На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
Модераторы: Rouse_, jack128, Krid
  
    > TRecordList<T: record> — класс для удобного хранения списка записей
      TRecordList<T: record> — класс для удобного хранения списка записей

      В 2010-м Delphi наконец-то допилили поддержку дженериков до нормального уровня, и я реализовал давнюю мечту - потомок TList для хранения записей (в том числе с полями ссылочного типа). Список поддерживает добавление как уже выделенных указателей на запись, так и самих записей (в этом случае он выделяет память и создает копию). Освобождение памяти происходит автоматически. Также добавлены методы для поиска и сортировки по произвольному условию. Если список отсортирован, производится бинарный поиск, который намного быстрее поиска перебором.

      09.12.2010 Добавлена поддержка сортировки, свойство Duplicates, бинарный поиск.

      ExpandedWrap disabled
        type
          // под 2009 не работает с объявлением типа PT = ^T
          {$IF CompilerVersion < 21.0}Только для Delphi 2010+{$IFEND}
          
          { Список, заточенный под хранение указателей на записи
            На добавление принимает как уже выделенные указатели, так и константные записи
            При удалении элемента память освобождается внутри класса
            Если надо объявить тип указателя на запись, это делается так:
              type PRec = TRecordList<TRec>.PT, поскольку компилятор считает, что
              ^TRec и TRecordList<TRec>.^T - это разные типы
            Поддерживает сортировку и двоичный поиск. При этом функция сравнения, использованная
              для сортировки, сохраняется в поле класса и используется при поиске }
          TRecordList<T: record> = class(TList)
          public
            type PT = ^T;
                 TMatchFn   = reference to function(const item: PT): Boolean;
                 TCompareFn = reference to function(const item1, item2: PT): Integer;
                 TNotifyFn  = reference to procedure(const item: PT; Action: TListNotification);
          protected
            // fields
            FOnCheckMatch: TMatchFn;
            FOnCompare   : TCompareFn;
            FOnNotify    : TNotifyFn;
            FSorted      : Boolean;
            FDuplicates  : TDuplicates;
            // overridden methods
            function Get(Index: Integer): PT;
            procedure Put(Index: Integer; Item: PT);
            procedure Notify(Ptr: Pointer; Action: TListNotification); override;
            // setters
            procedure SetSorted(Value: Boolean);
            procedure SetOnCompare(Fn: TCompareFn);
            // internal methods
            function BinaryFind(const Item: T; var Index: Integer): Boolean;
          public
            // methods
            function Add(Item: PT): Integer; overload;
            function Add(const Item: T): Integer; overload;
            function Locate(const Item: T): Integer; overload;
            function Locate(MatchFn: TMatchFn): Integer; overload;
            procedure Sort; overload;
            procedure Sort(CompareFn: TCompareFn); overload;
            // properties
            property Items[Index: Integer]: PT read Get write Put; default;
            property Sorted: Boolean read FSorted write SetSorted;
            property Duplicates   : TDuplicates read FDuplicates   write FDuplicates;
            property OnCheckMatch : TMatchFn    read FOnCheckMatch write FOnCheckMatch;
            property OnCompare    : TCompareFn  read FOnCompare    write SetOnCompare;
            property OnNotify     : TNotifyFn   read FOnNotify     write FOnNotify;
          end;
          {$ENDIF}
         
        ...
         
        {$REGION 'TRecordList<T>'}
         
        {$IF CompilerVersion >= 21.0}
        // Удостоверяемся, что сортировка и бинарный поиск будет производиться
        // с одним и тем же методом сравнения
        procedure TRecordList<T>.SetOnCompare(Fn: TCompareFn);
        begin
          FOnCompare := Fn;
          FSorted := False;
        end;
         
        // Бинарный поиск; возвращает True, если элемент найден.
        // В Index - индекс искомого или ближайшего к нему элемента
        function TRecordList<T>.BinaryFind(const Item: T; var Index: Integer): Boolean;
        var Start, Finish, I, CompRes: Integer;
        begin
          Result := False;
          Start := 0;
          Finish := Count - 1;
          while Start <= Finish do
          begin
            I := (Start + Finish) shr 1;
            CompRes := FOnCompare(Get(I), @Item);
            if CompRes = ValLess then Start := I + 1
            else
            begin
              Finish := I - 1;
              if CompRes = ValEqual then
              begin
                Result := True;
                if Duplicates <> dupAccept then Start := I;
              end;
            end;
          end; // while
          Index := Start;
        end;
         
        // Если список отсортирован, то делаем бинарный поиск. Если нет - простой перебор
        function TRecordList<T>.Locate(const Item: T): Integer;
        begin
          if not FSorted then
            Result := Locate(FOnCheckMatch)
          else
            if not BinaryFind(Item, Result) then
              Result := -1;
        end;
         
        // Простой перебор
        function TRecordList<T>.Locate(MatchFn: TMatchFn): Integer;
        var ppList: PPointerList;
        begin
          if not Assigned(MatchFn) then
            raise Exception.Create('MatchFn is not assigned');
          ppList := List;
          for Result := 0 to Count - 1 do
            if MatchFn(PT(ppList^[Result])) then
              Exit;
          Result := -1;
        end;
         
        // Сортировка на основе присвоенного ранее обработчика события
        procedure TRecordList<T>.Sort;
        begin
          if not Assigned(FOnCompare) then
            raise Exception.Create('FOnCompare is not assigned');
          inherited SortList(TListSortCompareFunc(FOnCompare));
        end;
         
        // Сортировка на основе указанной функции - копирует её в поле обработчика
        procedure TRecordList<T>.Sort(CompareFn: TCompareFn);
        begin
          OnCompare := CompareFn;
          Sort;
          FSorted := True;
        end;
         
        // Установка свойства
        procedure TRecordList<T>.SetSorted(Value: Boolean);
        begin
          if FSorted <> Value then
          begin
            if Value then Sort;
            FSorted := Value;
          end;
        end;
         
        // Добавление указателя
        function TRecordList<T>.Add(Item: PT): Integer;
        begin
          if not FSorted then
            Result := Count
          else
            if BinaryFind(Item^, Result) then
              case Duplicates of
                dupIgnore : Exit;
                dupError  : IceUtils.Error('Duplicate record');
              end;
          Insert(Result, Item);
        end;
         
        // Добавление записи (выделяет память и копирует запись)
        function TRecordList<T>.Add(const Item: T): Integer;
        var pItem: PT;
        begin
          pItem := AllocMem(SizeOf(T));
          pItem^ := Item;
          Result := Add(pItem);
        end;
         
        // Уведомление об удалении элемента - освобождаем выделенную память
        procedure TRecordList<T>.Notify(Ptr: Pointer; Action: TListNotification);
        begin
          if Assigned(FOnNotify) then
            FOnNotify(PT(Ptr), Action);
          // удаляем запись
          if Action = lnDeleted then
          begin
            {$HINTS OFF}Finalize(PT(Ptr)^);{$HINTS ON} // если нечего финализировать, то компилер проигнорирует эту строку
            FreeMemory(PT(Ptr));
          end;
        end;
         
        // Простые обёртки для получения и присвоения элементов в нужном типе
        procedure TRecordList<T>.Put(Index: Integer; Item: PT);
        begin
          inherited Put(Index, Item);
        end;
         
        function TRecordList<T>.Get(Index: Integer): PT;
        begin
          Result := PT(inherited Get(Index));
        end;
        {$IFEND}
         
        {$ENDREGION}


      Пример использования:
      ExpandedWrap disabled
        type
          TRec = record
            b: byte;
            a: array of Byte;
            s: string;
          end;
          PRec = TRecordList<TRec>.PT; // !!! объявление указателя на запись
         
        var lst: TRecordList<TRec>;
            rec: TRec;
            pr: PRec;
         
          // создание
          lst := TRecordList<TRec>.Create;
         
          // сортировка
          lst.Sort(function(const Item1, Item2: PRec): Integer
                   begin
                     Result := AnsiCompareStr(Item1.s, Item2.s);
                   end);
         
          // добавление записи
          rec.b := 1;
          SetLength(rec.a, 10);
          rec.s := 'foo';
          lst.Add(rec);
         
          // добавление указателя на запись
          pr := AllocMem(SizeOf(TRec));
          pr.b := 2;
          SetLength(pr.a, 20);
          pr.s := 'bar';
          lst.Add(pr);
         
          // получение элемента
          log(lst[0].s);
          log(lst[1].s);
         
          // поиск по произвольному условию
          log(IntToStr(
          lst.Locate(function (const item: PRec): Boolean
                      begin
                        Result := item.b = 2;
                      end)));


      Эта тема была разделена из темы "TRecordList<T: record> — класс для удобного хранения списка записей"
      Сообщение отредактировано: Fr0sT -
      0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
      0 пользователей:


      Рейтинг@Mail.ru
      [ Script execution time: 0,0207 ]   [ 16 queries used ]   [ Generated: 29.03.24, 14:18 GMT ]