Алгоритм пирамидальной сортировки (heapsort) — один из самых быстрых алгоритмов сортировки.

Program heapsort; 
 
{$APPTYPE CONSOLE} 
 
type 
 tkey = integer; 
 int = integer; 
 
const N = 10; 
 
var a,b : array [0..N+1] of tkey; 
 
function parent(x : int) : int; 
begin 
 result:=x shr 1; 
end; 
 
function left(x : int) : int; 
begin 
 result := x shl 1; 
 if result > a[0] then result := N+1; 
end; 
 
function right(x:int):int; 
begin 
 result := x shl 1 + 1; 
 if result > a[0] then result := N+1; 
end; 
 
procedure swap(i,j : int); 
var temp : tkey; 
begin 
 temp := a[i]; 
 a[i] := a[j]; 
 a[j] := temp; 
end; 
 
procedure moveup(x : int); 
begin 
 while (a[x] > a[parent(x)]) and (parent(x) > 0) do begin 
 swap(x, parent(x)); 
 x := parent(x); 
 end; 
end; 
 
procedure movedown(x : int); 
var max : integer; 
begin 
 if a[left(x)] > a[right(x)] then max := left(x) 
 else max := right(x); 
 while (a[max] > a[x]) and (max <= a[0]) do begin 
 swap(max, x); 
 x := max; 
 if a[left(x)] > a[right(x)] then max := left(x) 
 else max := right(x); 
 end; 
end; 
 
 
procedure update(x : int; k : tkey); 
begin 
 a[x] := k; 
 moveup(x); 
 movedown(x); 
end; 
 
procedure add(k : tkey); 
begin 
 inc(a[0]); 
 update(a[0], k); 
end; 
 
procedure delete(x : int); 
begin 
 swap(x, a[0]); 
 dec(a[0]); 
 update(x, a[x]); 
end; 
 
procedure hsort; 
var i:int; 
begin 
 a[0] := 1; 
 a[1] := b[1]; 
 for i := 2 to N do 
 add(b[i]); 
 for i := 1 to N do 
 delete(1); 
end; 
 
var i : int; 
 
begin 
 randomize; 
 fillchar(a, sizeof(a), 0); 
 fillchar(b, sizeof(b), 0); 
 
 for i := 1 to N do 
 b[i] := random(10); 
 
 writeln('Non-sorted elements'); 
 for i := 1 to N do 
 write(b[i], ' '); 
 writeln; 
 
 hsort; 
 
 writeln('Sorted elements'); 
 for i := 1 to N do 
 write(a[i], ' '); 
 readln; 
end.

Получить ссылку на материал