Сортировки

{
  Описание всех алгоритмов можно найти в книге:
      Кнут Д., Искусство программирования для ЭВМ, Т. 3.:
        Сортировка и поиск. М.: Мир, 1978.
  Описание почти всех алгоритмов в книге:
      Кормен Т., Лейзерсон Ч., Ривест Р., Алгоритмы:
        построение и анализ. М.: МЦНМО, 1999.
  Описание некоторых алгоритмов в книге:
      Романовский И., Дискретный анализ,
        СПб.: Невский диалект, 1999.
}
 
program SORT_ARRAY;
 
{ Увеличение размера стека - нужно для рекурсивных алгоритмов
  MergeSort и QuickSort }
{$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 );
    { Массивы для цифровой сортировки и сортировки вычерпыванием }
    C8T = array [0..256] of Integer;
    C12T = array [0..4096] of Integer;
 
{ Необходимая директива для использования переменных типа процедуры }
{$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 InsertSort2( var A : mas );
    var
      i, k : Integer;
      x : itp;
    begin
      { Вставляем ограничитель, меньший каждого элемента массива }
      A[0] := -1;
      { Вставляем в уже отсортированную часть элементы со 2 по max }
      for i := 2 to max do
        begin
          k := i;
          x := A[i];
          { Передвигаем на 1 позицию направо элементы,
            большие вставляемого элемента (он записан в x) }
          { Здесь не нужно проверять k > 1, так как есть ограничитель
            и всегда будет A[0] < x }
          while A[k - 1] > x do
            begin
              A[k] := A[k - 1];
              k := k - 1;
            end;
          { Вставляем элемент в нужную позицию }
          A[k] := x;
        end;
    end;
 
  { Сортировка выбором без запоминания минимума }
  procedure SelectSort( var A : mas );
    var
      i, j, m : Integer;
      x : itp;
    begin
      { Ищем элементы для позиций с 1 по max - 1 }
      for i := 1 to max - 1 do
        begin
          m := i;
          { Просматриваем все еще не выбранные элементы }
          for j := i + 1 to max do
            { Если встречается элемент, меньший того, что сейчас
              стоит на позиции m, запоминаем в m его позицию  }
            if A[j] < A[m] then
              m := j;
          { Меняем местами i-ый элемент и минимальный из оставшихся -
            m-ый элемент }
          x := A[i];
          A[i] := A[m];
          A[m] := 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 ShakerSort( var A : mas );
    var
      l, r, j : Integer;
      x : itp;
    begin
      l := 2;
      r := max;
      while l <= r do
        begin
          { "Пузырек" слева направо }
          for j := l to r do
          if A[j] < A[j - 1] then
            begin
              x := A[j];
              A[j] := A[j - 1];
              A[j - 1] := x;
            end;
          r := r - 1;
          { "Пузырек" справа налево }
          for j := r downto l do
          if A[j] < A[j - 1] then
            begin
              x := A[j];
              A[j] := A[j - 1];
              A[j - 1] := x;
            end;
          l := l + 1;
        end;
    end;
 
  { Сортировка "пузырьком" с остановкой }
  procedure BubbleSort2( var A : mas );
    var
      i, j, n : Integer;
      x : itp;
    begin
      i := max;
      n := 1;
      { Пока производились обмены элементов }
      while n > 0 do
        begin
          n := 0;
          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;
                n := 1;
              end;
          i := i - 1;
        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;
 
  { Объединение двух массивов для сортировки слиянием }
  procedure Merge( var A, P : mas; l, m, r : Integer );
    var
      i, j, k, z : Integer;
      A2 : mas;
    begin
      z := r - l + 1;
      i := l;
      j := m;
      k := 1;
      { Пока на "слили" все элементы от l до r }
      while k <= z do
        begin
          { Элемент из первого массива меньше или
            во втором массиве закончились элементы }
          if (j > r) or ((i < m) and (A[i] < A[j])) then
            begin
              A2[k] := A[i];
              i := i + 1;
            end
          { Элемент из второго массива меньше или
            в первом массиве закончились элементы }
          else
            begin
              A2[k] := A[j];
              j := j + 1;
            end;
          k := k + 1;
        end;
      i := l;
      { Копируем слитые элементы обратно в массив A }
      for k := 1 to z do
        begin
          A[i] := A2[k];
          i := i + 1;
        end;
    end;
 
  { Процедура рекурсивной сортировки слиянием }
  procedure RecoursiveMerge(var A, P : mas; l, r : Word);
    var
      m : Integer;
    begin
      m := (l + r + 1) div 2;
      { Сортируем первую половину }
      if l < m then
        RecoursiveMerge(A, P, l, m - 1);
      { Сортируем вторую половину }
      if m < r then
        RecoursiveMerge(A, P, m, r);
      { Сливаем два отсортированных массива }
      Merge(A, P, l, m, r);
    end;
 
  { Сортировка слиянием }
  procedure MergeSort( var A : mas );
    var
      p : ^mas;
    begin
      New(p);
      RecoursiveMerge(A, p^, 1, max);
      Dispose(p);
    end;
 
  { Процедура рекурсивной сортировки слиянием с подсортировкой }
  procedure RecoursiveMerge2(var A, P : mas; l, r, b : Word);
    var
      i, k, m : Integer;
      x : itp;
    begin
      { Если количество элементов в сортируемом массиве меньше b,
        сортируем его вставками }
      if r - l < b then
        begin
          for i := l + 1 to r do
            begin
              k := i;
              x := A[i];
              while (k > l) and (A[k - 1] > x) do
                begin
                  A[k] := A[k - 1];
                  k := k - 1;
                end;
              A[k] := x;
            end;
        end
      { Если количество элементов в сортируемом массиве больше b,
        делим его на две половины, сортируем их и затем сливаем }
      else
        begin
          m := (l + r) div 2;
          RecoursiveMerge2(A, P, l, m - 1, b);
          RecoursiveMerge2(A, P, m, r, b);
          Merge(A, P, l, m, r);
        end;
    end;
 
  { Сортировка слиянием с подсортировкой вставками по 10 элементов }
  procedure MergeSort10( var A : mas );
    var
      p : ^mas;
    begin
      New(p);
      RecoursiveMerge2(A, p^, 1, max, 10);
      Dispose(p);
    end;
 
  { Сортировка слиянием с подсортировкой вставками по 100 элементов }
  procedure MergeSort100( var A : mas );
    var
      p : ^mas;
    begin
      New(p);
      RecoursiveMerge2(A, p^, 1, max, 100);
      Dispose(p);
    end;
 
  { Сортировка слиянием с подсортировкой вставками по 1000 элементов }
  procedure MergeSort1000( var A : mas );
    var
      p : ^mas;
    begin
      New(p);
      RecoursiveMerge2(A, p^, 1, max, 1000);
      Dispose(p);
    end;
 
  { Процедура разбиения массива для быстрой сортировки }
  function Partition( var A : mas; l, r : Integer; x : itp ) : Integer;
  { Переставляем элементы массива так, чтобы слева от элемента,
    равного x, были только элементы меньшие или равные x,
    а справа - элементы, большие или равные x }
    var
      i, j : Integer;
      t : itp;
    begin
      i := l - 1;
      j := r + 1;
      repeat
 
        { Пока элементы справа больше среднего }
        repeat
          j := j - 1;
        until x >= A[j];
 
        { Пока элементы слева меньше среднего }
        repeat
          i := i + 1;
        until A[i] >= x;
 
        { Меняем левый и правый элементы и продолжаем дальше }
        if i < j then
          begin
            t := A[i];
            A[i] := A[j];
            A[j] := t;
          end;
        { Иначе - левый и правый встретились -
          разбиение массива завершено }
 
      until i >= j;
      Partition := j;
    end;
 
  { Рекурсивная процедура быстрой сортировки }
  procedure RecoursiveQuick( var A : mas; l, r : Integer );
    var
      m : Integer;
    begin
      if l < r then
        begin
          { В качестве граничного элемента выбирается средний
            элемент массива }
          m := Partition(A, l, r, A[(l + r) div 2]);
          RecoursiveQuick(A, l, m);
          RecoursiveQuick(A, m + 1, r);
        end;
    end;
 
  { Быстрая сортировка }
  procedure QuickSort( var A : mas );
    begin
      RecoursiveQuick(A, 1, max);
    end;
 
  { Рекурсивная процедура рандомизированной быстрой сортировки }
  procedure RecoursiveRandomQuick( var A : mas; l, r : Integer );
    var
      m : Integer;
    begin
      if l < r then
        begin
          { В качестве граничного элемента выбирается элемент
            массива со случайным номером }
          m := Partition(A, l, r, A[Random(r - l + 1) + l]);
          RecoursiveRandomQuick(A, l, m);
          RecoursiveRandomQuick(A, m + 1, r);
        end;
    end;
 
  { Рандомизированная быстрая сортировка }
  procedure RandomQuickSort( var A : mas );
    begin
      RecoursiveRandomQuick(A, 1, max);
    end;
 
  { Рекурсивная процедура быстрой сортировки с выбором медианы }
  procedure RecoursiveMedianQuick( var A : mas; l, r : Integer );
    var
      m : Integer;
      x1, x2, x3 : itp;
    begin
      if l < r then
        begin
          { В качестве граничного элемента выбирается средний
            по величине элемент из трех }
          x1 := A[l + (r - l + 1) div 4];
          x2 := A[(l + r) div 2];
          x3 := A[Integer(l + Longint(r - l + 1) * 3 div 4)];
          if x1 < x2 then
            begin
              if x3 < x2 then
                begin
                  if x1 < x3 then
                    x2 := x3
                  else
                    x2 := x1
                end
            end
          else { x1 > x2 }
            begin
              if x3 > x2 then
                begin
                  if x1 > x3 then
                    x2 := x3
                  else
                    x2 := x1
                end
            end;
 
          m := Partition(A, l, r, x2);
          RecoursiveMedianQuick(A, l, m);
          RecoursiveMedianQuick(A, m + 1, r);
        end;
    end;
 
  { Быстрая сортировка с выбором медианы по 3 элементам }
  procedure MedianQuickSort( var A : mas );
    begin
      RecoursiveMedianQuick(A, 1, max);
    end;
 
  { Исправление кучи с неправильным элементом в вершине }
  procedure HeapCorrect( var A : mas; Bound, n : Integer );
  { Перестановка элементов упорядоченной кучи, на вершине
    которой - единственный неупорядоченный элемент так,
    чтобы куча снова стала упорядоченной }
    var
      l, r, i : Integer;
      x : itp;
    begin
      { n - вершина кучи }
      { l - левый ребенок вершины, r - правый ребенок }
      l := n * 2;
      r := l + 1;
 
      { В i - номер максимального элемента из n, l и r }
      i := n;
      if r <= Bound then
        begin
          if A[l] > A[i] then
            i := l;
          if A[r] > A[i] then
            i := r;
        end
      else if l <= Bound then
        begin
          if A[l] > A[i] then
            i := l;
        end;
 
      { Если максимальный элемент не в вершине,
        меняем максимальный элемент с вершиной и
        вызываем HeapCorrect для подкучи, на вершину которой
        попал элемент из вершины }
      if i <> n then
        begin
          x := A[i];
          A[i] := A[n];
          A[n] := x;
          HeapCorrect(A, Bound, i);
        end;
    end;
 
  { Сортировка при помощи кучи }
  procedure HeapSort( var A : mas );
    var
      i, Bound : Integer;
      x : itp;
    begin
      { Строим упорядоченную кучу }
      for i := (max + 1) div 2 downto 1 do
        HeapCorrect(A, max, i);
 
      Bound := max;
      while Bound > 1 do
        begin
          { Меняем последний элемент кучи с максимальным
            элементом в вершине кучи }
          x := A[1];
          A[1] := A[Bound];
          A[Bound] := x;
          { Уменьшаем размер кучи }
          Bound := Bound - 1;
          { Упорядочиваем кучу }
          HeapCorrect(A, Bound, 1);
        end;
    end;
 
  { Сортировка подсчетом по n-ой 256-ричной цифре }
  procedure Counting8Sort( var A : mas; n: Integer );
    var
      i, j, k, s, index : Integer;
      P : ^mas;
      C : C8T;
    begin
      { Вычисляем сдвиг для n-ой цифры }
      s := 8 * n;
 
      New(P);
 
      { Обнуляем массив частот }
      for i := 0 to 255 do
        C[i] := 0;
 
      { Считаем частоты появления всех цифр в n-ой позиции }
      { Заодно копируем массив A в P^ }
      for i := 1 to max do
        begin
          { index - это значение n-ой цифры }
          index := (A[i] shr s) and 255;
          C[index] := C[index] + 1;
          P^[i] := A[i];
        end;
 
      { Сейчас в каждом C[i] - количество элементов массива A,
        у которых n-ая цифра равна i }
      { После следующего цикла в каждом C[i] будет записано
        количество элементов, с n-ой цифрой, не превосходящей i,
        а это то же самое, что номер последнего элемента
        с n-ой цифрой, равной i }
      for i := 1 to 255 do
        C[i] := C[i] + C[i - 1];
 
      { Переписываем элементы из массива P^ в A, начиная с последнего,
        в соответствии с номерами, записанными в C. Номер последнего
        элемента с n-ой цифрой, равной i, - C[i] - после записи
        элемента в позицию C[i] уменьшаем на 1 }
      for i := max downto 1 do
        begin
          index := (P^[i] shr s) and 255;
          A[C[index]] := P^[i];
          C[index] := C[index] - 1;
        end;
 
      Dispose(P);
    end;
 
  { Цифровая сортировка для 8-разрядных цифр }
  procedure Digital8Sort( var A : mas );
    var
      n : Integer;
      t : itp;
    begin
      t := randmax;
      n := 0;
      { Сортировка по всем цифрам, начиная с последней }
      while t > 0 do
        begin
          Counting8Sort(A, n);
          n := n + 1;
          t := t shr 8;
        end;
    end;
 
  { Сортировка подсчетом по n-ой 4096-ричной цифре }
  procedure Counting12Sort( var A : mas; n: Integer );
    var
      i, j, k, index : Integer;
      P : ^mas;
      C : C12T;
      s : Longint;
      bug : Integer;
    begin
      { Вычисляем сдвиг для n-ой цифры }
      s := 12 * n;
 
      { Переменная bug используется вместо числа 4095 -
        в общем случае это неверно, но таким образом
        обходится ошибка в Borland Pascal, где
        неправильно выполняется операция x shr 24 }
      if s = 24 then
        bug := 255
      else
        bug := 4095;
 
      New(P);
 
      { Обнуляем массив частот }
      for i := 0 to 4095 do
        C[i] := 0;
 
      { Считаем частоты появления всех цифр в n-ой позиции }
      { Заодно копируем массив A в P^ }
      for i := 1 to max do
        begin
          { index - это значение n-ой цифры }
          index := (A[i] shr s) and bug;
          C[index] := C[index] + 1;
          P^[i] := A[i];
        end;
 
      { Сейчас в каждом C[i] - количество элементов массива A,
        у которых n-ая цифра равна i }
      { После следующего цикла в каждом C[i] будет записано
        количество элементов, с n-ой цифрой, не превосходящей i,
        а это то же самое, что номер последнего элемента
        с n-ой цифрой, равной i }
      for i := 1 to 4095 do
        C[i] := C[i] + C[i - 1];
 
      { Переписываем элементы из массива P^ в A, начиная с последнего,
        в соответствии с номерами, записанными в C. Номер последнего
        элемента с n-ой цифрой, равной i, - C[i] - после записи
        элемента в позицию C[i] уменьшаем на 1 }
      for i := max downto 1 do
        begin
          index := (P^[i] shr s) and bug;
          A[C[index]] := P^[i];
          C[index] := C[index] - 1;
        end;
 
      Dispose(P);
    end;
 
  { Цифровая сортировка для 12-разрядных цифр }
  procedure Digital12Sort( var A : mas );
    var
      n : Integer;
      t : itp;
    begin
      t := randmax;
      n := 0;
      { Сортировка по всем цифрам, начиная с последней }
      while t > 0 do
        begin
          Counting12Sort(A, n);
          n := n + 1;
          t := t shr 12;
        end;
    end;
 
  { Сортировка вычерпыванием по 256 частям }
  procedure Bucket8Sort( var A : mas );
    var
      i, index, j, k : Integer;
      d, x : itp;
      P : ^mas;
      C : C8T;
    begin
      { Определяем размер каждой части }
      d := (randmax div 256) + 1;
 
      New(P);
 
      { Определяем количества элементов массива A,
        попадающих в каждую часть -
        так же, как в цифровой сортировке }
      for i := 0 to 256 do
        C[i] := 0;
      for i := 1 to max do
        begin
          index := A[i] div d;
          C[index] := C[index] + 1;
          P^[i] := A[i];
        end;
      for i := 1 to 256 do
        C[i] := C[i] + C[i - 1];
 
      { Переписываем элементы массива так, что сначала идут
        элементы, попавшие в первую часть, затем - элементы
        из второй части }
      for i := max downto 1 do
        begin
          index := P^[i] div d;
          A[C[index]] := P^[i];
          C[index] := C[index] - 1;
        end;
 
      { Остается только отсортировать элементы внутри каждой части -
        используем для этого сортировку вставками }
      for i := 0 to 255 do
        begin
          for j := C[i] + 2 to C[i + 1] do
            begin
              k := j;
              x := A[j];
              while (k > C[i] + 1) and (A[k - 1] > x) do
                begin
                  A[k] := A[k - 1];
                  k := k - 1;
                end;
              A[k] := x;
            end;
        end;
 
      Dispose(P);
  end;
 
  { Сортировка вычерпыванием по 4096 частям }
  procedure Bucket12Sort( var A : mas );
    var
      i, index, j, k : Integer;
      d, x : itp;
      P : ^mas;
      C : C12T;
    begin
      { Определяем размер каждой части }
      d := (randmax div 4096) + 1;
 
      New(P);
 
      { Определяем количества элементов массива A,
        попадающих в каждую часть -
        так же, как в цифровой сортировке }
      for i := 0 to 4096 do
        C[i] := 0;
      for i := 1 to max do
        begin
          index := A[i] div d;
          C[index] := C[index] + 1;
          P^[i] := A[i];
        end;
      for i := 1 to 4096 do
        C[i] := C[i] + C[i - 1];
 
      { Переписываем элементы массива так, что сначала идут
        элементы, попавшие в первую часть, затем - элементы
        из второй части }
      for i := max downto 1 do
        begin
          index := P^[i] div d;
          A[C[index]] := P^[i];
          C[index] := C[index] - 1;
        end;
 
      { Остается только отсортировать элементы внутри каждой части -
        используем для этого сортировку вставками }
      for i := 0 to 4095 do
        begin
          for j := C[i] + 2 to C[i + 1] do
            begin
              k := j;
              x := A[j];
              while (k > C[i] + 1) and (A[k - 1] > x) do
                begin
                  A[k] := A[k - 1];
                  k := k - 1;
                end;
              A[k] := x;
            end;
        end;
 
      Dispose(P);
  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] := 'Insertion with Bound';
    SortS[3] := 'Selection (ver. 1)';
    SortS[4] := 'Selection';
    SortS[5] := 'Bubble';
    SortS[6] := 'Stopping Bubble';
    SortS[7] := 'Shaker';
    SortS[8] := 'Shell';
    SortS[9] := 'Merge';
    SortS[10] := 'Merge + Insertion 10';
    SortS[11] := 'Merge + Insertion 100';
    SortS[12] := 'Merge + Insertion 1000';
    SortS[13] := 'Quick';
    SortS[14] := 'Randomized Quick';
    SortS[15] := 'Median Quick';
    SortS[16] := 'Heap';
    SortS[17] := 'Digital - 8';
    SortS[18] := 'Digital - 12';
    SortS[19] := 'Bucket - 256';
    SortS[20] := 'Bucket - 4096';
    Sort[1] := InsertSort;
    Sort[2] := InsertSort2;
    Sort[3] := SelectSort;
    Sort[4] := SelectSort2;
    Sort[5] := BubbleSort;
    Sort[6] := BubbleSort2;
    Sort[7] := ShakerSort;
    Sort[8] := ShellSort;
    Sort[9] := MergeSort;
    Sort[10] := MergeSort10;
    Sort[11] := MergeSort100;
    Sort[12] := MergeSort1000;
    Sort[13] := QuickSort;
    Sort[14] := RandomQuickSort;
    Sort[15] := MedianQuickSort;
    Sort[16] := HeapSort;
    Sort[17] := Digital8Sort;
    Sort[18] := Digital12Sort;
    Sort[19] := Bucket8Sort;
    Sort[20] := Bucket12Sort;
 
    Write('' : 24);
    for i := 1 to 4 do
      Write(FillS[i] : 12);
    WriteLn;
    for i := 1 to 20 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;
  end.

uses crt;
var a,b,c:array[1..500] of integer;
    n,m,i,j,k:integer;
begin
clrscr;
write('n=');readln(n);
write('m=');readln(m);
writeln('Massiv A:');
for i:=1 to n do
   begin
    a[i]:=2*i+1;{введем нечетные числа}
    write(a[i],' ');
   end;
writeln;
writeln('Massiv B:');
for i:=1 to m do
   begin
    b[i]:=2*i;{введем четные числа}
    write(b[i],' ');
   end;
writeln;
i:=1; j:=1; k:=1; {устанавливаем счётчики}
while (i<=n) or (j<=m) do {пока не дошли до конца каждого из массивов}
  begin
   if (i<=n) and (j<=m) then {если оба массива ещё не закончились}
     begin
       if a[i]<b[j] then {то пишем в новый массив меньший из текущих элементов}
        begin
         c[k]:= a[i];
         inc (i); {переходим к следующему элементу соответствующего массива}
         inc (k); {переходим к следующему элементу конечного массива}
        end
       else
        begin
         c[k]:= b[j];
         inc (j);
         inc (k);
        end
     end
   else if j>m then {иначе один из массивов уже закончился}
     begin {и мы пишем из того, в котором ещё есть элементы}
       c[k]:= a[i];
       inc (i);
       inc (k);
     end
   else if i>n then
     begin
       c[k]:= b[j];
       inc (j);
       inc (k);
     end;
  end;
writeln('Massiv C:');
for i:=1 to m+n do
write(c[i],' ');
readln
end.

program SortSlian;
uses crt;
type mas=array[1..1000] of integer;
procedure Sliv(var a:mas;p,q : integer);
{процедура сливающая массивы, p-начало, q-конец}
var r,i,j,k : integer;
    b:mas;
begin
 r:=(p+q) div 2;{делим массив}
 i:=p;{начало левой половины}
 j:=r+1;{начало правой половины}
 for k:=p to q do{смотрим от начала до конца}
 if (i<=r) and ((j>q) or (a[i]<a[j])) then
 {переставляем элементы из половин в новый массив, упорядочивая пары}
  begin
   b[k]:=a[i];
   i:=i+1;
  end
 else
  begin
   b[k]:=a[j];
   j:=j+1;
  end ;
 for k:=p to q do
 a[k]:=b[k];
end;
{рекурсивная процедура сортировки, проверяет если осталось
больше одного элемента, повторяет слияние в левой или правой частях массива}
procedure Sort(var a:mas;p,q : integer); {p,q - индексы начала и конца сортируемой части массива}
begin
 if p<q then {массив из одного элемента тривиально упорядочен}
 begin
  Sort(a,p,(p+q) div 2);{сортируем левую половину}
  Sort(a,(p+q) div 2 + 1,q);{правую половину}
  Sliv(a,p,q);{сливаем две половины}
 end;
end;
var a:mas;
    n,i:integer;
begin
 clrscr;
 randomize;
 write('Размер массива n=');
 readln(n); {Определение размера массива A - N) и его заполнение}
 writeln('Исходный массив:');
 for i:=1 to n do
  begin
   a[i]:=random(50);
   write(a[i],' ');
  end;
 writeln;
 writeln;
 {запуск сортирующей процедуры, сортируем от первого до последнего элемента}
 Sort(a,1,N);
 {Вывод отсортированного массива A}
 writeln('Результат сортировки:');
 for i:=1 to n do
 write(a[i],' ');
 readln
end.

{$R-}
Program xa;
uses
  crt;
type
  itype=longint; {Тип сортируемых данных}
  TTImas=array [1..1] of itype;
  TImas=^TTImas;
  ltype=byte; {Тип для массива "карманов"}
  TTBmas=array [1..1] of ltype;
  TBmas=^TTBmas;
 
{процедура вывода массива}
procedure printmas(mas:TImas; n:longint);
var
  i:longint;
begin
  for i:=1 to n do
    Write(mas^[i], ' ');
end;
 
{Процедура определения длинны числа}
function lengthi(ch:longint):integer;
var
 s:string;
begin
  str(ch,s);
  lengthi:=length(s);
end;
 
{Процедура определяющая в какой "карман" пойдёт число}
function numberpos(ch,posi:longint):integer;
var
 s:string;
 code,tmpi:integer;
begin
  str(ch,s);
  if length(s)<posi then
    numberpos:=0
  else
  begin
    delete(s,1,length(s)-posi);
    if length(s)>1 then
      delete(s,2,length(s)-1);
    val(s,tmpi,code);
    numberpos:=tmpi
   end;
end;
 
{Процедура сортировки}
procedure sortmas(var mas:TImas; n:longint);
var
  i,k,koliter,posf,l,posi,tmp:longint;
  mastmp:TImas;
  pos:TBmas;
begin
  koliter:=0;
  GetMem(MasTmp,sizeof(itype)*n);
  GetMem(pos,sizeof(ltype)*n);
  for i:=1 to n do
  begin
    if lengthi(mas^[i])>koliter then
      koliter:=lengthi(mas^[i]);
    pos^[i]:=0;
  end;
  for i:=1 to koliter do
  begin
    for k:=1 to n do
    begin
      pos^[k]:=numberpos(mas^[k],i);
      mastmp^[k]:=mas^[k];
    end;
    posi:=1;
    for posf:=0 to 9 do
      for k:=1 to n do
        if (pos^[k]=posf) then
        begin
          mas^[posi]:=mastmp^[k];
          inc (posi);
        end;
  end;
end;
 
{Процедура проверки правильности сортировки}
function yes(mas:TImas; n:longint):boolean;
var
  flag:boolean;
  i:longint;
begin
  flag:=true;
  i:=n;
  while (i>1) and flag do
  begin
    if mas^[i]<mas^[i-1] then
      flag:=False;
    dec(i);
  end;
  yes:=flag;
end;
 
var
  massiv:TImas;
  i,n:longint;
begin
  repeat
    clrscr;
    Write('Vvedute pa3mepHoCt'' massiva, n= ');
    readln(n);
  until (n>0);
  clrscr;
  Writeln('VVedute elemenTbl massiva');
  GetMem(massiv,sizeof(itype)*n);
  for i:=1 to n do
  begin
    Write('Massiv[',i,']= ');
    readln(massiv^[i]);
  end;
  clrscr;
  writeln('massiv do coptupovki:');
  printmas(massiv,n);
  sortmas(massiv,n);
  writeln;
  writeln;
  writeln('massiv posle sortupovku');
  printmas(massiv,n);
  writeln;
  Write('Macciv otcoptipovan ');
  if yes(massiv,n) then
    writeln('pravul''no')
  else
    writeln('nepravil''no');
  readln;
  FreeMem(massiv,sizeof(itype)*n);
end.
{$R+}

procedure MegreSort(var a: files);
{
 /Методы внешней сортировки/
 /Сортировка файла прямым слиянием/
 Обозначения:
 Элемент = запись. Для файлов - запись, 
 для переменных внутри кода - элемент
 
 Основная процедура.
 a - сортируемый типизированный файл 
}
var
  k, l: integer; { переменные для занесения значений из файлов B и C соответственно }
  col, count, reg, grB, grC, n: integer;
  i, j: integer; { счетчики для циклов }
  b, c: file of integer; { вспомогательные файлы }
begin
  n := filesize(a);  { rколичество компонент в сортируемом файле A }
  reset(a);
  writeln('Этапы слияния в файл A: ');
  assign(b, 'B.bmr');
  assign(c, 'C.bmr');
  
  col := 2; { количество элементов для сравнения "между собой" }
  count := 1; { количество элементов в группе-связке }
  
  {
   Главный цикл:
   пока количество введенных чисел не будет = количеству 
   чисел в группе-связке, т.е. пока не будут упорядочены все записи в файле A.
   Это значит, что при распеределении записей из A в один из вспомогательных
   файлов будут помещены все записи (чего, разумеется, быть не должно). Цикл 
   останавливается до этого действия
  }
  while n >= count do
  begin
    reg := 1; { регулирует занесении записей в файлы при распределении }
    reset(a);
    rewrite(b);
    rewrite(c);
     {
      Распределение записей из файла A 
      в файлы B и C при разбиении.
      Распределение происходит по четности.
      Переменная reg после каждого занесения записей в файлы 
      подбирает чередующиеся позиции указателя в файле A 
      во избежание занесения в один и тот же файл
      не предназначавшихся ему записей
     }
     { Добавление в файл B }  
    {---------------------------------------------------------------------------}
    while not eof(a) do
    begin
      if odd(filepos(a) + reg) then 
      begin
        i := 1;
        repeat
              {
                В файл должно быть занесено count элементов. 
                1 цикл = 1 группа-связка
              }
          if filepos(a) <> n then
          begin
            read(a, k);
            write(b, k);
          end;
          if filepos(a) mod 2 = 0 then
            reg := 2
          else
            reg := 1;
          
          if (eof(a)) then
            break;
          inc(i);
        until (i > count) or (eof(a));
      end
          else    
      { Добавление в файл C }
      begin
        i := 1;
        repeat
             {
              В файл должно быть занесено count элементов. 
              1 цикл = 1 группа-связка
             } 
          if filepos(a) <> n then
          begin
            read(a, k);
            write(c, k);
          end;
          if filepos(a) mod 2 = 0 then
            reg := 1
          else
            reg := 2;
          if (eof(a)) then
            break;
          inc(i);
        until (i > count) or (eof(a));
      end;
    end;
    {--------------------------------------------------------------------------}
        {
         Сравнение записей из файлов В и C 
         и постепенное слияние в файл A
        }
    rewrite(a);
    reset(b);
    reset(c);
    
    {  
     Если количество чисел в файле A не является степенью 2, т.е. могут 
     оборазовываться неполные группы-связки, то для подсчтеа правильного
     количества пар групп-связок добавляем единицу, отбрасыая нецелый остаток
    }
    if n mod col <> 0 then
      reg := 1
    else
      reg := 0;  
    for i := 1 to trunc(n / col) + reg do
    { "n/col" - количество пар групп-связок, которые необходимо сравнить между собой }
    begin
      grB := 0; { обнуление счетчиков для }
      grC := 0; { последующего сравнения  }
             {
              Сравнения.
              Здесь идет распределение по группам: все полные и неполные 
              считаются отдельно.
              В блоке для полных пар могут оставаться от 1 до |grB - grC| записей.
              Цикл идет до "количества элементов, над которыми производится 
              сравнение" - 1, т.к., например, для сравнения 4 чисел при 
              "худшем сравнении"
              (т.е. когда записи из каждого файла поочередно больше друг друга) 
              в файл запишутся только 3, а последний элемент будет заноситься 
              уже как "оставшийся". В блоке неполных пар высчитываетются позиции 
              "оставшихся файлов" и взависимости от количества записей в обоих 
              файлах либо сортируются слиянием, либо (если достигнут конец 
              одного из файлов) просто добавляются "оставшиеся"
             }
      {-----Сортировка неполных групп-связок-----}
      if (i = trunc(n / col) + reg) and (reg = 1) then { есть неполные группы-связки }
      begin
        if n mod col <= count then { проверяется условие на количество элементов в обоих файлах }
        begin
          seek(b, filesize(b) - n mod col); { высчитываются позиции в каждом файле }
          seek(c, filesize(c));
        end
        else
        begin
          seek(b, filesize(b) - (n mod col - (n mod col - count))); { высчитываются позиции в каждом файле }
          seek(c, filesize(c) - (n mod col - count));
        end;   
        if filepos(c) = filesize(c) then { есть пустой файл }
          while not eof(b) do { добавляем оставшиеся из другого }
          begin
            read(b, k);
            write(a, k);
          end
        else { иначе сортируем }
        begin
          j := 1;
          while true do
          begin
            if j = 1 then
            {
             Изначально нужно прочесть сразу обе записи,
             далее по одной из каждого файла
            }
            begin
              read(b, k);
              read(c, l);
            end;
            { 
             Сравнение отдельных элементов из групп-связок между собой 
             и последующее слияние в файл A 
            }
            if k < l then 
            begin
              write(a, k);
              if not eof(b) then
                read(b, k)
              else
              begin
                seek(c, filepos(c) - 1);  { предотвращение лишнего прочтения в цикле }
                break;
              end;
            end
            else
            begin
              write(a, l);
              if not eof(c) then
                read(c, l)
              else
              begin
                seek(b, filepos(b) - 1);  { предотвращение лишнего прочтения в цикле }
                break;
              end;
            end;
            inc(j);
          end;      
          if eof(c) then
            while not eof(b) do
            begin
              read(b, k);
              write(a, k);
            end
          else
            while not eof(c) do
            begin
              read(c, l);
              write(a, l);
            end;       
        end;
      end
         else
      {-----Сортировка полных групп-связок-----}
      begin
        for j := 1 to col - 1 do
        begin
          if j = 1 then 
            {
             Изначально нужно прочесть сразу обе записи, 
             далее по одной из каждого файла
            }
          begin
            read(b, k);
            read(c, l);
          end;         
          { 
            Сравнение отдельных элементов из групп-связок между собой 
            и последующее слияние в файл A 
          }
          if k < l then 
          begin
            write(a, k);
            inc(grB); { счетчик для count }
            if (grB <> count) then { предотвращение лишнего прочтения }
              read(b, k)
            else
              break;
          end
          else
          begin
            write(a, l);
            inc(grC); { счетчик для count }
            if (grC <> count) then  { предотвращение лишнего прочтения }
              read(c, l)
            else
              break;
          end; 
        end;
        {------------------------------------------------------------------------------------------}
        
        { занесение в файл A "оставшихся" элементов (записей) }
        if grB > grC then { так мы узнаем, в котором файле "остались" записи  }
        begin
          for j := 1 to grB - grC do
          begin
            {
             Если количество элементов в следующей паре-связке
             < или = количеству записей в файле B, то записываем
             элемент из файла С, иначе в B. Это сделано с целью
             предотвращения оставшегося (одного) элемента в Файле B
            }
            write(a, l);
            if not eof(c) then
              read(c, l);
          end;      
          seek(c, filepos(c) - 1);  { предотвращение лишнего прочтения в цикле }
        end
        else
        if grB < grC then { так мы узнаем, в котором файле "остались" записи }
        begin
          for j := 1 to grC - grB do
          begin
            {
             Если количество элементов в следующей паре-связке
             < или = количеству записей в файле B, то записываем
             элемент из файла С, иначе в B. Это сделано с целью
             предотвращения оставшегося (одного) элемента в Файле B
            }
            write(a, k);
            if not eof(b) then
              read(b, k);
          end;
          seek(b, filepos(b) - 1);  { предотвращение лишнего прочтения в цикле }
        end
      end;
      {---------------------------------------------------------------------------}
    end;
    reset(a);
    { вывод на экран содержимого файла A после слияния }
    while not eof(a) do
    begin
      read(a, num);
      write(num, ' ');
    end;
    writeln;
    writeln;
    col := col * 2; { повышение количества элементов для сравнения "между собой" в цикле }
    count := count * 2; { повышение количества элементов в группе-связке }
  end; 
  writeln;
  close(a);
  close(b);
  close(c);
  erase(b);
  erase(c);
end;

{
 /Методы внешней сортировки/
 /Сортировка файла прямым слиянием/
 Обозначения:
 Элемент = запись. Для файлов - запись,
 для переменных внутри кода - элемент
}
uses crt;
type
  files = file of integer;
 
var
  n,i, num: integer;
  a: files;
 
procedure MegreSort(var a: files);
{
 Основная процедура.
 a - сортируемый типизированный файл
}
var
  k, l: integer; { переменные для занесения значений из файлов B и C соответственно }
  col, count, reg, grB, grC, n: integer;
  i, j: integer; { счетчики для циклов }
  b, c: file of integer; { вспомогательные файлы }
begin
  n := filesize(a);  { rколичество компонент в сортируемом файле A }
  reset(a);
  writeln('Этапы слияния в файл A: ');
  assign(b, 'B.bmr');
  assign(c, 'C.bmr');
 
  col := 2; { количество элементов для сравнения "между собой" }
  count := 1; { количество элементов в группе-связке }
 
  {
   Главный цикл:
   пока количество введенных чисел не будет = количеству
   чисел в группе-связке, т.е. пока не будут упорядочены все записи в файле A.
   Это значит, что при распеределении записей из A в один из вспомогательных
   файлов будут помещены все записи (чего, разумеется, быть не должно). Цикл
   останавливается до этого действия
  }
  while n >= count do
  begin
    reg := 1; { регулирует занесении записей в файлы при распределении }
    reset(a);
    rewrite(b);
    rewrite(c);
     {
      Распределение записей из файла A
      в файлы B и C при разбиении.
      Распределение происходит по четности.
      Переменная reg после каждого занесения записей в файлы
      подбирает чередующиеся позиции указателя в файле A
      во избежание занесения в один и тот же файл
      не предназначавшихся ему записей
     }
     { Добавление в файл B }
    {---------------------------------------------------------------------------}
    while not eof(a) do
    begin
      if odd(filepos(a) + reg) then
      begin
        i := 1;
        repeat
              {
                В файл должно быть занесено count элементов.
                1 цикл = 1 группа-связка
              }
          if filepos(a) <> n then
          begin
            read(a, k);
            write(b, k);
          end;
          if filepos(a) mod 2 = 0 then
            reg := 2
          else
            reg := 1;
 
          if (eof(a)) then
            break;
          inc(i);
        until (i > count) or (eof(a));
      end
          else
      { Добавление в файл C }
      begin
        i := 1;
        repeat
             {
              В файл должно быть занесено count элементов.
              1 цикл = 1 группа-связка
             }
          if filepos(a) <> n then
          begin
            read(a, k);
            write(c, k);
          end;
          if filepos(a) mod 2 = 0 then
            reg := 1
          else
            reg := 2;
          if (eof(a)) then
            break;
          inc(i);
        until (i > count) or (eof(a));
      end;
    end;
    {--------------------------------------------------------------------------}
        {
         Сравнение записей из файлов В и C
         и постепенное слияние в файл A
        }
    rewrite(a);
    reset(b);
    reset(c);
 
    {
     Если количество чисел в файле A не является степенью 2, т.е. могут
     оборазовываться неполные группы-связки, то для подсчтеа правильного
     количества пар групп-связок добавляем единицу, отбрасыая нецелый остаток
    }
    if n mod col <> 0 then
      reg := 1
    else
      reg := 0;
    for i := 1 to trunc(n / col) + reg do
    { "n/col" - количество пар групп-связок, которые необходимо сравнить между собой }
    begin
      grB := 0; { обнуление счетчиков для }
      grC := 0; { последующего сравнения  }
             {
              Сравнения.
              Здесь идет распределение по группам: все полные и неполные
              считаются отдельно.
              В блоке для полных пар могут оставаться от 1 до |grB - grC| записей.
              Цикл идет до "количества элементов, над которыми производится
              сравнение" - 1, т.к., например, для сравнения 4 чисел при
              "худшем сравнении"
              (т.е. когда записи из каждого файла поочередно больше друг друга)
              в файл запишутся только 3, а последний элемент будет заноситься
              уже как "оставшийся". В блоке неполных пар высчитываетются позиции
              "оставшихся файлов" и взависимости от количества записей в обоих
              файлах либо сортируются слиянием, либо (если достигнут конец
              одного из файлов) просто добавляются "оставшиеся"
             }
      {-----Сортировка неполных групп-связок-----}
      if (i = trunc(n / col) + reg) and (reg = 1) then { есть неполные группы-связки }
      begin
        if n mod col <= count then { проверяется условие на количество элементов в обоих файлах }
        begin
          seek(b, filesize(b) - n mod col); { высчитываются позиции в каждом файле }
          seek(c, filesize(c));
        end
        else
        begin
          seek(b, filesize(b) - (n mod col - (n mod col - count))); { высчитываются позиции в каждом файле }
          seek(c, filesize(c) - (n mod col - count));
        end;
        if filepos(c) = filesize(c) then { есть пустой файл }
          while not eof(b) do { добавляем оставшиеся из другого }
          begin
            read(b, k);
            write(a, k);
          end
        else { иначе сортируем }
        begin
          j := 1;
          while true do
          begin
            if j = 1 then
            {
             Изначально нужно прочесть сразу обе записи,
             далее по одной из каждого файла
            }
            begin
              read(b, k);
              read(c, l);
            end;
            {
             Сравнение отдельных элементов из групп-связок между собой
             и последующее слияние в файл A
            }
            if k < l then
            begin
              write(a, k);
              if not eof(b) then
                read(b, k)
              else
              begin
                seek(c, filepos(c) - 1);  { предотвращение лишнего прочтения в цикле }
                break;
              end;
            end
            else
            begin
              write(a, l);
              if not eof(c) then
                read(c, l)
              else
              begin
                seek(b, filepos(b) - 1);  { предотвращение лишнего прочтения в цикле }
                break;
              end;
            end;
            inc(j);
          end;
          if eof(c) then
            while not eof(b) do
            begin
              read(b, k);
              write(a, k);
            end
          else
            while not eof(c) do
            begin
              read(c, l);
              write(a, l);
            end;
        end;
      end
         else
      {-----Сортировка полных групп-связок-----}
      begin
        for j := 1 to col - 1 do
        begin
          if j = 1 then
            {
             Изначально нужно прочесть сразу обе записи,
             далее по одной из каждого файла
            }
          begin
            read(b, k);
            read(c, l);
          end;
          {
           Сравнение отдельных элементов из групп-связок между собой
           и последующее слияние в файл A
          }
          if k < l then
          begin
            write(a, k);
            inc(grB); { счетчик для count }
            if (grB <> count) then { предотвращение лишнего прочтения }
              read(b, k)
            else
              break;
          end
          else
          begin
            write(a, l);
            inc(grC); { счетчик для count }
            if (grC <> count) then  { предотвращение лишнего прочтения }
              read(c, l)
            else
              break;
          end;
        end;
        {------------------------------------------------------------------------------------------}
 
        { занесение в файл A "оставшихся" элементов (записей) }
        if grB > grC then { так мы узнаем, в котором файле "остались" записи  }
        begin
          for j := 1 to grB - grC do
          begin
            {
             Если количество элементов в следующей паре-связке
             < или = количеству записей в файле B, то записываем
             элемент из файла С, иначе в B. Это сделано с целью
             предотвращения оставшегося (одного) элемента в Файле B
            }
            write(a, l);
            if not eof(c) then
              read(c, l);
          end;
          seek(c, filepos(c) - 1);  { предотвращение лишнего прочтения в цикле }
        end
        else
        if grB < grC then { так мы узнаем, в котором файле "остались" записи }
        begin
          for j := 1 to grC - grB do
          begin
            {
             Если количество элементов в следующей паре-связке
             < или = количеству записей в файле B, то записываем
             элемент из файла С, иначе в B. Это сделано с целью
             предотвращения оставшегося (одного) элемента в Файле B
            }
            write(a, k);
            if not eof(b) then
              read(b, k);
          end;
          seek(b, filepos(b) - 1);  { предотвращение лишнего прочтения в цикле }
        end
      end;
      {---------------------------------------------------------------------------}
    end;
    reset(a);
    { вывод на экран содержимого файла A после слияния }
    while not eof(a) do
    begin
      read(a, num);
      write(num, ' ');
    end;
    writeln;
    writeln;
    col := col * 2; { повышение количества элементов для сравнения "между собой" в цикле }
    count := count * 2; { повышение количества элементов в группе-связке }
  end;
  writeln;
  close(a);
  close(b);
  close(c);
  erase(b);
  erase(c);
end;
 
begin
  randomize;
  assign(a,'input');
  rewrite(a);
  write('Количество записей: ');
  readln(n);
  writeln('Исходные данные:');
  for i := 1 to n do  { занесение данных в типизированный файл A }
  begin
    num:=random(1000)-500;
    write(num,' ');
    write(a, num);
  end;
  writeln;
  writeln;
  MegreSort(a);
  readln;
end.

const
  mas: array [1..129] of integer

type
  TElement = Integer;
 
{ Сортировка "пузырьком" с остановкой }
procedure BubbleSort(var a: array of TElement);
var
  i, j, n: Integer;
  t: TElement;
begin
  i:=High(a);
  repeat
    n:=Low(a);
    for j:=Low(a) to i-1 do
      if a[j+1]<a[j] then begin
        n:=j;              { сохраним позицию последнего обмена }
        t:=a[j]; a[j]:=a[j+1]; a[j+1]:=t;   { обменяем соседние }
      end;
    i:=n; { ограничим следующий цикл позицией последнего обмена }
  until n=Low(a); { обмен в поз. 0 или их не было => сортировка завершена }
end;
 
{ пример использования }
var
  a: array [1..10] of TElement;
  i: Integer;
begin
  Randomize;
  for i:=Low(a) to High(a) do a[i]:=-99+Random(199);
  Write('A ='); for i:=Low(a) to High(a) do Write(a[i]:4); WriteLn;
  BubbleSort(a);
  Write('A''='); for i:=Low(a) to High(a) do Write(a[i]:4); WriteLn;
end.

begin
  n:=High(a);
  repeat
    i:=n; n:=Low(a);
    for j:=Low(a) to i-1 do
      if a[j+1]<a[j] then begin
        n:=j; t:=a[j]; a[j]:=a[j+1]; a[j+1]:=t;
      end;
  until n=Low(a);
end;

type
  TElement = Integer;
 
{ Сортировка "шейкером" }
procedure ShakerSort(var a: array of TElement);
var
  l, r, n, j: Integer;
  t: TElement;
begin
  l:=Low(a); n:=l; r:=High(a);
  while l<r do begin
    { "Пузырек" слева направо }
    for j:=l to r-1 do
      if a[j+1]<a[j] then begin
        n:=j;
        t:=a[j]; a[j]:=a[j+1]; a[j+1]:=t;
      end;
    r:=n;
    { "Пузырек" справа налево }
    for j:=r downto l+1 do
      if a[j]<a[j-1] then begin
        n:=j;
        t:=a[j]; a[j]:=a[j-1]; a[j-1]:=t;
      end;
    l:=n;
  end;
end;
 
{ пример использования }
var
  a: array [1..10] of TElement;
  i: Integer;
begin
  Randomize;
  for i:=Low(a) to High(a) do a[i]:=-99+Random(199);
  Write('A ='); for i:=Low(a) to High(a) do Write(a[i]:4); WriteLn;
  ShakerSort(a);
  Write('A''='); for i:=Low(a) to High(a) do Write(a[i]:4); WriteLn;
end.

type TElement = Integer;
 
procedure InsertSort(var a: array of TElement);
var i, j, l, r, m: Integer; t: TElement;
begin
  for i:=Low(a)+1 to High(a) do begin
    t:=a[i]; l:=Low(a); r:=i;
    while l<r do begin
      m:=l+(r-l) div 2;
      if a[m]<=t then l:=m+1 else r:=m;
    end;
    for j:=i downto r+1 do a[j]:=a[j-1];
    a[r]:=t;
  end;
end;

procedure SortRadix(var a: array of Longint; n: Integer);
type LongintArr = array [0..0] of Longint;
var
  b: ^LongintArr;
  e: Integer;
{$R-}
  procedure SortCount;
  var
    c: array [0..$F] of Integer;
    i, t: Integer;
  begin
    FillChar(c,SizeOf(c),#0);
    for i:=0 to n-1 do Inc(c[a[i] shr e and $F]);
    for i:=Low(c)+1 to High(c) do Inc(c[i],c[i-1]);
    for i:=n-1 downto 0 do begin
      t:=a[i] shr e and $F;
      Dec(c[t]); b^[c[t]]:=a[i];
    end;
    for i:=0 to n-1 do a[i]:=b^[i];
  end;
var
  i: Integer;
  m: Longint;
begin
  GetMem(b,n*SizeOf(Longint));
  m:=a[0]; for i:=1 to n-1 do if m<a[i] then m:=a[i];
  e:=0;
  while m>0 do begin
    SortCount; Inc(e,4); m:=m shr 4;
  end;
  FreeMem(b,n*SizeOf(Longint));
end;

const
  n=10;
  a: array [0..n-1] of Longint = (9,8,7,6,5,4,3,2,1,0);
var i: Integer;
begin
  Write('A ='); for i:=Low(a) to High(a) do Write(' ',a[i]); WriteLn;
  SortRadix(a,n);
  Write('A''='); for i:=Low(a) to High(a) do Write(' ',a[i]); WriteLn;
end.

procedure SortRadix(var a: array of Longint; n: Integer);
type LongintArr = array [0..0] of Longint;
var
  b: ^LongintArr;
  e: Integer;
{$R-}
  procedure SortCount;
  var
    c: array [0..$FF] of Integer;
    i, t: Integer;
  begin
    FillChar(c,SizeOf(c),#0);
    for i:=0 to n-1 do Inc(c[a[i] shr e and $FF]);
    for i:=Low(c)+1 to High(c) do Inc(c[i],c[i-1]);
    for i:=n-1 downto 0 do begin
      t:=a[i] shr e and $FF;
      Dec(c[t]); b^[c[t]]:=a[i];
    end;
    for i:=0 to n-1 do a[i]:=b^[i];
  end;
var
  i: Integer;
  m: Longint;
begin
  GetMem(b,n*SizeOf(b[0]));
  m:=a[0]; for i:=1 to n-1 do if m<a[i] then m:=a[i];
  e:=0;
  while m>0 do begin
    SortCount; Inc(e,8); m:=m shr 8;
  end;
  FreeMem(b,n*SizeOf(b[0]));
end;