paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 09:19:39 +01:00
Code Issues Packages Projects Releases Wiki Activity

+ added a sort algorithm interface that accepts a custom callback function for

Browse Source 
exchanging two elements. This is required for TStringList.Sort (and is the
  most generic form for a sort algorithm interface that I can think of).

git-svn-id: trunk@41182 -
This commit is contained in:
nickysn 2019-02-03 00:33:43 +00:00
parent 2a0eb54fd5
commit c7d8bd9666
1 changed files with 64 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
rtl/inc/sortbase.pp
View File

@ -26,25 +26,37 @@ type
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;
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
@ -204,4 +216,56 @@ begin
FreeMem(TempBuf, ItemSize);
end;
procedure QuickSort_ItemList_CustomItemExchanger_Context(
Items: Pointer;
ItemCount, ItemSize: SizeUInt;
Comparer: TListSortComparer_Context;
Exchanger: TListSortCustomItemExchanger_Context;
Context: Pointer);
procedure QuickSort(L, R : Longint);
var
I, J : Longint;
P : Pointer;
begin
repeat
I := L;
J := R;
P := Items + ItemSize*((L + R) div 2);
repeat
while Comparer(P, Items + ItemSize*I, Context) > 0 do
Inc(I);
while Comparer(P, Items + ItemSize*J, Context) < 0 do
Dec(J);
If I <= J then
begin
Exchanger(Items + ItemSize*I, Items + ItemSize*J, Context);
Inc(I);
Dec(J);
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 J - L < R - I then
begin
if L < J then
QuickSort(L, J);
L := I;
end
else
begin
if I < R then
QuickSort(I, R);
R := J;
end;
until L >= R;
end;
begin
if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then
exit;
QuickSort(0, ItemCount - 1);
end;
end.