old/PAS/!SPbSTU/HeapSort.pas

Program HeapSort;
{Ну что, дождались вы и этой чертовой пирамидальной сортировки
 Я все-таки врубился как там что. Оказалось еще более сложно чем казалось
 вначале. Основная идея:
   - Дерева никакого нет, и не было!
   - Зато эта долбаная пирамида соществует в твоем мозгу
      С САМОГО НАЧАЛА В ПОЛНОМ РАЗМЕРЕ!
   - Ну и типа мы с нижних рядов едем в верх, на каждом шаге
     просеивая текущий эл-т через пирамиду (см. Н. Вирта)
   - Таким хреном отехав с середины до самого верха, т.е. просеив все эл-ты
     мы получили эту долбанную пирамиду, с условием что два сина всегда 
     больше отца!
   - Потом - совершенно другой этап: сама сортировка и есть.
     1) Т.к. пирамида удовлетворяет усл. (A[i] < A[2i]) AND (A[i] < A[2i+1])
        значит A[1] - самый маленький элемент ! 
     2) Ну мы его и пихаем в последний эл-т пирамиды, а его - в голову и 
        просеиваем. Таким образом на верху - опять самый маленький.
        И при этом уменшаем длину нашей пирамиды на 1
     3) Пока наша пирамида еще не пустая повторяем.
     4) Таким хреном - у нас обратно отсортированный массив. Ну все сравнения
        - наоборот - вот тебе и прямая сортировка!

PS. попробую это в коде откомментировать ;)
}

CONST
 ArLen = 10;
TYPE
 Index = 1..ArLen;
 Item  = word;
VAR
 Pir : array [1..ArLen] of Item;

Procedure Sift(L,R:word);{Блин! Sift - просеивать по англицки!}
var
 i, j : Index;
 x    : Item;
{В этой процедуре самое важное - L и R, они отвечают не просто зи индексы,
 а еще говорят о том, какая часть пирамиды сейчас реально рассматривается}
begin
 i := L; {Тот, который меняем}
 j := 2*i; {На кого можно менять}
 x := Pir[L]; {Кого просеиваем}
 if (j<R) AND (Pir[j] < Pir[J+1]) then Inc(j); {Выберем наибольшего потомка}
 while (j<=R) and (x < Pir[j]) do
 begin
  Pir[i] := Pir[j]; {Обменяли, достаточно просто заменить себя на своего сына
                     т.к сам - x и он никуда не денется} 
  i := j; {Спустились}
  j := 2*i;
  if (j<R) AND (Pir[j] < Pir[J+1]) then Inc(j); {Выберем наибольшего потомка}
 end;
 Pir[i] := x; {Ну вот и вернем x на место}
              {Я НЕ ПОНИМАЮ ПОЧЕМУ ЭТОЙ СТРОКИ НЕТ В ВИРТЕ }
end;{Sift}
{-------------------------}
VAR
 L,R : index;
 x : item;
BEGIN
 Randomize;
 for l := 1 to ArLen do Pir[l] := Random(200);

 L := ArLen Div 2 + 1; {Идея - нижняя часть - не требует просевки}
 R := ArLen;

 while L>1 do 
  begin
   Dec(L);
   Sift(L,R);
  end;
 
 While R > 1 do
 begin
  x := Pir[R];
  Pir[R]:=Pir[1]; {Идея о впихивании верхнего в конец пирамиды}
  Pir[1] := x;    
  Dec(R);
  Sift(L,R);
 end; 
 for l := 1 to ArLen do WriteLn(Pir[l]);
END.