ВУЗ: Не указан
Категория: Не указан
Дисциплина: Не указана
Добавлен: 23.01.2025
Просмотров: 3167
Скачиваний: 3
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.