Автор: Александр Шарахов
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Список чисел и объектов с расширенными возможностями бинарного поиска.

В списке хранятся:
Data - числа (идентификаторы/свойства/хеши объектов), по которым планируется
выполнять поиск,
Objects - указатели на соответствующие объекты,
SeqNo - последовательные номера, присвоенные элементам при добавлении в список.

Класс TDataList аналогичен TStringList.
Основные особенности:
1. Тип TData выбирается произвольно (требуется перекомпиляция).
2. В сортированном списке дубликаты всегда упорядочены в порядке поступления.
Eсли количество добавлений превышает 2*MaxInt+1, данное правило может
нарушаться. Если это критично, исправьте тип FSeqNo на int64.
3. Свойство Duplicates (разрешены ли дубликаты) имеет тип boolean.
4. Из-за операций с дубликатами никогда не возникают исключения.
5. Если в сортированном списке дубликаты не разрешены, метод Add при добавлении
дубликата возвращает отрицательное значение, позволяющее определить положение
в списке конфликтующего элемента.
6. Методы Insert и Delete не выполняют никаких действий с недопустимым индексом.
Метод Insert также не выполняет никаких действий при попытке вставить элемент
в сортированный список.
7. Кроме очевидных методов поиска IndexOfData, IndexOfObject, IndexOfSeqNo,
возвращающих индекс первого подходящего элемента, существуют также:
function FindFirstGE(D: TData; var Index: integer): boolean;
function FindLastLE(D: TData; var Index: integer): boolean;
Первая функция используется для определения в сортированном списке индекса
первого элемента, большего или равного указанному, вторая - для определения
индекса последнего элемента, меньшего или равного указанному. Положительный
результат означает, что найден элемент, равный указанному, и его индекс
помещается в переменную Index. В случае отрицательного результата в нее
помещается индекс элемента (если бы такой элемент существовал), большего
или меньшего указанного. Это значение может выходить за границы списка.
8. Фукции
function FindFirstCount(D: TData; var Index: integer): integer;
function FindLastCount(D: TData; var Index: integer): integer;
могут использоваться для поиска в сортированном списке с одновременным
подсчетом количества элементов, равных указанному. Если количество
найденных элементов отличается от нуля, то переменная Index принимает
значение соответственно первого или последнего из найденных элементов.

Зависимости: нет
Автор:       Александр Шарахов, alsha@mailru.com, Москва
Copyright:   Александр Шарахов
Дата:        19 января 2003 г.
***************************************************** }

unit DataLst;

interface

{ TDataList class }

type
  TData = cardinal;
  TDataItem = record
    FData: TData;
    FObject: TObject;
    FSeqNo: cardinal; // To sort duplicates in addition order
  end;
  PDataItem = ^TDataItem;

  TDataItemList = array[0..MaxInt div sizeof(TDataItem) - 1] of TDataItem;
  PDataItemList = ^TDataItemList;

  TDataCompare = function(PDI1, PDI2: PDataItem): integer;

  TDataList = class
  private
    FList: PDataItemList;
    FCount: integer;
    FCapacity: integer;
    FSeqCount: cardinal;
    FSorted: boolean;
    FDuplicates: boolean; // If true then allow duplicates
    procedure ExchangeItems(Index1, Index2: integer);
    procedure Grow;
    procedure QuickSort(L, R: integer; Compare: TDataCompare);
    procedure InsertItem(Index: integer; D: TData; O: TObject);
    procedure SetSorted(Value: boolean);
  protected
    function GetCapacity: integer;
    function GetData(Index: integer): TData;
    function GetObject(Index: integer): pointer {TObject};
    function GetSeqNo(Index: integer): cardinal;
    procedure PutData(Index: integer; D: TData);
    procedure PutObject(Index: integer; O: pointer {TObject});
    procedure SetCapacity(NewCapacity: integer);
  public
    destructor Destroy; override;
    function Add(D: TData; O: TObject): integer; virtual;
    procedure Clear; virtual;
    procedure Delete(Index: integer); virtual;
    procedure Exchange(Index1, Index2: integer); virtual;
    function FindFirstGE(D: TData; var Index: integer): boolean; virtual;
    function FindLastLE(D: TData; var Index: integer): boolean; virtual;
    function FindFirstCount(D: TData; var Index: integer): integer; virtual;
    function FindLastCount(D: TData; var Index: integer): integer; virtual;
    function IndexOfData(D: TData): integer; virtual;
    function IndexOfObject(O: TObject): integer; virtual;
    function IndexOfSeqNo(SN: cardinal): integer; virtual;
    procedure Insert(Index: integer; D: TData; O: TObject); virtual;
    procedure Sort; virtual;
    property Data[Index: integer]: TData read GetData write PutData;
    property Objects[Index: integer]: pointer {TObject} read GetObject write
      PutObject;
    property SeqNo[Index: integer]: cardinal read GetSeqNo;
    property Count: integer read FCount;
    property Duplicates: boolean read FDuplicates write FDuplicates;
    property Sorted: boolean read FSorted write SetSorted;
  end;

implementation

{ TDataList }

destructor TDataList.Destroy;
begin
  ;
  inherited Destroy;
  FCount := 0;
  SetCapacity(0);
  FSeqCount := 0;
end;

function TDataList.Add(D: TData; O: TObject): integer;
begin
  ;
  if FSorted then
    if FindLastLE(D, Result) then
      if FDuplicates then
        inc(Result)
      else
        Result := -1 - Result // Can't add duplicate
    else
      inc(Result)
  else
    Result := FCount;
  if Result >= 0 then
    InsertItem(Result, D, O);
end;

procedure TDataList.Clear;
begin
  ;
  if FCount <> 0 then
  begin
    ;
    FCount := 0;
    SetCapacity(0);
    FSeqCount := 0;
  end;
end;

procedure TDataList.Delete(Index: integer);
begin
  ;
  if (Index >= 0) and (Index < FCount) then
  begin
    ;
    dec(FCount);
    if Index < FCount then
      System.Move(
        FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(TDataItem));
  end;
end;

procedure TDataList.Exchange(Index1, Index2: integer);
begin
  ;
  if (not FSorted) and (Index1 >= 0) and (Index1 < FCount) and (Index2 >= 0) and
    (Index2 < FCount) then
    ExchangeItems(Index1, Index2);
end;

procedure TDataList.ExchangeItems(Index1, Index2: integer);
var
  Item1, Item2: PDataItem;
  Temp: TDataItem;
begin
  ;
  Item1 := @FList^[Index1];
  Item2 := @FList^[Index2];
  Temp := Item1^;
  Item1^ := Item2^;
  Item2^ := Temp;
end;

function TDataList.GetCapacity: integer;
begin
  ;
  Result := FCapacity;
end;

function TDataList.GetData(Index: integer): TData;
begin
  ;
  if (Index < 0) or (Index >= FCount) then
    Result := 0
  else
    Result := FList^[Index].FData;
end;

function TDataList.GetObject(Index: integer): pointer {TObject};
begin
  ;
  if (Index < 0) or (Index >= FCount) then
    Result := nil
  else
    Result := FList^[Index].FObject;
end;

function TDataList.GetSeqNo(Index: integer): cardinal;
begin
  ;
  if (Index < 0) or (Index >= FCount) then
    Result := 0
  else
    Result := FList^[Index].FSeqNo;
end;

procedure TDataList.Grow;
var
  Delta: integer;
begin
  ;
  if FCapacity > 64 then
    Delta := FCapacity div 4
  else
    Delta := 16;
  SetCapacity(FCapacity + Delta);
end;

function TDataList.IndexOfData(D: TData): integer;
begin
  ;
  if FSorted then
    if FindFirstGE(D, Result) then {found}
    else
      Result := -1
  else
  begin
    ;
    Result := 0;
    while (Result < FCount) and (D <> FList^[Result].FData) do
      inc(Result);
    if Result >= FCount then
      Result := -1;
  end;
end;

function TDataList.IndexOfObject(O: TObject): integer;
begin
  ;
  Result := 0;
  while (Result < FCount) and (O <> FList^[Result].FObject) do
    inc(Result);
  if Result >= FCount then
    Result := -1;
end;

function TDataList.IndexOfSeqNo(SN: cardinal): integer;
begin
  ;
  Result := 0;
  while (Result < FCount) and (SN <> FList^[Result].FSeqNo) do
    inc(Result);
  if Result >= FCount then
    Result := -1;
end;

procedure TDataList.Insert(Index: integer; D: TData; O: TObject);
begin
  ;
  if (not FSorted) and (Index >= 0) and (Index < FCount) then
    InsertItem(Index, D, O);
end;

procedure TDataList.InsertItem(Index: integer; D: TData; O: TObject);
begin
  ;
  if FCount = FCapacity then
    Grow;
  if Index < FCount then
    System.Move(FList^[Index], FList^[Index + 1], (FCount - Index) *
      SizeOf(TDataItem));
  with FList^[Index] do
  begin
    ;
    FData := D;
    FObject := O;
    FSeqNo := FSeqCount;
  end;
  inc(FCount);
  inc(FSeqCount);
end;

procedure TDataList.PutData(Index: integer; D: TData);
begin
  ;
  if (not FSorted) and (Index >= 0) and (Index < FCount) then
    FList^[Index].FData := D;
end;

procedure TDataList.PutObject(Index: integer; O: pointer {TObject});
begin
  ;
  if (Index >= 0) and (Index < FCount) then
    FList^[Index].FObject := O;
end;

procedure TDataList.SetCapacity(NewCapacity: integer);
begin
  ;
  ReallocMem(FList, NewCapacity * SizeOf(TDataItem));
  FCapacity := NewCapacity;
end;

function FindDataCompare(PDI1, PDI2: PDataItem): integer;
begin
  ;
  Result := 0;
  if PDI1^.FData < PDI2^.FData then
    dec(Result)
  else if PDI1^.FData > PDI2^.FData then
    inc(Result);
end;

function TDataList.FindFirstGE(D: TData; var Index: integer): boolean;
var
  i, j, t, c: integer;
begin
  ;
  Result := false;
  i := -1; // Index of the element less than D
  j := FCount - 1;
  if FSorted then
    while i < j do
    begin
      ;
      t := (i + j + 1) shr 1; // Round to right
      c := FindDataCompare(@FList^[t].FData, @D);
      if c < 0 then
        i := t
      else
      begin
        ;
        j := t - 1;
        if c = 0 then
          Result := true;
      end;
    end;
  Index := i + 1;
end;

function TDataList.FindLastLE(D: TData; var Index: integer): boolean;
var
  i, j, t, c: integer;
begin
  ;
  Result := false;
  i := 0;
  j := FCount; // Index of the element greater than D
  if FSorted then
    while i < j do
    begin
      ;
      t := (i + j) shr 1; // Round to left
      c := FindDataCompare(@FList^[t].FData, @D);
      if c > 0 then
        j := t
      else
      begin
        ;
        i := t + 1;
        if c = 0 then
          Result := true;
      end;
    end;
  Index := j - 1;
end;

function TDataList.FindFirstCount(D: TData; var Index: integer): integer;
begin
  ;
  if FindFirstGE(D, Index) then
  begin
    ;
    Result := 1;
    while FindDataCompare(@FList^[Index + Result].FData, @D) = 0 do
      inc(Result);
  end
  else
    Result := 0;
end;

function TDataList.FindLastCount(D: TData; var Index: integer): integer;
begin
  ;
  if FindLastLE(D, Index) then
  begin
    ;
    Result := 1;
    while FindDataCompare(@FList^[Index - Result].FData, @D) = 0 do
      inc(Result);
  end
  else
    Result := 0;
end;

function SortDataCompare(PDI1, PDI2: PDataItem): integer;
begin
  ;
  Result := 0;
  if PDI1^.FData < PDI2^.FData then
    dec(Result)
  else if PDI1^.FData > PDI2^.FData then
    inc(Result)
      // Compare duplicates
  else if PDI1^.FSeqNo < PDI2^.FSeqNo then
    dec(Result)
  else if PDI1^.FSeqNo > PDI2^.FSeqNo then
    inc(Result);
end;

procedure TDataList.QuickSort(l, r: integer; Compare: TDataCompare);
var
  i, j, p: integer;
begin
  ;
  repeat;
    i := l;
    j := r;
    p := (i + j) shr 1;
    repeat;
      while Compare(@FList^[i], @FList^[p]) < 0 do
        inc(i);
      while Compare(@FList^[p], @FList^[j]) < 0 do
        dec(j);
      if i <= j then
      begin
        ;
        ExchangeItems(i, j);
        if p = i then
          p := j
        else if p = j then
          p := i;
        inc(i);
        dec(j);
      end;
    until i > j;
    if l < j then
      QuickSort(l, j, Compare);
    l := i;
  until i >= r;
end;

procedure TDataList.Sort;
begin
  if (not FSorted) and (FCount > 1) then
    QuickSort(0, FCount - 1, SortDataCompare);
end;

procedure TDataList.SetSorted(Value: boolean);
begin
  if FSorted <> Value then
  begin
    if Value then
      Sort;
    FSorted := Value;
  end;
end;

end.