Delphi World - Список чисел и объектов с расширенными возможностями бинарного поиска
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Список чисел и объектов с расширенными возможностями бинарного поиска

Автор: Александр Шарахов
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.
Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования