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.