## 2010. július 5., hétfő

### How to sort a TStringList using the Quicksort algorithm

Problem/Question/Abstract:

How to sort a TStringList using the Quicksort algorithm

Answer:

Here is a complete example, which uses a rather tricky type case to gain access to some private data of the TStringList. It does provide a method for you to use as many custom sort routines as you like in one descendant class. One thing to note is that only swaps pointers and not data so it is extremely fast even with 10000 entrys.

unit sslistu;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{\$R *.DFM}

type
TStringListCompare = function(var X, Y: TStringItem): integer;
TStringListCracker = class(TStrings)
private
FList: PStringItemList;
FCount: Integer;
FCapacity: Integer;
FSorted: Boolean;
end;

TcStringList = class(TStringList)
private
FListptr: PStringItemList;
procedure ExchangeItems(Index1, Index2: Integer);
procedure QuickSort(L, R: Integer; Compare: TStringListCompare);
procedure SetSorted(Value: Boolean);
public
procedure Sort(Compare: TStringListCompare); {Hide not Override}
end;

procedure TcStringList.SetSorted(Value: Boolean);
begin
if Sorted <> Value then
TStringListCracker(Self).FSorted := value;
end;

procedure TcStringList.ExchangeItems(Index1, Index2: Integer);
var
Temp: Integer;
Item1, Item2: PStringItem;
begin
Item1 := @FListPtr^[Index1];
Item2 := @FListPtr^[Index2];
Temp := Integer(Item1^.FString);
Integer(Item1^.FString) := Integer(Item2^.FString);
Integer(Item2^.FString) := Temp;
Temp := Integer(Item1^.FObject);
Integer(Item1^.FObject) := Integer(Item2^.FObject);
Integer(Item2^.FObject) := Temp;
end;

procedure TcStringList.QuickSort(L, R: Integer; Compare: TStringListCompare);
var
I, J: Integer;
P: TStringItem;
begin
repeat
I := L;
J := R;
P := FListPtr^[(L + R) shr 1];
repeat
while Compare(FListPtr^[I], P) < 0 do
Inc(I);
while Compare(FListPtr^[J], P) > 0 do
Dec(J);
if I <= J then
begin
ExchangeItems(I, J);
Inc(I);
Dec(J);
end;
until
I > J;
if L < J then
QuickSort(L, J, Compare);
L := I;
until
I >= R;
end;

procedure TcStringList.Sort(Compare: TStringListCompare);
begin
{trick to gain access to private data}
FListptr := TStringListCracker(Self).FList;
QuickSort(0, Count - 1, Compare);
end;

function Example1(var X, Y: TStringItem): integer;
begin
Result := CompareStr(X.FString, Y.FString);
end;

function Example2(var X, Y: TStringItem): integer;
begin
Result := CompareStr(copy(X.FString, 2, 5), copy(Y.FString, 2, 5));
end;

function Example3(var X, Y: TStringItem): integer;
begin
if integer(X.FObject) > integer(Y.FObject) then
result := 1
else if integer(X.FObject) < integer(Y.FObject) then
result := -1
else
result := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
fSList: TcStringList;
I, J, K, L: integer;
s: string;
begin
fSList := TcStringList.create;
for I := 0 to 10000 do
begin
s := '';
for K := 10 to Random(20) + 10 do
s := s + char(random(26) + 65);
L := random(20000);
fSList.addobject(s, pointer(L));
end;
listbox1.items.add('Sorting');
application.processmessages;
fSList.addobject('Dennis', pointer(10000));
fSList.Sorted := false; {disable default Sort}
fSList.Sort(Example1); {replacement Alpha sort}
fSList.Sorted := true; {enable Binary searching}
listbox1.items.add('Done');
application.processmessages;
{if ByStringPosdata then
fSList.Sort(Example2);
if ByObjectValue then
fSList.Sort(Example3);}
listbox1.items.assign(fSList);
showmessage('Dennis is at line number #' + inttostr(fSList.Indexof('Dennis')));
fSList.free;
end;

end.