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.