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.