A: Borland Pascal 7.0 has a very useful object called a TCollection that allows you to sort items by any key you wish and that disposes of any objects it owns when the collection itself is freed. Inexplicably, these very useful behaviors were omitted from Delphi's TStringList. But now... <trumpet fanfare>
This unit contains a class called "TSortableList" derived from TStringList that supports the ability for you to define descendent classes that sort the list any way you wish and has the option to "own" the objects that are added to it, so that they are disposed with the list.
How to use a TSortableList that owns its objects:
1. Create a new TSortableList and tell it that it should own any objects in it.
var
my_list : TSortableList;
begin
my_list := TSortableList.Create(True);
{ "True" = Owns objects }
my_list.Add('Aaa', TObject.Create);
{ In a TStringList, this... }
my_list.Add('Bbb', TObject.Create);
{ ...would be... }
my_list.Add('Ccc', TObject.Create);
{ ...very bad! }
my_list.Free;
{ All objects freed }
end;
How to sort on an arbitrary key:
Suppose you wanted a list of strings sorted by all but the first character (i.e. this order -> "ZAble", "YBaker", "XCharlie").
1. Declare a descendent of TSortableList and override
the Compare method. The Compare method should return an integer such that
the result is:
-1 if the item at
index i1 is "less" than the item at i2
0 if the item
at index i1 is "equal" than the item at i2
1 if the item
at index i1 is "more" than the item at i2
TExList = class(TSortableList)
function Compare(i1, i2
: Integer) : Integer; override;
end;
2. Define the new compare method
function Compare(i1, i2 : Integer) :
Integer;
begin
case Key of
1 :
Result := AnsiCompareText(Copy(Strings[i1], 2, 254),
Copy(Strings[i2], 2, 254));
else
Result := inherited Compare(i1, i2);
end;
end;
3. Specify the key you just defined.
var
my_list : TExList;
begin
my_list := TExList.Create;
my_list.Key := 1;
{ <<<<< New key is made active }
DoSomeStuff;
my_list.Free;
end;
There you go! I strongly suggest that any Key that you define Compare methods for have a value of at least 1 and that all unhandled Key values be passed to the inherited method, as above. A Key of 0 is defined to be the default alphabetical sort.
Note that you can define a Key based on the objects in a list, like so:
function Compare(i1, i2 : Integer) :
Integer;
begin
case Key of
1 :
Result := AnsiCompareText(TSomeObject(Objects[i1]).Text,
TSomeObject(Objects[i2].Text);
else
Result := inherited Compare(i1, i2);
end;
end;
Of course, it is your responsibility to be sure that the objects in the list are the type that your Compare method assumes them to be.
Important
If you do have a list that is a) sorted, and b) determines its order via values derived from the objects that are stored in the list, watch out for changing objects in such a way as to change their sort order; the TSortableList will not know that the list is now out of order and calls to routines that depend on knowing this (such as Add) may fail to work. Your best bet in this case is to set Sorted to False, make whatever changes to the objects you wish, and then set Sorted back to True. This will resort the list.
I also took the liberty of "protecting" the
Find method against the possibility that someone would call it when the
list was not sorted -- in that case, it now calls IndexOf (which, somewhat
recursively, would call Find if the list was sorted). This is exactly
what happened in the example code for Find! If you look at the method
list for TStringList, you won't find Find -- but you can do a topic search
for it. The example code for Find works, but only by chance -- add
another string to either end of the list, and "Flowers" won't be found.
What's wrong with the example code is that the list's Sorted property is
not set to True; the reason it (accidently) works is because the item that
was being found ("Flowers") happened to be the middle item in the list,
which is where the search algorithm looks first.
unit TSortLst;
interface
Uses
Classes;
type
TSortableList = class(TStringList)
private
FOwnsObjects : Boolean;
FKey : Integer;
FAscending : Boolean;
procedure QuickSort(left, right: Integer);
function CallCompare(i1, i2 : Integer) : Integer;
procedure SetAscending(value : Boolean);
procedure SetKey(value : Integer);
protected
procedure PutObject(index : Integer; AObject : TObject);
override;
function Compare(i1, i2 : Integer) : Integer; virtual;
public
constructor Create(owns_objects : Boolean);
procedure Clear; override;
procedure Delete(index : Integer); override;
function Find(const s : string; var index : Integer):
Boolean; override;
procedure Sort; override;
property Ascending : Boolean read FAscending write
SetAscending;
property Key : Integer read FKey write SetKey;
property OwnsObjects : Boolean read FOwnsObjects;
end;
implementation
Uses
SysUtils;
{ Private Methods }
procedure TSortableList.QuickSort(left, right: Integer);
var
i, j, pivot : Integer;
s : String;
begin
i := left;
j := right;
{ Rather than store the pivot value (which was assumed to be
a string),
store the pivot index }
pivot := (left + right) shr 1;
repeat
while CallCompare(i, pivot) < 0 do
Inc(i);
while CallCompare(j, pivot) > 0 do
Dec(j);
if i <= j then
begin
Exchange(i, j);
{ If we just moved the pivot item, reset
the pivot index }
if pivot = i then
pivot := j
else if pivot = j then
pivot := i;
Inc(i);
Dec(j);
end;
until i > j;
if left < j then
QuickSort(left, j);
if i < right then
QuickSort(i, right);
end;
function TSortableList.CallCompare(i1, i2 : Integer) : Integer;
begin
Result := Compare(i1, i2);
if not FAscending then
Result := -Result;
end;
procedure TSortableList.SetAscending(value : Boolean);
begin
if value <> FAscending then
begin
FAscending := value;
if Sorted then
begin
Sorted := False;
Sorted := True;
end
end;
end;
procedure TSortableList.SetKey(value : Integer);
begin
if value <> FKey then
begin
FKey := value;
if Sorted then
begin
Sorted := False;
Sorted := True;
end
end;
end;
{ Protected Methods }
function TSortableList.Compare(i1, i2 : Integer) : Integer;
begin
Result := AnsiCompareText(Strings[i1], Strings[i2]);
end;
{ Public Methods }
constructor TSortableList.Create(owns_objects : Boolean);
begin
inherited Create;
FOwnsObjects := owns_objects;
FKey := 0;
FAscending := True;
end;
procedure TSortableList.Clear;
var
index : Integer;
begin
Changing;
if FOwnsObjects then
for index := 0 to Count - 1 do
GetObject(index).Free;
inherited Clear;
Changed;
end;
procedure TSortableList.Delete(index: Integer);
begin
Changing;
if FOwnsObjects then
GetObject(index).Free;
inherited Delete(index);
Changed;
end;
function TSortableList.Find(const s : string; var index : Integer):
Boolean;
begin
if not Sorted then
begin
index := IndexOf(s);
Result := (index <> -1);
end
else
Result := inherited Find(s, index);
end;
procedure TSortableList.PutObject(index: Integer; AObject: TObject);
begin
Changing;
if FOwnsObjects then
GetObject(index).Free;
inherited PutObject(index, AObject);
Changed;
end;
procedure TSortableList.Sort;
begin
if not Sorted and (Count > 1) then
begin
Changing;
QuickSort(0, Count - 1);
Changed;
end;
end;
end.
If you have any comments, suggestions or even
criticisms <g> for TSortableList, hey, tough! No, really, send
me some mail at 71744,422. I am particularly interested in bug reports.
Version 1.0 5/12/95 - Mike Stortz