Программа для сортировки одномерного массива — Pascal(Паскаль)

program SORT_ARRAY;

{$M 65520, 0, 655360}

  { Необязательно, но используется при подсчете времени }
  uses Crt;

  const
    { Размер массива }
    max = 16000;
    { Диапазон случайных чисел }
    randmax : Longint = 16000000;
    theword : Longint = 65536;


  type
    { Тип элемента сортируемого массива }
    itp = Longint;
    { Тип массива }
    mas = array [0..max] of itp;
    { Тип процедуры для сортировки или заполнения массива }
    Func = procedure ( var A : mas );

{ Необходимая директива для использования переменных типа процедуры }
{$F+}

  { Заполнение массива числами по возрастанию }
  procedure FillInc( var A : mas );
    var
      i : Integer;
    begin
      for i := 1 to max do
        A[i] := i;
    end;

  { Заполнение массива числами по убыванию }
  procedure FillDec( var A : mas );
    var
      i : Integer;
    begin
      for i := 1 to max do
        A[i] := max - i;
    end;

  { Заполнение массива равными числами (0) }
  procedure FillZero( var A : mas );
    var
      i : Integer;
    begin
      for i := 1 to max do
        A[i] := 0;
    end;

  { Заполнение массива случайными числами }
  procedure FillRand( var A : mas );
    var
      i : Integer;
      t : LongInt;
    begin
      for i := 1 to max do
        begin
          t := Random(32768);
          t := t * 32768;
          t := t + Random(32768);
          A[i] := t mod randmax;
        end;
    end;

  { Сортировка вставками }
  procedure InsertSort( var A : mas );
    var
      i, k : Integer;
      x : itp;
    begin
      { Вставляем в уже отсортированную часть элементы со 2 по max }
      for i := 2 to max do
        begin
          k := i;
          x := A[i];
          { Передвигаем на 1 позицию направо элементы,
            большие вставляемого элемента (он записан в x) }
          { Условие k > 1 гарантирует, что мы не выйдем за
            границу массива, если вставляется элемент,
            меньший всех предыдущих.
            В Turbo Pascal условия вычисляются в обратном порядке,
            поэтому условие цикла while нужно заменить на
            (A[k - 1] > x) and (k > 1) }
          while (k > 1) and (A[k - 1] > x) do
            begin
              A[k] := A[k - 1];
              k := k - 1;
            end;
          { Вставляем элемент в нужную позицию }
          A[k] := x;
        end;
    end;

  { Сортировка выбором }
  procedure SelectSort2(var A : mas);
    var
      i, j, m : Integer;
      x : itp;
    begin
      { Ищем элементы для позиций с 1 по max - 1 }
      for i := 1 to max - 1 do
        begin
          m := i;
          x := A[i];
          { Просматриваем все еще не выбранные элементы }
          for j := i + 1 to max do
            { Если встречается элемент, меньший того, что сейчас
              стоит на позиции m, запоминаем в m его позицию,
              а в x - его значение }
            if x > A[j] then
              begin
                m := j;
                x := A[j];
              end;
            { Меняем местами i-ый элемент, и минимальный из оставшихся -
              m-ый элемент, сохраненный в x }
            A[m] := A[i];
            A[i] := x;
        end;
    end;

  { Сортировка "пузырьком" }
  procedure BubbleSort( var A : mas );
    var
      i, j : Integer;
      x : itp;
    begin
      for i := max downto 2 do
        for j := 2 to i do
          if A[j] < A[j - 1] then
            begin
              x := A[j];
              A[j] := A[j - 1];
              A[j - 1] := x;
            end;
    end;

{ Сортировка Шелла }
  procedure ShellSort( var A : mas );
    const
      steps = 12;
    var
      i, j, l, k, p, n : Integer;
      x : itp;
      s : array [1..steps] of Integer;
    begin
      k := 1;
      { Формируем последовательность чисел -
        шаги, с которыми выбираем сортируемые подмассивы }
      for i := steps downto 1 do
        begin
          s[i] := k;
          k := k * 2 + 1;
        end;

      { Сортировки подмассивов вплоть до шага 1 -
        обычной сортировки пузырьком }
      for k := 1 to steps do
        begin
          l := s[k];
          { Для каждого шага l нужно отсортировать l подмассивов }
          for p := 1 to l do
            begin
              i := max - l;
              n := 1;
              { Сортировка подмассива пузырьком с остановкой }
              { Подмассив - это (A[p], A[p+l], A[p+2*l], ...) }
              while n > 0 do
                begin
                  n := 0;
                  j := p;
                  while j <= i do
                    begin
                      if A[j] > A[j + l] then
                        begin
                          x := A[j];
                          A[j] := A[j + l];
                          A[j + l] := x;
                          n := 1;
                        end;
                      j := j + l;
                    end;
                  i := i - l;
                end;
            end;
        end;
    end;

{$F-}

  { Проверка того, что массив отсортирован }
  function CheckArray( var A : mas ) : Boolean;
    var
      i : Integer;
    begin
      CheckArray := TRUE;
      for i := 1 to max - 1 do
        if A[i] > A[i + 1] then
          CheckArray := FALSE;
    end;

  { Вывод элементов массива на экран }
  procedure PrintArray( var A : mas );
    var
      i : Integer;
    begin
      WriteLn;
      for i := 1 to max do
        Write(A[i] : 16);
      WriteLn;
    end;

  var
    A : mas;
    Fill  : array [1..4] of Func;
    FillS : array [1..4] of string[24];
    Sort  : array [1..20] of Func;
    SortS : array [1..20] of string[24];
    i, j : Integer;
    Time : Longint;
  begin
    FillS[1] := 'Random';
    FillS[2] := 'Increasing';
    FillS[3] := 'Equal';
    FillS[4] := 'Decreasing';
    Fill[1] := FillRand;
    Fill[2] := FillInc;
    Fill[3] := FillZero;
    Fill[4] := FillDec;
    SortS[1] := 'Insertion';
    SortS[2] := 'Selection';
    SortS[3] := 'Bubble';
    SortS[4] := 'Shell';
    Sort[1] := InsertSort;
    Sort[2] := SelectSort2;
    Sort[3] := BubbleSort;
    Sort[4] := ShellSort;

    Write('' : 24);
    for i := 1 to 4 do
      Write(FillS[i] : 12);
    WriteLn;
    for i := 1 to 4 do
      begin
        Write(SortS[i] : 24);
        for j := 1 to 4 do
          begin
            Fill[j](A);
            Time := Meml[$40 : $6C];
            Sort[i](A);
            Time := Meml[$40 : $6C] - Time;
            if CheckArray(A) then
              Write(Time : 12)
            else
              begin
                Write('Failed' : 12);
{                PrintArray(A);}
              end;
          end;
        WriteLn;
      end;
      readln;
  end.