[Back to OOP SWAG index] [Back to Main SWAG index] [Original]
unit TSortLst;
(*
Version 1.0 5/12/95 - Mike Stortz
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.
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.
*)
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.
[Back to OOP SWAG index] [Back to Main SWAG index] [Original]