paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-01 15:10:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ added .Sort overloads, that specify an algorithm and use the sortbase defined

Browse Source 
algorithms for sorting TList, TFPList and TStringList when FPC_TESTGENERICS is
  defined as well. Unfortunately, I couldn't test it, because the RTL doesn't
  compile with FPC_TESTGENERICS, due to errors, completely unrelated to the
  sortbase changes.

git-svn-id: trunk@41248 -
This commit is contained in:
nickysn 2019-02-07 15:45:13 +00:00
parent 8b17af1f89
commit ff90e7622a
3 changed files with 79 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
rtl/objpas/classes/classesh.inc
View File

@ -272,6 +272,7 @@ Type
public
procedure Assign(Source: TFPList);
procedure Sort(Compare: TListSortCompare);
procedure Sort(Compare: TListSortCompare; SortingAlgorithm: PSortingAlgorithm);
procedure ForEachCall(Proc2call: TListCallback; Arg: Pointer);
procedure ForEachCall(Proc2call: TListStaticCallback; Arg: Pointer);
end;
@ -856,7 +857,9 @@ type
function IndexOf(const S: string): Integer; override;
procedure Insert(Index: Integer; const S: string); override;
procedure Sort; virtual;
procedure Sort(SortingAlgorithm: PSortingAlgorithm); virtual;
procedure CustomSort(CompareFn: TStringListSortCompare);
procedure CustomSort(CompareFn: TStringListSortCompare; SortingAlgorithm: PSortingAlgorithm);
property Duplicates: TDuplicates read GetDuplicates write SetDuplicates;
property Sorted: Boolean read GetSorted write SetSorted;
property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;

5
rtl/objpas/classes/lists.inc
View File

@ -493,6 +493,11 @@ begin
inherited Sort(TFPPtrListSortCompare(Compare));
end;
procedure TFPList.Sort(Compare: TListSortCompare; SortingAlgorithm: PSortingAlgorithm);
begin
inherited Sort(TFPPtrListSortCompare(Compare), SortingAlgorithm);
end;
procedure TFPList.ForEachCall(Proc2call: TListCallback; Arg: Pointer);
var
I: integer;

96
rtl/objpas/classes/stringl.inc
View File

@ -1882,32 +1882,46 @@ begin
Changed;
end;
procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
var
I, J, Pivot: Integer;
type
PStringList_CustomSort_Context = ^TStringList_CustomSort_Context;
TStringList_CustomSort_Context = record
List: TStringList;
ListStartPtr: Pointer;
ItemSize: SizeUInt;
IndexBase: Integer;
CompareFn: TStringListSortCompare;
end;
function TStringList_CustomSort_Comparer(Item1, Item2, Context: Pointer): Integer;
begin
repeat
I := L;
J := R;
Pivot := (L + R) div 2;
repeat
while CompareFn(Self, I, Pivot) < 0 do Inc(I);
while CompareFn(Self, J, Pivot) > 0 do Dec(J);
if I <= J then
begin
FMap.InternalExchange(I, J); // No check, indices are correct.
if Pivot = I then
Pivot := J
else if Pivot = J then
Pivot := I;
Inc(I);
Dec(j);
end;
until I > J;
if L < J then
QuickSort(L,J, CompareFn);
L := I;
until I >= R;
with PStringList_CustomSort_Context(Context)^ do
Result := CompareFn(List,
((Item1 - ListStartPtr) div ItemSize) + IndexBase,
((Item2 - ListStartPtr) div ItemSize) + IndexBase);
end;
procedure TStringList_CustomSort_Exchanger(Item1, Item2, Context: Pointer);
begin
with PStringList_CustomSort_Context(Context)^ do
List.Exchange(((Item1 - ListStartPtr) div ItemSize) + IndexBase,
((Item2 - ListStartPtr) div ItemSize) + IndexBase);
end;
procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
var
Context: TStringList_CustomSort_Context;
begin
if L > R then
exit;
Context.List := Self;
Context.ListStartPtr := FMap.Items[L];
Context.CompareFn := CompareFn;
Context.ItemSize := FMap.KeySize + FMap.DataSize;
Context.IndexBase := L;
DefaultSortingAlgorithm^.ItemListSorter_CustomItemExchanger_ContextComparer(
Context.ListStartPtr, R - L + 1, Context.ItemSize, @TStringList_CustomSort_Comparer,
@TStringList_CustomSort_Exchanger, @Context);
end;
procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
@ -1920,6 +1934,28 @@ begin
end;
end;
procedure TStringList.CustomSort(CompareFn: TStringListSortCompare; SortingAlgorithm: PSortingAlgorithm);
var
Context: TStringList_CustomSort_Context;
begin
if not Sorted and (FMap.Count > 1) then
begin
Changing;
Context.List := Self;
Context.ListStartPtr := FMap.Items[0];
Context.CompareFn := CompareFn;
Context.ItemSize := FMap.KeySize + FMap.DataSize;
Context.IndexBase := 0;
SortingAlgorithm^.ItemListSorter_CustomItemExchanger_ContextComparer(
Context.ListStartPtr, FMap.Count, Context.ItemSize, @TStringList_CustomSort_Comparer,
@TStringList_CustomSort_Exchanger, @Context);
Changed;
end;
end;
procedure TStringList.Sort;
begin
if not Sorted and (FMap.Count > 1) then
@ -1930,5 +1966,15 @@ begin
end;
end;
procedure TStringList.Sort(SortingAlgorithm: PSortingAlgorithm);
begin
if not Sorted and (FMap.Count > 1) then
begin
Changing;
FMap.Sort(SortingAlgorithm);
Changed;
end;
end;
{$endif}