mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 07:28:09 +02:00
386 lines
12 KiB
ObjectPascal
386 lines
12 KiB
ObjectPascal
{
|
|
This file is part of the Free Pascal Run Time Library (rtl)
|
|
Copyright (c) 1999-2019 by the Free Pascal development team
|
|
|
|
This file provides the base for the pluggable sorting algorithm
|
|
support. It also provides a default QuickSort implementation.
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
|
|
{$IFNDEF FPC_DOTTEDUNITS}
|
|
unit sortbase;
|
|
{$ENDIF FPC_DOTTEDUNITS}
|
|
|
|
{$MODE objfpc}
|
|
|
|
interface
|
|
|
|
type
|
|
TListSortComparer_NoContext = function(Item1, Item2: Pointer): Integer;
|
|
TPtrListSorter_NoContext = procedure(ItemPtrs: PPointer; ItemCount: SizeUInt; Comparer: TListSortComparer_NoContext);
|
|
TItemListSorter_NoContext = procedure(Items: Pointer; ItemCount, ItemSize: SizeUInt; Comparer: TListSortComparer_NoContext);
|
|
|
|
TListSortComparer_Context = function(Item1, Item2, Context: Pointer): Integer;
|
|
TListSortCustomItemExchanger_Context = procedure(Item1, Item2, Context: Pointer);
|
|
TPtrListSorter_Context = procedure(ItemPtrs: PPointer; ItemCount: SizeUInt; Comparer: TListSortComparer_Context; Context: Pointer);
|
|
TItemListSorter_Context = procedure(Items: Pointer; ItemCount, ItemSize: SizeUInt; Comparer: TListSortComparer_Context; Context: Pointer);
|
|
TItemListSorter_CustomItemExchanger_Context = procedure(Items: Pointer;
|
|
ItemCount, ItemSize: SizeUInt; Comparer: TListSortComparer_Context;
|
|
Exchanger: TListSortCustomItemExchanger_Context; Context: Pointer);
|
|
|
|
PSortingAlgorithm = ^TSortingAlgorithm;
|
|
TSortingAlgorithm = record
|
|
PtrListSorter_NoContextComparer: TPtrListSorter_NoContext;
|
|
PtrListSorter_ContextComparer: TPtrListSorter_Context;
|
|
ItemListSorter_ContextComparer: TItemListSorter_Context;
|
|
ItemListSorter_CustomItemExchanger_ContextComparer: TItemListSorter_CustomItemExchanger_Context;
|
|
end;
|
|
|
|
{
|
|
QuickSort
|
|
|
|
Average performance: O(n log n)
|
|
Worst performance: O(n*n)
|
|
Extra memory use: O(log n) on the stack
|
|
Stable: no
|
|
Additional notes: Uses the middle element as the pivot. This makes it work
|
|
well also on already sorted sequences, which can occur
|
|
often in practice. As expected from QuickSort, it works
|
|
best on random sequences and is usually the fastest
|
|
algorithm to sort them. It is, however, possible for a
|
|
malicious user to craft special sequences, which trigger
|
|
its worst O(n*n) case. They can also occur in practice,
|
|
although they are very unlikely. If this is not an
|
|
acceptable risk (e.g. for high risk applications,
|
|
security-conscious applications or applications with hard
|
|
real-time requirements), another sorting algorithm must
|
|
be used.
|
|
}
|
|
|
|
procedure QuickSort_PtrList_NoContext(
|
|
ItemPtrs: PPointer;
|
|
ItemCount: SizeUInt;
|
|
Comparer: TListSortComparer_NoContext);
|
|
procedure QuickSort_PtrList_Context(
|
|
ItemPtrs: PPointer;
|
|
ItemCount: SizeUInt;
|
|
Comparer: TListSortComparer_Context;
|
|
Context: Pointer);
|
|
procedure QuickSort_ItemList_Context(
|
|
Items: Pointer;
|
|
ItemCount, ItemSize: SizeUInt;
|
|
Comparer: TListSortComparer_Context;
|
|
Context: Pointer);
|
|
procedure QuickSort_ItemList_CustomItemExchanger_Context(
|
|
Items: Pointer;
|
|
ItemCount, ItemSize: SizeUInt;
|
|
Comparer: TListSortComparer_Context;
|
|
Exchanger: TListSortCustomItemExchanger_Context;
|
|
Context: Pointer);
|
|
|
|
const
|
|
QuickSort: TSortingAlgorithm = (
|
|
PtrListSorter_NoContextComparer: @QuickSort_PtrList_NoContext;
|
|
PtrListSorter_ContextComparer: @QuickSort_PtrList_Context;
|
|
ItemListSorter_ContextComparer: @QuickSort_ItemList_Context;
|
|
ItemListSorter_CustomItemExchanger_ContextComparer: @QuickSort_ItemList_CustomItemExchanger_Context;
|
|
);
|
|
|
|
var
|
|
DefaultSortingAlgorithm: PSortingAlgorithm = @QuickSort;
|
|
|
|
implementation
|
|
|
|
Procedure QuickSort_PtrList_NoContext(ItemPtrs: PPointer; L, R : SizeUInt;
|
|
Comparer: TListSortComparer_NoContext);
|
|
var
|
|
I, J, PivotIdx : SizeUInt;
|
|
P, Q : Pointer;
|
|
begin
|
|
repeat
|
|
I := L;
|
|
J := R;
|
|
PivotIdx := L + ((R - L) shr 1); { same as ((L + R) div 2), but without the possibility of overflow }
|
|
P := ItemPtrs[PivotIdx];
|
|
repeat
|
|
while (I < PivotIdx) and (Comparer(P, ItemPtrs[i]) > 0) do
|
|
Inc(I);
|
|
while (J > PivotIdx) and (Comparer(P, ItemPtrs[J]) < 0) do
|
|
Dec(J);
|
|
if I < J then
|
|
begin
|
|
Q := ItemPtrs[I];
|
|
ItemPtrs[I] := ItemPtrs[J];
|
|
ItemPtrs[J] := Q;
|
|
if PivotIdx = I then
|
|
begin
|
|
PivotIdx := J;
|
|
Inc(I);
|
|
end
|
|
else if PivotIdx = J then
|
|
begin
|
|
PivotIdx := I;
|
|
Dec(J);
|
|
end
|
|
else
|
|
begin
|
|
Inc(I);
|
|
Dec(J);
|
|
end;
|
|
end;
|
|
until I >= J;
|
|
// sort the smaller range recursively
|
|
// sort the bigger range via the loop
|
|
// Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
|
|
if (PivotIdx - L) < (R - PivotIdx) then
|
|
begin
|
|
if (L + 1) < PivotIdx then
|
|
QuickSort_PtrList_NoContext(ItemPtrs, L, PivotIdx - 1, Comparer);
|
|
L := PivotIdx + 1;
|
|
end
|
|
else
|
|
begin
|
|
if (PivotIdx + 1) < R then
|
|
QuickSort_PtrList_NoContext(ItemPtrs, PivotIdx + 1, R, Comparer);
|
|
if (L + 1) < PivotIdx then
|
|
R := PivotIdx - 1
|
|
else
|
|
exit;
|
|
end;
|
|
until L >= R;
|
|
end;
|
|
|
|
procedure QuickSort_PtrList_NoContext(ItemPtrs: PPointer; ItemCount: SizeUInt; Comparer: TListSortComparer_NoContext);
|
|
begin
|
|
if not Assigned(ItemPtrs) or (ItemCount < 2) then
|
|
exit;
|
|
QuickSort_PtrList_NoContext(ItemPtrs, 0, ItemCount - 1, Comparer);
|
|
end;
|
|
|
|
procedure QuickSort_PtrList_Context(ItemPtrs: PPointer; ItemCount: SizeUInt; Comparer: TListSortComparer_Context; Context: Pointer);
|
|
|
|
procedure QuickSort(L, R : SizeUInt);
|
|
var
|
|
I, J, PivotIdx : SizeUInt;
|
|
P, Q : Pointer;
|
|
begin
|
|
repeat
|
|
I := L;
|
|
J := R;
|
|
PivotIdx := L + ((R - L) shr 1); { same as ((L + R) div 2), but without the possibility of overflow }
|
|
P := ItemPtrs[PivotIdx];
|
|
repeat
|
|
while (I < PivotIdx) and (Comparer(P, ItemPtrs[I], Context) > 0) do
|
|
Inc(I);
|
|
while (J > PivotIdx) and (Comparer(P, ItemPtrs[J], Context) < 0) do
|
|
Dec(J);
|
|
if I < J then
|
|
begin
|
|
Q := ItemPtrs[I];
|
|
ItemPtrs[I] := ItemPtrs[J];
|
|
ItemPtrs[J] := Q;
|
|
if PivotIdx = I then
|
|
begin
|
|
PivotIdx := J;
|
|
Inc(I);
|
|
end
|
|
else if PivotIdx = J then
|
|
begin
|
|
PivotIdx := I;
|
|
Dec(J);
|
|
end
|
|
else
|
|
begin
|
|
Inc(I);
|
|
Dec(J);
|
|
end;
|
|
end;
|
|
until I >= J;
|
|
// sort the smaller range recursively
|
|
// sort the bigger range via the loop
|
|
// Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
|
|
if (PivotIdx - L) < (R - PivotIdx) then
|
|
begin
|
|
if (L + 1) < PivotIdx then
|
|
QuickSort(L, PivotIdx - 1);
|
|
L := PivotIdx + 1;
|
|
end
|
|
else
|
|
begin
|
|
if (PivotIdx + 1) < R then
|
|
QuickSort(PivotIdx + 1, R);
|
|
if (L + 1) < PivotIdx then
|
|
R := PivotIdx - 1
|
|
else
|
|
exit;
|
|
end;
|
|
until L >= R;
|
|
end;
|
|
|
|
begin
|
|
if not Assigned(ItemPtrs) or (ItemCount < 2) then
|
|
exit;
|
|
QuickSort(0, ItemCount - 1);
|
|
end;
|
|
|
|
procedure QuickSort_ItemList_Context(Items: Pointer; ItemCount, ItemSize: SizeUInt; Comparer: TListSortComparer_Context; Context: Pointer);
|
|
|
|
var
|
|
TempBuf: Pointer;
|
|
|
|
procedure QuickSort(L, R : SizeUInt);
|
|
var
|
|
I, J, PivotIdx : SizeUInt;
|
|
P : Pointer;
|
|
begin
|
|
repeat
|
|
I := L;
|
|
J := R;
|
|
PivotIdx := L + ((R - L) shr 1); { same as ((L + R) div 2), but without the possibility of overflow }
|
|
P := Items + ItemSize*PivotIdx;
|
|
repeat
|
|
while (I < PivotIdx) and (Comparer(P, Items + ItemSize*I, Context) > 0) do
|
|
Inc(I);
|
|
while (J > PivotIdx) and (Comparer(P, Items + ItemSize*J, Context) < 0) do
|
|
Dec(J);
|
|
if I < J then
|
|
begin
|
|
Move((Items + ItemSize*I)^, TempBuf^, ItemSize);
|
|
Move((Items + ItemSize*J)^, (Items + ItemSize*I)^, ItemSize);
|
|
Move(TempBuf^, (Items + ItemSize*J)^, ItemSize);
|
|
if PivotIdx = I then
|
|
begin
|
|
PivotIdx := J;
|
|
P := Items + ItemSize*PivotIdx;
|
|
Inc(I);
|
|
end
|
|
else if PivotIdx = J then
|
|
begin
|
|
PivotIdx := I;
|
|
P := Items + ItemSize*PivotIdx;
|
|
Dec(J);
|
|
end
|
|
else
|
|
begin
|
|
Inc(I);
|
|
Dec(J);
|
|
end;
|
|
end;
|
|
until I >= J;
|
|
// sort the smaller range recursively
|
|
// sort the bigger range via the loop
|
|
// Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
|
|
if (PivotIdx - L) < (R - PivotIdx) then
|
|
begin
|
|
if (L + 1) < PivotIdx then
|
|
QuickSort(L, PivotIdx - 1);
|
|
L := PivotIdx + 1;
|
|
end
|
|
else
|
|
begin
|
|
if (PivotIdx + 1) < R then
|
|
QuickSort(PivotIdx + 1, R);
|
|
if (L + 1) < PivotIdx then
|
|
R := PivotIdx - 1
|
|
else
|
|
exit;
|
|
end;
|
|
until L >= R;
|
|
end;
|
|
|
|
begin
|
|
if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then
|
|
exit;
|
|
GetMem(TempBuf, ItemSize);
|
|
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
|
|
try
|
|
QuickSort(0, ItemCount - 1);
|
|
finally
|
|
FreeMem(TempBuf, ItemSize);
|
|
end;
|
|
{$else FPC_HAS_FEATURE_EXCEPTIONS}
|
|
QuickSort(0, ItemCount - 1);
|
|
FreeMem(TempBuf, ItemSize);
|
|
{$endif FPC_HAS_FEATURE_EXCEPTIONS}
|
|
end;
|
|
|
|
procedure QuickSort_ItemList_CustomItemExchanger_Context(
|
|
Items: Pointer;
|
|
ItemCount, ItemSize: SizeUInt;
|
|
Comparer: TListSortComparer_Context;
|
|
Exchanger: TListSortCustomItemExchanger_Context;
|
|
Context: Pointer);
|
|
|
|
procedure QuickSort(L, R : SizeUInt);
|
|
var
|
|
I, J, PivotIdx : SizeUInt;
|
|
P : Pointer;
|
|
begin
|
|
repeat
|
|
I := L;
|
|
J := R;
|
|
PivotIdx := L + ((R - L) shr 1); { same as ((L + R) div 2), but without the possibility of overflow }
|
|
P := Items + ItemSize*PivotIdx;
|
|
repeat
|
|
while (I < PivotIdx) and (Comparer(P, Items + ItemSize*I, Context) > 0) do
|
|
Inc(I);
|
|
while (J > PivotIdx) and (Comparer(P, Items + ItemSize*J, Context) < 0) do
|
|
Dec(J);
|
|
if I < J then
|
|
begin
|
|
Exchanger(Items + ItemSize*I, Items + ItemSize*J, Context);
|
|
if PivotIdx = I then
|
|
begin
|
|
PivotIdx := J;
|
|
P := Items + ItemSize*PivotIdx;
|
|
Inc(I);
|
|
end
|
|
else if PivotIdx = J then
|
|
begin
|
|
PivotIdx := I;
|
|
P := Items + ItemSize*PivotIdx;
|
|
Dec(J);
|
|
end
|
|
else
|
|
begin
|
|
Inc(I);
|
|
Dec(J);
|
|
end;
|
|
end;
|
|
until I >= J;
|
|
// sort the smaller range recursively
|
|
// sort the bigger range via the loop
|
|
// Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion
|
|
if (PivotIdx - L) < (R - PivotIdx) then
|
|
begin
|
|
if (L + 1) < PivotIdx then
|
|
QuickSort(L, PivotIdx - 1);
|
|
L := PivotIdx + 1;
|
|
end
|
|
else
|
|
begin
|
|
if (PivotIdx + 1) < R then
|
|
QuickSort(PivotIdx + 1, R);
|
|
if (L + 1) < PivotIdx then
|
|
R := PivotIdx - 1
|
|
else
|
|
exit;
|
|
end;
|
|
until L >= R;
|
|
end;
|
|
|
|
begin
|
|
if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then
|
|
exit;
|
|
QuickSort(0, ItemCount - 1);
|
|
end;
|
|
|
|
end.
|