Cod sursa(job #1405499)

Utilizator ButnaruButnaru George Butnaru Data 29 martie 2015 12:18:21
Problema Sortare prin comparare Scor 100
Compilator fpc Status done
Runda Arhiva educationala Marime 1.12 kb
//Heap sort
program algsort;
type tabel=array[0..500001] of longint;
     buf=array[0..1 shl 17] of char;
var heap:tabel; ff1,ff2:buf;
    n,i,nr,x:longint;
    f1,f2:text;
procedure swap(var a,b:longint);
var aux:longint;
begin aux:=a; a:=b; b:=aux; end;
procedure heapdown(v:longint);
var w:longint;
begin
w:=v*2;
while w<=nr do begin
if (w<nr) and (heap[w]>heap[w+1]) then w:=w+1;
if heap[v]>heap[w] then swap(heap[v],heap[w]) else break;
v:=w; w:=w*2;
end;
end;
procedure heapup(v:longint);
var k:longint;
begin
k:=heap[v];
while (v>1) and (heap[v]<heap[v div 2]) do begin
swap(heap[v],heap[v div 2]);
v:=v div 2;
end;
heap[v]:=k;
end;
procedure add_heap(x:longint);
begin
nr:=nr+1; heap[nr]:=x;
heapup(nr);
end;
procedure delet_heap;
begin
swap(heap[1],heap[nr]); nr:=nr-1;
heapdown(1);
end;
begin
assign (f1,'algsort.in');
assign (f2,'algsort.out');
reset (f1);
rewrite (f2);
settextbuf(f1,ff1);
settextbuf(f2,ff2);
readln (f1,n);nr:=0;
for i:=1 to n do begin
read(f1,x); add_heap(x);
end;
for i:=1 to n do begin write (f2,heap[1],' '); delet_heap; end;
close (f1);
close (f2);
end.