old/PAS/!SPbSTU/ShellSort.pas

Program ShellSort;
{Сортировка Шелла, улучшение алгоритма прямого включения, разница в том,
 что процесс сортировки бьется на T этапов, в каждом из которых делается 
 один проход прямого включения, но только на элементы, отстоящие друг от 
 друга на h[i] эл-тов (i in [1..T] и h[T] = 1)

 Также для алгоритма прямой вставки удобно использовать "барьеры". Дабы
 при перемещении не сверять индекс эл-та с началом массива, удобно 
 расширить массив на 1 эл-т (в данном случае на h[1]) и туда писать эл-т,
 которому собираемся искать место. Таким образом размер массива будет
 [-h[1]..TotalCount]. Вследствие желания создать универсальный алгоритм
 с использованием динамических структур (нам заранее не известно T и 
 соответственно h[1]) будет использоваься смещенная индексация массива
 ( A[i] -> A[h[1]+i]).

 Используются улучшения Д. Кнута:
 h[k-1] := 3*h[k]+1;
 T := LOG(N,3)-1

 PS. Надеюсь весь этот бред поможет вам разобраться в предложенном алгоритме.}

type
 item = word;
const
 MaxCount = 65530 div SizeOf(item); {Максимальное число эл-тов массива}
 TotalCount = 20000;

type
 pArray = ^tArray;
 tArray = array [1..MaxCount] of Item;
 tIndex  = 1..MaxCount;

var
 T  : tIndex; {Число "разбиений"}
 h  : pArray;
 Fi : tIndex; {Реальный индекс первого эл-та (не барьера)}
 A  : pArray;

{--------------------------------------------------------------}
Procedure Init; {Устанавливаются улучш. Кнута, иниц. массивы}
var
 i : tIndex;
begin
 T := round(Ln(TotalCount)/Ln(3)-1); {(С) Кнут}
 GetMem(h,T*SizeOf(item)); {Иниц. массив расстояний}
 h^[T] := 1;
 for i := T-1 DownTo 1 do h^[i] := 3*h^[i+1]+1;
 Fi := h^[1]; {Установим глоб. индекс "смещенного" смещения}
 GetMem(A,(TotalCount+Fi)*Sizeof(Item)); {Иницализируем осн. массив}
                 {^^^ Для барьеров} 
end;{Init}
{--------------------------------------------------------------}
Procedure Done; {Осв. всю память}
begin
  FreeMem(h,T*SizeOf(Item));
  FreeMem(A,TotalCount*SizeOf(Item));
end;{Done}
{--------------------------------------------------------------}
Procedure SetArray; {Процедурка заполнения эл-тов массива случ. числами}
var
 i : tIndex;
begin
  Randomize;
  For i := 1 To TotalCount Do A^[Fi+i] := Random(65535);
                                {^^^ Опять барьеры}
end;{SetArray}
{--------------------------------------------------------------}

{Основная программа}
Var
 i,j,k,m,s : tIndex;
 Times     : pArray;
 x         : Item;

BEGIN
  Init;
  SetArray;

  GetMem(Times,T*SizeOF(Word));
  FillChar(Times^,T*SizeOF(Word),0);

  For m := 1 to T do
  begin
   k := h^[m]; {Расстояние между эл-тами}
   s := Fi-k;  {"барьер"}
   For i := k+1 to TotalCount do
   begin
     x := A^[Fi+i]; {Эл-т, с которым работаем}
     If S=Fi then S := Fi-k;
     inc(s);
     A^[s] := x;         {Установим "барьер"}
     j := i-k;           {Предыдущий через расстояние}
     while A^[Fi+j] > x do
      begin
       Inc(Times^[m]);
       A^[Fi+j+k] := A^[Fi+j]; {Двигаем массив}
       dec(j,k);
      end;
     A^[Fi+j+k] := x;
   end;
  end;

  For i := 1 to TotalCount do
  begin
   if ((i-1) mod 10) = 0 then WriteLN;
   Write(A^[Fi+i]:7);
  end;

  WriteLN(#10#13'Число перестановок на каждом этапе:');
  for i := 1 to T do WriteLn(i,'(',H^[i],') -> ',Times^[i]);

  FreeMem(Times,T*SizeOF(Word));

  Done;
END.