{ Увеличение размера стека - нужно для рекурсивных алгоритмов 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;
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.
