Interface

uses Classes, Common;

{ Медленные алгоритмы сортировки }

procedure InsertionStdSort(aList, bList: TList; aCompare: TCompareFunc);

procedure InsertionBublSort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

procedure InsertionOptSort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

procedure SelectionStdSort(aList, bList: TList; aCompare: TCompareFunc);

procedure SelectionSort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

procedure BubbleSort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

procedure ShakerSort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

{ Быстрые алгоритмы сортировки }

procedure ShellSort(aList: TList; aCompare: TCompareFunc);

procedure ShellKnuthSort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

{ Самые быстрые алгоритмы сортировки }

procedure QuickHoarStd1Sort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

procedure QuickHoarStd2Sort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

procedure QuickHoarRNDSort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

procedure QuickHoarMDNSort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

procedure QuickHoarNonRecursiveSort(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

procedure MSS(aList: TList; aFirst, aLast: Integer;

aCompare: TCompareFunc; aTempList: PPointerList);

procedure DigitSort(aList: TList);

Implementation

{ Сортировка простой выборкой }

procedure SelectionStdSort;

var

i, j, m, N: Integer;

{ Состояние элементов входного множества}

c: array of Boolean;

begin

N:=aList.Count;

SetLength(c, N);

{ Сброс отметок}

for i:=0 to N-1 do c[i]:=True;

{ Поиск первого невыбранного элемента во входном множестве}

for i:=0 to N-1 do

begin

j:=0;

while not c[j] do j:=j+1;

m:=j;

{ Поиск минимального элемента }

for j:=1 to N-1 do

if c[j] and (aCompare(aList.List[j], aList.List[m]) = -1) then m:=j;

{ Запись в выходное множество}

bList.Items[i]:=aList.List[m];

{ В входное множество - "пусто" }

c[m]:=False;

end;

end;

{ Обменная сортировка простой выборкой }

procedure SelectionSort;

var

i, j, IndexOfMin: Integer;

Temp: Pointer;

begin

{ Перебор элементов выходного множества }

for i:=aFirst to pred(aLast) do

{ Входное множество - [i:N-1]; выходное - [1:i-1] }

begin

IndexOfMin:=i;

{ Поиск минимума во входном множестве }

for j:=i+1 to aLast do

{ Обмен первого элемента входного множества с минимальным }

if (aCompare(aList.List[j], aList.List[IndexOfMin]) < 0) then

IndexOfMin:=j;

Temp:=aList.List[i];

aList.List[i]:=aList.List[IndexOfMin];

aList.List[IndexOfMin]:=Temp;

end;

end;

{ Сортировка простыми вставками }

procedure InsertionStdSort;

var i, j, k: Integer;

begin

{ Перебор входного массива }

for i:=0 to aList.Count-1 do

begin

j:=0;

{ Поиск места для a[i] в выходном массиве

при условии (j < i) и (b[j] <= a[i]) }

while (j < i) and (aCompare(bList.Items[j],aList.Items[i]) <= 0) do

j:=j+1;

{ Освобождение места для нового элемента }

for k:=i downto j+1 do

bList.Items[k]:=bList.Items[k-1];

{ Запись в выходной массив }

bList.Items[j]:=aList.Items[i];

end;

end;

{ Сортировка методом вставок }

procedure InsertionBublSort;

var

i, j: Integer;

Temp: Pointer;

begin

{ Перебор входного массива }

for i:=aFirst+1 to aLast do

{ Входное множество - [i..N-1], выходное множество - [0..i-1] }

begin

{ Запоминается значение нового элемента }

Temp:=aList.List[i];

j:=i;

{ Поиск места для элемента в выходном множестве со сдвигом

цикл закончится при достижении начала или,

когда будет встречен элемент, меньший нового }

while (j > aFirst) and (aCompare(Temp, aList.List[j-1]) < 0) do

begin

{ Все элементы, большие нового сдвигаются }

aList.List[j]:=aList.List[j-1];

{ Цикл от конца к началу выходного множества }

Dec(j);

end;

{ Новый элемент ставится на свое место }

aList.List[j]:=Temp;

end;

end;

{ Оптимизированная сортировка методом вставок }

procedure InsertionOptSort;

var

i, j, IndexOfMin: Integer;

Temp: Pointer;

begin

{ Найти наименьший элемент и поместить его в первую позицию }

IndexOfMin:=aFirst;

for i:=aFirst+1 to aLast do

if (aCompare(aList.List[i], aList.List[IndexOfMin]) < 0) then

IndexOfMin:=i;

if aFirst <> IndexOfMin then

begin

Temp:=aList.List[aFirst];

aList.List[aFirst]:=aList.List[IndexOfMin];

aList.List[IndexOfMin]:=Temp;

end;

{ Сортировка методом простых вставок }

for i:=aFirst+2 to aLast do

begin

Temp:=aList.List[i];

j:=i;

while (aCompare(Temp, aList.List[j-1]) < 0) do

begin

aList.List[j]:=aList.List[j-1];

Dec(j);

end;

aList.List[j]:=Temp;

end;

end;

{ Пузырьковая сортировка }

procedure BubbleSort;

var

i,j: Integer;

Temp: Pointer;

Done: Boolean;

begin

for i:=aFirst to aLast-1 do

begin

Done:=True;

for j:=aLast downto i+1 do

{ Переставить j-й и j-1-й элементы }

if aCompare(aList.List[j],aList.List[j-1]) < 0 then

begin

Temp:=aList.List[j];

aList.List[j]:=aList.List[j-1];

aList.List[j-1]:=Temp;

Done:=False;

end;

if Done then Exit;

end;

end;

{ Пузырьковая двухпроходная сортировка }

procedure ShakerSort;

var

i: Integer;

Temp: Pointer;

begin

while aFirst < aLast do

begin

for i:=aLast downto aFirst+1 do

if aCompare(aList.List[i], aList.List[i-1]) < 0 then

begin

Temp:=aList.List[i];

aList.List[i]:=aList.List[i-1];

aList.List[i-1]:=Temp;

end;

Inc(aFirst);

for i:=aFirst+1 to aLast do

if aCompare(aList.List[i], aList.List[i-1]) < 0 then

begin

Temp:=aList.List[i];

aList.List[i]:=aList.List[i-1];

aList.List[i-1]:=Temp;

end;

Dec(aLast);

end;

end;

{ Сортировка Шелла }

procedure ShellSort;

var

h, i, N: Integer;

Temp: Pointer;

{ Признак перестановки }

k: Boolean;

begin

N:=aList.Count;

{ Начальное значение интервала }

h:=N div 2;

{ Цикл с уменьшением интервала до 1 }

while h > 0 do

begin

{ Пузырьковая сортировка с интервалом h }

k:=True;

{ Цикл, пока есть перестановки }

while k do

begin

k:=False;

{ Сравнение элементов на интервале h }

for i:=0 to N-h-1 do

begin

if aCompare(aList.List[i], aList.List[i+h]) = 1 then

begin

{ Перестановка }

Temp:=aList.List[i];

aList.List[i]:=aList.List[i+h];

aList.List[i+h]:=Temp;

{ Признак перестановки }

k:=True;

end;

end;

end;

{ Уменьшение интервала }

h:=h div 2;

end;

end;

{ Сортировка Шелла с применением ряда Кнута }

procedure ShellKnuthSort;

var

i, j, h, N: Integer;

Temp: Pointer;

begin

{ Начальное значение h должно быть

близко к 1/9 количества элементов }

h:=1; N:=(aLast - aFirst) div 9;

while h <= N do

h:=h*3 + 1;

{ При каждом проходе цикла значение

шага уменьшается на треть }

while h > 0 do

begin

{ Выполнить сортировку методом

вставки для каждого подмножества }

for i:=(aFirst + h) to aLast do

begin

Temp:=aList.List[i];

j:=i;

while (j >= (aFirst+h)) and (aCompare(Temp, aList.List[j-h]) < 0) do

begin

aList.List[j]:=aList.List[j-h];

Dec(j, h);

end;

aList.List[j]:=Temp;

end;

h:=h div 3;

end;

end;

{ Быстрая сортировка Хоара с выбором

среднего элемента в качестве базового }

procedure QuickHoarStd1Sort;

var

L, R: Integer;

M, Temp: Pointer;

begin

if aFirst >= aLast then Exit;

{ В качестве базового элемента выбирается средний }

M:=aList.List^[(aFirst+aLast) div 2];

{ Начальные значения индексов }

L:=aFirst-1; R:=aLast+1;

{ Приступить к разбиению списка }

while True do

begin

repeat Dec(R);

until aCompare(aList.List[R], M) <= 0;

repeat Inc(L);

until aCompare(aList.List[L], M) >= 0;

if L >= R then Break;

Temp:=aList.List[L];

aList.List[L]:=aList.List[R];

aList.List[R]:=Temp;

end;

{ Выполнить быструю сортировку левого подсписка }

QuickHoarStd1Sort(aList, aFirst, R, aCompare);

{ Выполнить быструю сортировку правого подсписка }

QuickHoarStd1Sort(aList, R+1, aLast, aCompare);

end;

{ Быстрая сортировка Хоара (без одной рекурсии) }

procedure QuickHoarStd2Sort;

var

L, R: Integer;

M, Temp: Pointer;

begin

{ Повторять, по в списке

есть хотя бы два элемента }

while (aFirst < aLast) do

begin

{ В качестве базового элемента выбирается средний }

M:=aList.List^[(aFirst+aLast) div 2];

{ Начальные значения индексов }

L:=aFirst-1; R:=aLast+1;

{ Приступить к разбиению списка }

while True do

begin

repeat Dec(R);

until aCompare(aList.List[R], M) <= 0;

repeat Inc(L);

until aCompare(aList.List[L], M) >= 0;

if L >= R then Break;

Temp:=aList.List[L];

aList.List[L]:=aList.List[R];

aList.List[R]:=Temp;

end;

{ Выполнить быструю сортировку левого подсписка }

if aFirst < R then

QuickHoarStd2Sort(aList, aFirst, R, aCompare);

{ Выполнить быструю сортировку правого подсписка и устранение рекурсии }

aFirst:=R+1;

end;

end;

{ Быстрая сортировка Хоара со

случайным выбором базового элемента }

procedure QuickHoarRNDSort;

var

L, R: Integer;

M, Temp: Pointer;

begin

while aFirst < aLast do

begin

{ Начало добавляемой части }

{ Выбрать случайный элемент, переставить его со

средним элементом и взять в качестве базового }

R:=aFirst + Random(aLast - aFirst + 1);

L:=(aFirst + aLast) div 2;

M:=aList.List[R];

aList.List[R]:=aList.List[L];

aList.List[L]:=M;

{ Конец добавляемой части }

L:=aFirst-1;

R:=aLast+1;

while True do

begin

repeat Dec(R);

until aCompare(aList.List[R], M) <= 0;

repeat Inc(L);

until aCompare(aList.List[L], M) >= 0;

if L >= R then Break;

Temp:=aList.List[L];

aList.List[L]:=aList.List[R];

aList.List[R]:=Temp;

end;

if (aFirst < R) then

QuickHoarRNDSort(aList, aFirst, R, aCompare);

aFirst:=R+1;

end;

end;

{ Быстрая сортировка Хоара с выбором

базового элемента методом трех медиан }

procedure QuickHoarMDNSort;

var

L, R: Integer;

M, Temp: Pointer;

begin

while aFirst < aLast do

begin

{ Начало добавляемой части }

{ Если в списке есть, по крайней мере, три элемента,

выбрать базовый элемент как медиану первого, последнего

и среднего элементов и записать его в позицию в середину списка }

if aLast - aFirst >= 2 then

begin

R:=(aFirst + aLast) div 2;

if aCompare(aList.List[aFirst], aList.List[R]) > 0 then

begin

Temp:=aList.List[aFirst];

aList.List[aFirst]:=aList.List[R];

aList.List[R]:=Temp;

end;

if aCompare(aList.List[aFirst], aList.List[aLast]) > 0 then

begin

Temp:=aList.List[aFirst];

aList.List[aFirst]:=aList.List[aLast];

aList.List[aLast]:=Temp;

end;

if aCompare(aList.List^[R], aList.List[aLast]) > 0 then

begin

Temp:=aList.List[R];

aList.List[R]:=aList.List[aLast];

aList.List[aLast]:=Temp;

end;

M:=aList.List[R];

end else

{ В противном случае в списке всего два

элемента, выбрать в качестве базового первый }

M:=aList.List[aFirst];

{ Конец добавляемой части }

L:=aFirst-1;

R:=aLast+1;

while True do

begin

repeat Dec(R);

until aCompare(aList.List[R], M) <= 0;

repeat Inc(L);

until aCompare(aList.List[L], M) >= 0;

if L >= R then Break;

Temp:=aList.List[L];

aList.List[L]:=aList.List[R];

aList.List[R]:=Temp;

end;

if aFirst < R then

QuickHoarMDNSort(aList, aFirst, R, aCompare);

aFirst:=R+1;

end;

end;

{ Быстрая сортировка Хоара без рекурсии }

procedure QuickHoarNonRecursiveSort;

var

L, R, SP: Integer;

M, Temp: Pointer;

Stack: array [0..63] of Integer;

begin

{ Инициализировать стек }

Stack[0]:=aFirst;

Stack[1]:=aLast;

SP:=2;

while SP <> 0 do

begin

{ Извлечь верхний список }

Dec(SP, 2);

aFirst:=Stack[SP];

aLast:=Stack[SP+1];

{ Пока в списке есть хотя бы два элемента }

while aFirst < aLast do

begin

{ В качестве базового выбирается средний элемент }

M:=aList.List[(aFirst+aLast) div 2];

{ Задать начальные значения индексов и приступить к разбиению списка }

L:=aFirst-1; R:=aLast+1;

while True do

begin

repeat Dec(R);

until aCompare(aList.List[R], M) <= 0;

repeat Inc(L);

until aCompare(aList.List[L], M) >= 0;

if L >= R then Break;

Temp:=aList.List[L];

aList.List[L]:=aList.List[R];

aList.List[R]:=Temp;

end;

{ Поместить большой список в стек и

повторить цикл для меньшего подсписка }

if (R - aFirst) < (aLast - R) then

begin

Stack[SP]:=R+1;

Stack[SP+1]:=aLast;

Inc(SP, 2);

aLast:=R;

end

else

begin

Stack[SP]:=aFirst;

Stack[SP+1]:=R;

Inc(SP, 2);

aFirst:=R+1;

end;

end;

end;

end;

{ Сортировка слиянием }

procedure MSS;

var

Mid, i, j, ToInx,

FirstCount: Integer;

begin

{ Вычислить среднюю точку }

Mid:=(aFirst + aLast) div 2;

{ Рекурсивная сортировка слиянием первой и второй половин списка }

if aFirst < Mid then

MSS(aList, aFirst, Mid, aCompare, aTempList);

if (Mid+1) < aLast then

MSS(aList, Mid+1, aLast, aCompare, aTempList);

{ Скопировать первую половину списка во вспомогательный список }

FirstCount:=Mid-aFirst+1;

Move(aList.List[aFirst], aTempList[0], FirstCount*SizeOf(Pointer));

{ Установить значения индексов: i - индекс для вспомогательного списка

(т.е. первой половины); j - индекс для второй половины списка;

ToInx - индекс в результирующем списке, куда будут копироваться

отсортированные элементы }

i:=0; j:=Mid+1; ToInx:=aFirst;

{ Выполнить слияние двух списков; повторять

пока один из списков не опустеет }

while (i < FirstCount) and (j <= aLast) do

begin

{ Определить элемент с наименьшим значением из следующих

элементов в обоих списках и скопировать его; увеличить

значение соответствующего индекса }

if aCompare(aTempList[i], aList.List[j]) <= 0 then

begin

aList.List[ToInx]:=aTempList[i];

Inc(i);

end

else

begin

aList.List[ToInx]:=aList.List[j];

Inc(j);

end;

{ В объединенных списках есть еще один элемент }

Inc(ToInx);

end;

{ Если в первом элементе остались элементы, скопировать их }

if i < FirstCount then

Move(aTempList[i], aList.List[ToInx], (FirstCount - i)*SizeOf(Pointer));

{ Если во втором списке остались элементы, то они уже находятся в нужных

позициях, т.е. сортировка завершена; если второй список пуст, сортировка

также завершена }

end;

procedure MergeSortStd(aList: TList;

aFirst, aLast: Integer; aCompare: TCompareFunc);

var

TempList: PPointerList;

ItemCount: Integer;

begin

{ Есть хотя бы два элемента для сортировки }

if aFirst < aLast then

begin

{ создать временный список указателей }

ItemCount:=aLast-aFirst+1;

GetMem(TempList, ((ItemCount+1) div 2)*SizeOf(Pointer));

try

MSS(aList, aFirst, aLast, aCompare, TempList);

finally

FreeMem(TempList, ((ItemCount+1) div 2)*SizeOf(Pointer));

end;

end;

end;

const

D=5; { максимальное количество цифр в числе }

P=10; { основание системы счисления }

{ возвращает значение n-ой цифры в числе v }

function Digit(v, n: Integer): Integer;

begin

for n:=n downto 2 do

v:=v div P;

Digit:=v mod P;

end;

procedure DigitSort;

var

{ индекс элемента, следующего за последним в i-ой группе }

b: array[0..P-2] of Integer;

i, j, k, m, N: Integer;

x: Pointer;

begin

N:=aList.Count-1;

for m:=1 to D do

begin

{ перебор цифр, начиная с младшей }

for i:=0 to P-2 do b[i]:=1;

{ нач. значения индексов }

for i:=1 to N do

begin

{ перебор массива }

{ определение m-ой цифры }

k:=Digit(LongWord(aList.Items[i]^),m);

x:=aList.Items[i];

{ сдвиг - освобождение места в конце k-ой группы }

for j:=i downto b[k]+1 do

aList.Items[j]:=aList.Items[j-1];

{ запись в конец k-ой группы }

aList.Items[b[k]]:=x;

{ модификация k-го индекса и всех больших }

for j:=k to P-2 do b[j]:=b[j]+1;

end;

end;

end;

end.

В следующем примере показан способ применения приведенных модулей.

program demo;

{$APPTYPE CONSOLE}

uses

Classes,

SysUtils,

Windows,

srch in 'srch.pas',

common in 'common.pas',

sort in 'sort.pas';

const

LoadFileName = 'c:\data.txt';

SaveFileName = 'c:\data_sort.txt';

var

w, Id: Word;

t, Size: LongWord;

tmpList: PPointerList;

begin

{ Открытие выборки }

OpenList(LoadFileName, Size);

WriteLn('Samples size: '+IntToStr(Size));

WriteLn('');

WriteLn('Select command:');

WriteLn(' 0 - Exit');

WriteLn(' 1 - Linear search');

WriteLn(' 2 - Selection sort');

WriteLn(' 3 - Insert bubble sort');

WriteLn(' 4 - Shell sort');

WriteLn(' 5 - Quick Hoar standard sort');

WriteLn(' 6 - MSS sort');

{ Выбор пункта меню }

repeat ReadLn(Id); until Id <= 6;

{ Обработка команды меню }

case Id of

0: Exit;

1: begin

Write('Input key: ');

ReadLn(w);

{ Зафиксировать момент времени }

t:=GetTickCount;

WriteLn('Serial number: '+

IntToStr(LineNonSortedSearch(List, @w, CompareLongWord)));

{ Время выполнения алгоритма }

t:=GetTickCount-t;

WriteLn('Linear search time: '+IntToStr(t));

ReadLn;

end;

2: begin

t:=GetTickCount;

SelectionSort(List,0,List.Count-1, CompareLongWord);

t:=GetTickCount-t;

WriteLn('Selection sort time: '+IntToStr(t));

end;

3: begin

t:=GetTickCount;

InsertionBublSort(List,0,List.Count-1, CompareLongWord);

t:=GetTickCount-t;

WriteLn('Insert bubble sort time: '+IntToStr(t));

end;

4: begin

t:=GetTickCount;

ShellSort(List, CompareLongWord);

t:=GetTickCount-t;

WriteLn('Shell sort time: '+IntToStr(t));

end;

5: begin

t:=GetTickCount;

QuickHoarStd1Sort(List, 0,List.Count-1, CompareLongWord);

t:=GetTickCount-t;

WriteLn('Quick Hoar standard sort time: '+IntToStr(t));

end;

6: begin

New(tmpList);

t:=GetTickCount;

MSS(List, 0,List.Count-1, CompareLongWord, tmpList);

t:=GetTickCount-t;

WriteLn('MSS sort time: '+IntToStr(t));

Dispose(tmpList);

end;

end;

{ Сохранение отсортированных данных }

if Id > 1 then SaveList(SaveFileName);

ReadLn;

end.