program HSortDem;                 {Demonstrate the HeapSort algorithm}
{$N+,E+}
uses CRT;
{$I GetInput.i }

type
Sequence = array[1..31] of integer;

var
A,                                {the sequence to be sorted}
A0                                {copy of the original sequence}
  : Sequence;
i,                                {an index of terms in the sequence}
n,                                {the number of terms in the sequence}
t,                                {temporary variable used for swapping}
r,                                {index of rows in display}
r0,                               {number of rows in display of heap}
tc,                               {total comparisons, book-keeping excluded}
ta,                               {total assignments of variables}
s,                                {step size for diagonal lines}
y                                 {cursor coordinate}
  : integer;
OriginalMode
  : word;
d                                 {amount of delay to insert}
  : real;
pwr2                              {powers of 2---needed for proper indenting}
  : array[0..5] of integer;

procedure HideCursor;

begin
  TextColor(0);
  GoToXY(1, 1);
  Write(' ');
  GoToXY(1, 1);
  TextColor(15)
end;

procedure Prompt;

var
x0, y0                    {coordinates of cursor location}
         : integer;
Ch       : Char;

begin
  x0 := WhereX;
  y0 := WhereY;
  GoToXY(1, 25);
  ClrEoL;
  Write('                      Press any key to continue . . . ');
  HideCursor;
  Ch := ReadKey;
  if Ch = #0
  then Ch := ReadKey;
  GoToXY(1, 25);
  ClrEoL;
  GoToXY(x0, y0)
end;                               {of procedure Prompt}

function x0(i : integer) : integer;    {calculate x cursor coord of a(i)}

var
r                                 {row that a(i) lies in}
  : integer;

begin
  r := 1;
  while pwr2[r] <= i do r := r + 1;
x0 := pwr2[r0 - r + 1] - pwr2[r0] + 39 + (i-pwr2[r-1])*pwr2[r0-r+2]
end;

function y0(i : integer) : integer;    {calculate y cursor coord of a(i)}

var
r                                 {row that a(i) lies in}
  : integer;

begin
  r := 1;
  while pwr2[r] <= i do r := r + 1;
  y0 := 4 + 2*r
end;

procedure slash(i : integer);     {draw diagonal lines to indicate
                                   branching of tree}
var
  i0
  : integer;

begin
  i0 := i div 2;
  GoToXY((x0(i) + x0(i0) + 2) div 2, y0(i) - 1);
  if i = 2*i0
  then Write('/')
  else Write('\')
end;

procedure HeapSort(var A : Sequence; n : integer);

var
  i
  : integer;

procedure Drop(i, k : integer);

var
i0,
i1,
j,
t
   : integer;

begin
  GoToXY(x0(i), y0(i));
  TextBackGround(7);
  Write('  ');
  TextBackground(0);
  i1 := i;
  t  := A[i];
  ta := ta + 1;
  GoToXY(43, 23);
  Write(ta:3);
  GoToXY(60, 4);
  ClrEoL;
  if i < 10
  then Write(' ');
  Write('a(', i:1, ') = ');
  Write(t:1);
  GoToXY(1, 20);
  ClrEoL;
  Write('     Have saved the value of a(', i:1, '), and will compare');
  WriteLn(' it');
  ClrEoL;
  Write('     with its subordinate');
  if 2*i < k
  then Write('s');
  WriteLn(', in preparation for possible promotion.');
  ClrEoL;
  Prompt;
  repeat
    i0 := i1;
    j := 2*i1;
    if j = k
    then
      begin
        TextColor(31);
        GoToXY(x0(k),y0(k));
        Write(A[k]:2);
        GoToXY(68, 4);
        Write(t:2);
        TextColor(15);
        GoToXY(1, 22);
        Write('     We compare a(', k:1, ') = ', A[k]:1, ' with ', t:1, '.');
        WriteLn;
        tc := tc + 1;
        GoToXY(43, 24);
        Write(tc:3);
        Prompt;
        GoToXY(68, 4);
        Write(t:2);
        GotoXY(x0(k), y0(k));
        Write(A[k]:2);
        if A[k] > t
        then
          begin
            GoToXY(1, 20);
            ClrEoL;
            GoToXY(1, 21);
            ClrEoL;
            GoToXY(1, 22);
            ClrEoL;
            GoToXY(6, 20);
            WriteLn('a(', j:1, ') = ', A[j]:1, ' is larger than ', t:1, ',');
            Write('     so we promote it.');
            Prompt;
            TextBackground(7);
            GoToXY(x0(k), y0(k));
            Write('  ');
            TextBackground(0);
            HideCursor;
            Delay(500);
            GoToXY(x0(i1), y0(i1));
            Write(A[j]:2);
            A[i1] := A[k];
            ta := ta + 1;
            GoToXY(43, 23);
            Write(ta:3);
            Prompt;
            i1 := k
          end
        else
          begin
            GoToXY(1, 20);
            ClrEoL;
            GoToXY(1, 21);
            ClrEoL;
            GoToXY(1, 22);
            ClrEoL;
            GoToXY(6, 20);
            Write('a(', j:1, ') = ', A[j]:1);
            WriteLn(' is smaller than ', t:1, ',');
            Write('     so ', t:1, ' has found its level.');
            Prompt;
            GoToXY(x0(j), y0(j));
            Write(A[j]:2)
          end;
      end;
    if j < k
    then
      begin
        TextColor(31);
        GoToXY(x0(j), y0(j));
        Write(A[j]:2);
        GoToXY(x0(j+1), y0(j+1));
        Write(A[j+1]:2);
        TextColor(15);
        GoToXY(1, 20);
        ClrEoL;
        Write('     We compare a(', j:1, ') = ', A[j]:1, ' with a(');
        WriteLn((j+1):1, ') = ', A[j+1]:1, '.');
        ClrEoL;
        WriteLn;
        ClrEoL;
        tc := tc + 1;
        GoToXY(43, 24);
        Write(tc:3);
        Prompt;
        GoToXY(x0(j), y0(j));
        Write(A[j]:2);
        GoToXY(x0(j+1), y0(j+1));
        Write(A[j+1]:2);
        if A[j+1] > A[j]
        then j := j + 1;
        GoToXY(1, 20);
        ClrEoL;
        GoToXY(1, 21);
        ClrEoL;
        GoToXY(1, 22);
        ClrEoL;
        GoToXY(6, 20);
        WriteLn('a(', j:1, ') = ', A[j]:1, ' is the larger subordinate,');
        Write('     so we compare it with ', t:1, '.');
        GoToXY(x0(j), y0(j));
        TextColor(31);
        Write(A[j]:2);
        GoToXY(68, 4);
        Write(t:2);
        TextColor(15);
        tc := tc + 1;
        GoToXY(43, 24);
        Write(tc:3);
        Prompt;
        GoToXY(68, 4);
        Write(t:2);
        GoToXY(x0(j), y0(j));
        Write(A[j]:2);
        GoToXY(1, 20);
        ClrEoL;
        if A[j] > t
        then
          begin
            Write('     We find that a(', j:1, ') = ', A[j]:1, ' is larger');
            WriteLn(' than ', t:1, ',');
            ClrEoL;
            WriteLn('     so we promote a(', j:1, ').');
            ClrEoL;
            Prompt;
            A[i1] := A[j];
            ta := ta + 1;
            GoToXY(43, 23);
            Write(ta:3);
            TextBackground(7);
            GoToXY(x0(j), y0(j));
            Write('  ');
            TextBackground(0);
            HideCursor;
            Delay(500);
            GoToXY(x0(i1), y0(i1));
            Write(A[i1]:2);
            Prompt;
            i1 := j
          end
        else
          begin
            Write('     We find that ', t:1, ' ò a(', j:1, ') = ', A[j]:1);
            WriteLn(',');
            ClrEoL;
            Write('     so ', t:1, ' has found its level.');
            Prompt;
          end;
      end
  until i0 = i1;
  A[i1] := t;
  ta := ta + 1;
  GoToXY(43, 23);
  Write(ta:3);
  GoToXY(x0(i1), y0(i1));
  Write(A[i1]:2);
  GoToXY(60, 4);
  ClrEoL;
  GoToXY(1, 22);
  ClrEoL;
  Write('     We return ', t:1, ' to the tree.');
  Prompt
end;                              {of Drop}

begin                             {main body of HeapSort}
  for i := n div 2 downto 1 do Drop(i, n);
  GoToXY(1, 20);
  ClrEoL;
  GoToXY(1, 21);
  ClrEoL;
  GoToXY(1, 22);
  ClrEoL;
  GoToXY(6, 20);
  WriteLn('We now have a heap.  Hence a(1) = ', A[1]:1, ' is the largest');
  WriteLn('     number in the heap.  We continue by swapping');
  WriteLn('     a(1) with the last entry, a(', n:1, ') = ', A[n]:1, '.');
  Prompt;
  for i := n downto 2 do
    begin
      if i < n
      then
        begin
          GoToXY(1, 20);
          ClrEoL;
          GoToXY(1, 21);
          ClrEoL;
          GoToXY(1, 22);
          ClrEoL;
          GoToXY(6, 20);
          Write('The demotion of a(1) has been completed; ');
          WriteLn('we have a heap again.');
          Write('     Hence a(1) = ', A[1]:1);
          WriteLn(' is the largest number in the heap.');
          Write('     We continue by swapping a(1) with a(');
          WriteLn(i:1, ') = ', A[i]:1, '.');
          Prompt
        end;
      t := A[i];
      A[i] := A[1];
      A[1] := t;
      ta := ta + 3;
      GoToXY(43, 23);
      Write(ta:3);
      GoToXY(x0(1), y0(1));
      TextBackground(7);
      Write('  ');
      GoToXY(x0(i), y0(i));
      Write('  ');
      TextBackground(0);
      HideCursor;
      Delay(500);
      GoToXY(x0(1), y0(1));
      Write(A[1]:2);
      GoToXY(x0(i), y0(i));
      TextColor(14);
      Write(A[i]:2);
      TextColor(0);
      slash(i);
      TextColor(15);
      GoToXY(1, 20);
      ClrEoL;
      GoToXY(1, 21);
      ClrEoL;
      GoToXY(1, 22);
      ClrEoL;
      GoToXY(6, 20);
      if i > 2
      then
        begin
          WriteLn('To restore the heap, we demote a(1) = ', A[1]:1, '.');
          if i = n
          then
            begin
              Write('     Note that a(', n:1, ') is no longer part of the');
              WriteLn(' heap.')
            end;
          if i = n - 1
          then
            begin
              Write('     Note that a(', i:1, '), a(', n:1, ') are no');
              WriteLn(' longer part of the heap.')
            end;
          if i < n - 1
          then
            begin
              Write('     Note that a(', i:1, '), ..., a(', n:1, ') are');
              WriteLn(' no  longer part of the heap.')
            end;
          Prompt;
          Drop(1, i-1)
        end
    end
end;                              {of HeapSort}

begin                             {main}
  OriginalMode := LastMode;
  TextColor(15);
  TextBackground(0);
  ClrScr;
  pwr2[0] := 1;
  for i := 1 to 5 do pwr2[i] := 2*pwr2[i-1];
  GoToXY(36, 2);
  Write('HEAPSORT');
  GoToXY(6, 17);
  WriteLn('Will sort a given sequence of numbers into increasing order.');
  n := round(GetInput(6, 18, 'Choose length of sequence, n = ',
                      '                           (0 ó n ó 31)', 1, 31));
  r0 := 1;
  while pwr2[r0] <= n do r0 := r0 + 1;
  GoToXY(6, 18);
  Write('We arrange the numbers in the form of a binary tree, as');
  WriteLn(' depicted above.');
  HideCursor;
  delay(1000);
  for i := 1 to n do
    begin
      GoToXY(x0(i), y0(i));
      Write('a', i:1);
      if i > 1
      then slash(i)
    end;
  Prompt;
  GoToXY(6, 19);
  Write('Now generating a random sequence of ', n:1, ' numbers, ');
  WriteLn('each one in [0, 99].');
  HideCursor;
  Delay(1000);
  Randomize;
  for i := 1 to n do
    begin
      a[i] := random(100);
      a0[i] := a[i]
    end;
  GoToXY(6, 20);
  Write('The values are: ');
  for i := 1 to n do
    begin
      if WhereX < 73
      then Write(a[i]:1)
      else
        begin
          WriteLn;
          Write('     ', a[i]:1)
        end;
      if i < n
      then Write(', ')
      else Write('.')
    end;
  y := WhereY;
  Prompt;
  GoToXY(1, y+1);
  Write('     As a binary tree, the sequence looks like this:');
  HideCursor;
  Delay(1000);
  ClrScr;
  GoToXY(36, 2);
  Write('HEAPSORT');
  for i := 1 to n do
    begin
      GoToXY(x0(i), y0(i));
      Write(a[i]:2);
      if i > 1
      then slash(i)
    end;
  HideCursor;
  Delay(1000);
  GoToXY(1, 16);
  Write('     The first step is to demote');
  WriteLn(' entries that fail to be larger than both');
  Write('     of their subordinates.  That');
  WriteLn(' is, if a(i) is smaller than a(2i) or');
  Write('     a(2i+1) then a(i) is swapped');
  WriteLn(' with the larger of a(2i) and a(2i+1).');
  Write('     This starts at the bottom');
  WriteLn(' (high indices), and proceeds toward the');
  Write('     top.  When this first step');
  WriteLn(' is completed, we have a(i) ò a(2i) and');
  Write('     a(i) ò a(2i+1) for all i,');
  WriteLn(' and we say that we have a "heap."  Since');
  Write('     a(i) may be demoted through');
  WriteLn(' several levels, we save a little time');
  Write('     with the swaps by removing');
  WriteLn(' a(i) from the table and promoting');
  Write('     subordinates, until the terminal');
  WriteLn(' position of a(i) has been found.');
  Prompt;
  for i := 15 to 25 do
    begin
      GoToXY(1, i);
      ClrEoL
    end;
  ta := 0;
  tc := 0;
  GoToXY(1, 23);
  WriteLn('          Number of variable assignments: ', ta:3);
  WriteLn('          Number of comparisons:          ', tc:3);
  Prompt;
  HeapSort(A, n);
  GoToXY(1, 20);
  ClrEoL;
  GoToXY(1, 21);
  ClrEoL;
  GoToXY(1, 22);
  ClrEoL;
  GoToXY(1, 20);
  Write('     The remaining tree contains only one element, ');
  WriteLn('so it is sorted.');
  HideCursor;
  Delay(500);
  TextColor(14);
  GoToXY(x0(1), y0(1));
  Write(A[1]:2);
  TextColor(15);
  Prompt;
  ClrScr;
  GoToXY(36, 4);
  Write('SUMMARY');
  GoToXY(31, 8);
  Write('ORIGINAL SEQUENCE');
  GoToXY(6, 10);
  for i := 1 to n do
    begin
      Write(A0[i]:2);
      if i < n
      then Write(', ');
      if WhereX > 72
      then
        begin
          WriteLn;
          Write('     ')
        end
    end;
  GoToXY(32, 14);
  Write('SORTED SEQUENCE');
  GoToXY(6, 16);
  for i := 1 to n do
    begin
      Write(A[i]:2);
      if i < n
      then Write(', ');
      if WhereX > 72
      then
        begin
          WriteLn;
          Write('     ')
        end
    end;
  GoToXY(1, 20);
  WriteLn('          Number of variable assignments: ', ta:3);
  WriteLn('          Number of comparisons:          ', tc:3);
  Prompt;
  TextMode(OriginalMode)
end.