Автор: Юрий Иванов
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> TSortList - работа с отсортированным списком

Класс для работы с отсортированным списком. Использует базовый класс TList.
Позволяет добавлять элементы в отсортированном порядке, производить
быстрый поиск элементов и очищать память указателей и память,
распределенную для элементов хранения.
Добавлены 1 свойство и 4 новых метода:
Свойство:
Compare - имя функции сравнения типа TListSortCompare.
Методы:
AddSort - позволяет добавлять элементы в список в отсортированном порядке.
Search - осуществляет быстрый поиск элемента в отсортированном списке (возвращает его номер или -1).
GetItem - возвращает указатель на найденный элемент, если элемент отсутствует, возвращается nil.
ClearAll - очищает память указателей и память, распределенную под хранение элементов Item.

Зависимости: Classes, SysUtils
Автор:       Юрий, i7@mail.ru, Тверь
Copyright:   Юрий Иванов (http://www.ivanovtver.chat.ru/sortlistr.zip)
Дата:        30 июля 2003 г.
***************************************************** }

{******************************************************************************
* SortList *
* -------- *
* Класс для работы с отсортированным списком. Использует базовый класс TList.*
* Позволяет добавлять элементы в отсортированном порядке и производить *
* быстрый поиск элементов. *
* Добавлены 1 свойство и 4 новых метода: *
* Свойство: Compare - имя функции сравнения типа TListSortCompare. *
* Смотри описание метода Sort в TList. *
* Имя функции должно быть назначено до выполнения методов*
* AddSort и Search. Если это не сделано, то генерируется *
* ошибка. *
* Методы: AddSort - позволяет добавлять элементы в List в *
* отсортированном порядке. *
* Search - осуществляет быстрый поиск элемента в *
* отсортированном списке. Item - указатель на искомый *
* элемент. Может содержать только "ключевые" значения, *
* используемые в функции сравнения. *
* Возврат - номер элемента в списке, начиная с 0. *
* Если элемент не найден, то возвращается отрицательное *
* значение (-1). *
* GetItem - возвращает указатель на найденный элемент *
* если элемент отсутствует, возвращается nil *
* ClearAll - очищает память указателей и память, *
* распределенную под хранение элементов Item *
* Внимание! Во избежание нарушения порядка сортировки, не пользуйтесь *
* совместно с новым AddSort методами Add и Insert, *
* оставшимися от TList. *
*******************************************************************************
* Может использоваться без ограничений. *
******************************************************************************* *
* Разработчик Иванов Ю. E-mail: i7@mail.ru *
* Информацию о других разработках автора можно посмотреть на странице *
* http://i7.da.ru *
* *
* декабрь 2000 г. - июль 2002 *
*******************************************************************************
Пример использования:
interface
...
type Tdat = record
     kod: integer;
     txt: string[50];
     num: double;
end;
...
var
    ldat: TSortList;
    dat: ^Tdat;
...
implementation
//*********************************************
function Sort_dat(i1,i2: Pointer): integer;
var
d1,d2: ^Tdat;
begin
    d1:=i1; d2:=i2;
    if d1^.kod < d2^.kod then Result:=-1
    else
      if d1^.kod > d2^.kod then Result:=1
      else
        Result:=0;
end;
//*********************************************
procedure ....
var
 d: Tdat;
 pos: integer;
begin
...
   // добавление элемента
        New(dat);
        dat^.kod:=kodd;
        dat^.txt:=st;
        dat^.num:=dob;
        ldat.AddSort(dat);
    end;
...
  // поиск элемента по "ключевым полям"
        d.kod:=8613;
        pos:=ldat.Search(@d);
        if pos < 0 then
          ShowMessage('элемент '+ IntToStr(d.kod) + ' не найден')
        else
        dat:=ldat.Items[pos];
...
  // получение элемента по "ключевым полям"
        d.kod:=8613;
        dat:=ldat.GetItem(@d);
        if dat = nil then
          ShowMessage('элемент '+ IntToStr(d.kod) + ' не найден')
...
  // очистка списка и памяти элементов
        ldat.ClearAll;
...
end;
...
initialization
  ldat:=TSortList.Create;
  ldat.Compare:=Sort_dat;
finalization
  ldat.Free;
end.
*********************************************************************}
unit Sortlist;

interface
uses Classes, SysUtils;

type
  TSortList = class(TList)
  private
    Ret: integer;
    ERR: byte;
    pcl, pcr: Pointer;
    FCompare: TListSortCompare;
    procedure SetCompare(Value: TListSortCompare);
    function SearchItem(Item: Pointer): integer;
    procedure QuickSearch(Item: Pointer; L, R: integer);
  public
    procedure AddSort(Item: Pointer);
    function Search(Item: Pointer): integer;
    procedure ClearAll;
    function GetItem(Item: Pointer): Pointer;
    property Compare: TListSortCompare read FCompare write SetCompare;
  end;
implementation
//*******************************************

procedure TSortList.ClearAll;
var
  i: integer;
  Item: Pointer;
begin
  if Count <> 0 then
    for i := 0 to Count - 1 do
    begin
      item := Items[i];
      try
        Dispose(Item);
      except
      end;
    end;
  Clear;
end;
//------------------------------------------------------

procedure TSortList.SetCompare(Value: TListSortCompare);
begin
  FCompare := Value;
end;
//-----------------------------------------------------------

procedure TSortList.QuickSearch(Item: Pointer; L, R: integer);
var
  K: Integer;
  P: Pointer;
begin
  ERR := 0;
  Ret := -1;
  pcl := Items[L];
  if Compare(Item, pcl) < 0 then
  begin
    Ret := L;
    ERR := 1;
    exit;
  end
  else if Compare(Item, pcl) = 0 then
  begin
    Ret := L;
    exit;
  end;
  pcr := Items[R];
  if Compare(Item, pcr) > 0 then
  begin
    Ret := R;
    ERR := 2;
    exit;
  end
  else if Compare(Item, pcr) = 0 then
  begin
    Ret := R;
    exit;
  end;
  //-----------------
  if R - L > 1 then
  begin
    K := (R - L) div 2;
    P := items[L + K];
    if Compare(Item, P) < 0 then
      QuickSearch(Item, L, L + K)
    else
    begin
      if Compare(Item, P) > 0 then
        QuickSearch(Item, L + K, R)
      else if Compare(Item, P) = 0 then
      begin
        Ret := L + K;
        exit;
      end;
    end;
  end
  else
  begin
    ERR := 1;
    ret := R;
  end;
end;
//----------------------------------------------------

function TSortList.SearchItem(Item: Pointer): integer;
begin
  if Count > 0 then
  begin
    QuickSearch(Item, 0, Count - 1);
    Result := Ret;
  end
  else
  begin
    Result := 0;
    ERR := 2;
  end;
end;
//------------------------------------------------

function TSortList.Search(Item: Pointer): integer;
begin
  if Addr(Compare) = nil then
  begin
    Error('Функция сравнения не назначена', -1);
    Result := -1;
    exit;
  end;
  Result := SearchItem(item);
  if ERR <> 0 then
    Result := -1;
end;
//-----------------------------------------

procedure TSortList.AddSort(item: Pointer);
var
  i: integer;
begin
  if Addr(Compare) = nil then
  begin
    Error('Функция сравнения не назначена', -1);
    exit;
  end;
  i := SearchItem(item);
  if (ERR = 0) or (ERR = 1) then
    Insert(i, item)
  else if ERR = 2 then
    Add(item);
end;
//-------------------------------------------------

function TSortList.GetItem(Item: Pointer): Pointer;
var
  i: integer;
begin
  i := Search(Item);
  if i = -1 then
    Result := nil
  else
    Result := Items[i];
end;
end.