Пирамидальная сортировка

Алгоритм пирамидальной сортировки (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.

Вот и всё, Удачи!