[fpc-devel] Custom sorted stringlists
Franz Müller
bupa at gmx.at
Mon Jan 14 21:50:41 CET 2019
Hi, after a lot of testing, I think it is safe and I have submitted this
patch to the bugtracker
https://bugs.freepascal.org/view.php?id=34873
With this patch, it is possible to provide a custom compare function to
a stringlist and thus allow the stringlist to keep the items
automatically sorted according to the custom compare routine.
In addition, this custom compare function can also use fields of the
objects associated with the strings.
I would also be willing to update the documentation accordingly, but I
have no idea how to do that.
Franz
-------------- next part --------------
Index: rtl/objpas/classes/classesh.inc
===================================================================
--- rtl/objpas/classes/classesh.inc (revision 40862)
+++ rtl/objpas/classes/classesh.inc (working copy)
@@ -759,14 +759,18 @@
FOnChanging: TNotifyEvent;
FDuplicates: TDuplicates;
FCaseSensitive : Boolean;
- FForceSort : Boolean;
FOwnsObjects : Boolean;
FSortStyle: TStringsSortStyle;
+ FObjectSort: boolean;
+ FOnCompareItems: TStringListSortCompare; // user defined compare function or nil, if standard
+ FDoCompare: TStringListSortCompare; // compare function actually used for sorting
procedure ExchangeItemsInt(Index1, Index2: Integer); inline;
function GetSorted: Boolean;
procedure Grow;
procedure InternalClear(FromIndex : Integer = 0; ClearOnly : Boolean = False);
- procedure QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
+ procedure QuickSort(L, R: Integer);
+ procedure SortIfNeeded;
+ procedure SetOnCompareItems(const AValue: TStringListSortCompare);
procedure SetSorted(Value: Boolean);
procedure SetCaseSensitive(b : boolean);
procedure SetSortStyle(AValue: TStringsSortStyle);
@@ -791,10 +795,12 @@
public
destructor Destroy; override;
function Add(const S: string): Integer; override;
+ function AddObject(const S: string; AObject: TObject): Integer; override;
procedure Clear; override;
procedure Delete(Index: Integer); override;
procedure Exchange(Index1, Index2: Integer); override;
function Find(const S: string; Out Index: Integer): Boolean; virtual;
+ function Find(const S: string; const O: TObject; Out Index: Integer): Boolean; virtual;
function IndexOf(const S: string): Integer; override;
procedure Insert(Index: Integer; const S: string); override;
procedure Sort; virtual;
@@ -805,7 +811,9 @@
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
property OwnsObjects : boolean read FOwnsObjects write FOwnsObjects;
- Property SortStyle : TStringsSortStyle Read FSortStyle Write SetSortStyle;
+ property SortStyle : TStringsSortStyle Read FSortStyle Write SetSortStyle;
+ property ObjectSort : boolean read FObjectSort write FObjectSort;
+ property OnCompareItems: TStringListSortCompare read FOnCompareItems write SetOnCompareItems;
end;
{$else}
Index: rtl/objpas/classes/stringl.inc
===================================================================
--- rtl/objpas/classes/stringl.inc (revision 40862)
+++ rtl/objpas/classes/stringl.inc (working copy)
@@ -1230,9 +1230,10 @@
Pointer(Flist^[Index2].FObject):=P2;
end;
+
function TStringList.GetSorted: Boolean;
begin
- Result:=FSortStyle in [sslUser,sslAuto];
+ Result:=FSortStyle <> sslNone;
end;
@@ -1285,8 +1286,7 @@
SetCapacity(0);
end;
-procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare
- );
+procedure TStringList.QuickSort(L, R: Integer);
var
Pivot, vL, vR: Integer;
ExchangeProc: procedure(Left, Right: Integer) of object;
@@ -1297,11 +1297,9 @@
else
ExchangeProc := @ExchangeItems;
- if R - L <= 1 then begin // a little bit of time saver
- if L < R then
- if CompareFn(Self, L, R) > 0 then
+ if R=L+1 then begin // a little bit of time saver
+ if FDoCompare(Self, L, R) > 0 then
ExchangeProc(L, R);
-
Exit;
end;
@@ -1311,12 +1309,15 @@
Pivot := L + Random(R - L); // they say random is best
while vL < vR do begin
- while (vL < Pivot) and (CompareFn(Self, vL, Pivot) <= 0) do
+ while (vL < Pivot) and (FDoCompare(Self, vL, Pivot) <= 0) do
Inc(vL);
- while (vR > Pivot) and (CompareFn(Self, vR, Pivot) > 0) do
+ while (vR > Pivot) and (FDoCompare(Self, vR, Pivot) >= 0) do
Dec(vR);
+ if vL=vR then
+ break;
+
ExchangeProc(vL, vR);
if Pivot = vL then // swap pivot if we just hit it from one side
@@ -1325,10 +1326,10 @@
Pivot := vL;
end;
- if Pivot - 1 >= L then
- QuickSort(L, Pivot - 1, CompareFn);
- if Pivot + 1 <= R then
- QuickSort(Pivot + 1, R, CompareFn);
+ if L < Pivot - 1 then
+ QuickSort(L, Pivot - 1);
+ if Pivot + 1 < R then
+ QuickSort(Pivot + 1, R);
end;
@@ -1437,6 +1438,8 @@
procedure TStringList.PutObject(Index: Integer; AObject: TObject);
begin
+ If ObjectSort and Sorted then
+ Error(SSortedListError,0);
CheckIndex(Index);
Changing;
Flist^[Index].FObject:=AObject;
@@ -1500,7 +1503,6 @@
end;
-
destructor TStringList.Destroy;
begin
@@ -1509,19 +1511,23 @@
end;
-
function TStringList.Add(const S: string): Integer;
begin
- If Not (SortStyle=sslAuto) then
+ Result:=AddObject(s,nil)
+end;
+
+function TStringList.AddObject(const S: string; AObject: TObject): Integer;
+begin
+ If SortStyle<>sslAuto then
Result:=FCount
else
- If Find (S,Result) then
- Case DUplicates of
+ If Find (S, AObject, Result) then
+ Case Duplicates of
DupIgnore : Exit;
DupError : Error(SDuplicateString,0)
end;
- InsertItem (Result,S);
+ InsertItem (Result,S,AObject);
end;
procedure TStringList.Clear;
@@ -1554,6 +1560,8 @@
procedure TStringList.Exchange(Index1, Index2: Integer);
begin
+ If Sorted then
+ Error(SSortedListError,0);
CheckIndex(Index1);
CheckIndex(Index2);
Changing;
@@ -1562,30 +1570,66 @@
end;
+function LegacyCompare(List: TStringList; Index1, Index2: Integer): Integer;
+// For backward compatibility: If CompareStrings or DoComparetext have been
+// overriden, we must use this procedure for comparing
+begin
+ Result:=List.CompareStrings(List[index1], List[Index2]);
+end;
+
+
+function CompareSLText(List: TStringList; Index1, Index2: Integer): Integer;
+// Case insensitive compare of 2 stringlist elements
+begin
+ result:=AnsiCompareText(List[Index1], List[Index2]);
+end;
+
+
+function CompareSLStrings(List: TStringList; Index1, Index2: Integer): Integer;
+// Case sensitive compare of 2 stringlist elements
+begin
+ result:=AnsiCompareStr(List[Index1], List[Index2]);
+end;
+
+
+procedure TStringList.SortIfNeeded;
+begin
+ if SortStyle<>sslAuto then
+ exit;
+
+ if assigned(OncompareItems) then
+ FDoCompare:=OnCompareItems // use custom compare function
+ else
+ if (TMethod(@Self.CompareStrings).Code <> CodePointer(@TStringList.CompareStrings))
+ or (TMethod(@Self.DoCompareText).Code <> CodePointer(@TStringList.DoCompareText)) then
+ FDoCompare:=@LegacyCompare // use overriding compare function of descending class
+ else
+ if CaseSensitive then
+ FDoCompare:=@CompareSLStrings // use optimized case sensitive compare
+ else
+ FDoCompare:=@CompareSLText; // use optimized case insensitive compare
+ Sort;
+end;
+
+
procedure TStringList.SetCaseSensitive(b : boolean);
begin
if b=FCaseSensitive then
Exit;
FCaseSensitive:=b;
- if FSortStyle=sslAuto then
- begin
- FForceSort:=True;
- try
- Sort;
- finally
- FForceSort:=False;
- end;
- end;
+ SortIfNeeded;
end;
+
procedure TStringList.SetSortStyle(AValue: TStringsSortStyle);
begin
- if FSortStyle=AValue then Exit;
- if (AValue=sslAuto) then
- Sort;
+ if FSortStyle=AValue then
+ Exit;
FSortStyle:=AValue;
+ SortIfNeeded;
end;
+
procedure TStringList.CheckIndex(AIndex: Integer);
begin
If (AIndex<0) or (AIndex>=FCount) then
@@ -1608,43 +1652,72 @@
end;
+procedure TStringList.SetOnCompareItems(const AValue: TStringListSortCompare);
+begin
+ if FOnCompareItems=AValue then
+ Exit;
+ FOnCompareItems:=AValue;
+ SortIfNeeded;
+end;
+
+
function TStringList.Find(const S: string; out Index: Integer): Boolean;
+begin
+ Result := Find(S, nil, Index);
+end;
+
+function TStringList.Find(const S: string; const O: TObject;
+ out Index: Integer): Boolean;
var
L, R, I: Integer;
CompareRes: PtrInt;
begin
Result := false;
- Index:=-1;
- if Not Sorted then
+ if not Sorted then
Raise EListError.Create(SErrFindNeedsSortedList);
+
+ // Compare function needs index of stringlist-element, so for the binary search
+ // append S after the last element of the stringlist
+ InsertItem(FCount,S,O);
+
+ // The string we look for has been appended temporarily (it has now index Count-1)
+ // It will be removed from the list at the end of this procedure
+ // The actual stringlist ends now at Count-2
+
// Use binary search.
- L := 0;
- R := Count - 1;
- while (L<=R) do
- begin
- I := L + (R - L) div 2;
- CompareRes := DoCompareText(S, Flist^[I].FString);
- if (CompareRes>0) then
- L := I+1
- else begin
- R := I-1;
- if (CompareRes=0) then begin
- Result := true;
- if (Duplicates<>dupAccept) then
- L := I; // forces end of while loop
+ try
+ L := 0;
+ R := Count - 2;
+ while (L<=R) do
+ begin
+ I := (L + R) div 2;
+ CompareRes := FDoCompare(self, Count-1, I);
+ if CompareRes>0 then
+ L := I+1
+ else begin
+ R := I-1;
+ if CompareRes=0 then begin
+ Result := true;
+ if Duplicates<>dupAccept then
+ L := I; // forces end of while loop
+ end;
end;
end;
- end;
- Index := L;
+ finally
+ // restore stringlist to what it was on entry of this method
+ // don't use delete, as the object must not be freed
+ Dec(FCount);
+ Flist^[FCount].FString:='';
+ Flist^[FCount].FObject:=nil;
+ Index := L;
+ end;
end;
-
function TStringList.IndexOf(const S: string): Integer;
-
begin
- If Not Sorted then
+ If ObjectSort or not Sorted then
Result:=Inherited indexOf(S)
else
// faster using binary search...
@@ -1653,16 +1726,14 @@
end;
-
procedure TStringList.Insert(Index: Integer; const S: string);
-
begin
If SortStyle=sslAuto then
Error (SSortedListError,0)
else
begin
- If (Index<0) or (Index>FCount) then
- Error(SListIndexError,Index); // Cannot use CheckIndex, because there >= FCount...
+ If Index<>FCount then // Index=FCount allowed here
+ CheckIndex(Index);
InsertItem (Index,S);
end;
end;
@@ -1669,27 +1740,25 @@
procedure TStringList.CustomSort(CompareFn: TStringListSortCompare);
-
begin
- If (FForceSort or (Not (FSortStyle=sslAuto))) and (FCount>1) then
- begin
- Changing;
- QuickSort(0,FCount-1, CompareFn);
- Changed;
- end;
+ If SortStyle<>sslAuto then
+ begin
+ FDoCompare:=CompareFn;
+ Sort;
+ end;
end;
-function StringListAnsiCompare(List: TStringList; Index1, Index: Integer): Integer;
-begin
- Result := List.DoCompareText(List.FList^[Index1].FString,
- List.FList^[Index].FString);
-end;
-
procedure TStringList.Sort;
-
begin
- CustomSort(@StringListAnsiCompare);
+// When Sort is called, FDoCompare is always set correctly
+// Called from CustomSort and from SortIfNeeded
+ if FCount>1 then
+ begin
+ Changing;
+ Quicksort(0,FCount-1);
+ Changed;
+ end;
end;
{$else}
More information about the fpc-devel
mailing list