Object Pascal Delphi 2009, Delphi 2009

Источник: delphiplus

Алексей Коленько

Вступление.

Данная статья знакомит с так называемой техникой Smart pointers. Собственно это никакие не указатели. Для них не существует специальной синтаксической конструкции и ключевых слов. Правильнее под этим термином понимать технику или набор приемов, рецептов создания типов данных с автоматически распределяемой и освобождаемой памятью в Object Pascal Delphi 2009. Я бы даже определил как достаточно мощный шаблон проектирования классов в Delphi 2009 for Win32. В сочетании с другими средствами, введенными в Delphi 2009, эта техника может дать программисту на Object Pascal в руки мощные средства для написания сложных верифицируемых программ или прикладных библиотек с минимальными трудозатратами, легко воспринимаемым кодом и количеством ошибок, пониженным по сравнению с более традиционными подходами.

Для чего эту технику можно использовать?

Давайте, вспомним, как мы все работаем с объектами. Как правило, это выглядит подобно коды на следующей врезке.

type

TSomeClass = class

private

// ................

protected

// ................

public

constructor Create;

destructor Destroy; override;

// ................

published

// ................

end;

// .......................

implementation

procedure SomeProcedure({..Что-то передаем....});

var

SomeClass: TSomeClass;

begin

// Создаем экземпляр класса.

SomeClass:=TSomeClass.Create;

try

// .......................

// .....Что-то делаем.....

// .......................

// ......................

finally

// Удаляем экземпляр класса.

SomeClass.Free;

end;

// .......................

// .....Что-то еще делаем.....

// .......................

end;

// .......................

end.

Первое что мы делаем: создаем экземпляр класса и присваиваем его соответствующей переменной, затем выполняем некоторую полезную работу с этим экземпляром. В заключение, после того как объект перестал быть нужным мы должны освободить выделенную под него память. Каждый раз мы должны проходить путь от

SomeClass:=TSomeClass.Create;

до

SomeClass.Free;

Собственно это не сложно и не должно вызывать осложнений у более или менее опытного программиста. Однако, нередко возникает дилемма: стоит ли или не стоит вызывать в данном случае конструктор или освобождать память ненужного к этому времени экземпляра класса.

Можно поступить по-другому: объявить интерфейс соответствующего класса, присвоить созданный экземпляр класса соответствующей интерфейсной переменной, а дальше работать с ней.

type

ISomeClass = interface(IInterface)

// ................

end;

TSomeClass = class( TIntefacedObject, ISomeClass)

private

// ................

protected

// ................

public

constructor Create;

destructor Destroy; override;

// ................

published

// ................

end;

implementation

// .......................

procedure SomeProcedure({......});

var

SomeClass: ISomeClass;

begin

// Создаем экземпляр класса.

SomeClass:=TSomeClass.Create;

try

// .......................

// .....Что-то делаем.....

// .......................

except

// .......................

// Обрабатываем исключение.

// .......................

end;

// .......................

end.

При выходе из процедуры менеджер памяти удаляет ссылку на интерфейс. Механизм, заложенный в класс TIntefacedObject и интерфейс IInterface, подсчитывает количество ссылок на указанный экземпляр класса TSomeClass и если число ссылок становиться равным нулю - удаляет данный экземпляр класса из памяти.

Недостатки данного метода очевидны для программиста: иерархия наследования нашего прикладного класса должна идти от TIntefacedObject (или по крайней мере он должен реализовывать соответствующие методы) и необходимо объявлять для каждого такого класса необходимый интерфейс. Также у нас остается неприятный (рутинный) кусок кода, связанный с инициализацией экземпляра класса.

// .......................

// Создаем экземпляр класса.

SomeClass:=TSomeClass.Create;

// .......................

// .....Что-то делаем.....

// .......................

Хотелось бы избавиться от такой нужной для экземпляра класса, но достаточно рутинной для программиста процедуры. Сделать процедуру выделения и утилизации памяти экземпляра класса более прозрачной для прикладного программиста. С другой стороны, это дело вкуса… Вся эта "кухня" нужна при программировании под Win32. При работе с версией Delphi for .Net практически все это становится ненужным.

Как использовать технику "интеллектуальных указателей"

Дальше в попытке пояснить технику "интеллектуальных указателей" автор будет придерживаться идей изложенных Марко Кэнту (Marco Cantu) в справочнике по особеностям Delphi 2009 [1].

Рассмотрим задачу с реализацией части библиотеки вычислительной геометрии, связанной с таким интересным геометрическим объектом как "мультиточка". По своей сути "мультиточка" представляет собой некоторый произвольный набор или множество точек, в общем случае многомерного пространства (например, вершины многоугольника на плоскости или множество фактов из некоторого класса или кластера в многомерном признаковом пространстве при решении задач классификации и анализа данных). Для нашей задачи остановимся на 2-мерных точках.

Определим основной элементарный класс из которого состоитит мультиточка - TPointD2.

TPointD2 = packed record

strict private

FX,

FY: single;

private

function GetX: single;

procedure SetX( const Value: single);

function GetY: single;

procedure SetY( const Value: single);

public

procedure Empty;

function IsEmpty: boolean;

function Min( const PT: TPointD2): TPointD2;

function Max( const PT: TPointD2): TPointD2;

function Distance: single;

function Angle: single;

function Invert: TPointD2;

property X: single read GetX write SetX;

property Y: single read GetY write SetY;

end;

Кроме координат на плоскости данный класс (X,Y) содержит некоторое количество методов, которые мы используем в последующих тестах.

Некоторые методы класса TPointD2

procedure Empty;	Инициализирует точку специальными значениями. Создает так называемую "пустую" точку.
function IsEmpty: boolean;	Метод проверяет является ли точка "пустой".
function Min( const PT: TPointD2): TPointD2;	Вычисляет "минимальную" точку из текущей точки и точки PT. Этот метод один из многочисленных других методов класса TPointD2 предназначенных для реализации специфической для данного класса функциональности.
function Max( const PT: TPointD2): TPointD2;	Вычисляет "максимальную" точку из текущей точки и точки PT. Этот метод один из многочисленных других методов класса TPointD2 предназначенных для реализации специфической для данного класса функциональности.
function Distance: single;	Метод вычисляет квадрат расстояния от начала координат до текущей точки.
function Angle: single;	Метод вычисляет угол между вектором направленным из начала координат в текущую точку.
Function Invert: TPointD2;	Метод возвращает точку, имеющую инвертированные координаты текущей точки: . Фактически данный метод производит поворот вектора, направленного из начала координат в текущую точку на угол 180° (обращение).

Определим массив (вектор) 2-мерных точек. Благодаря тому что, что в Delphi 2009 появились обобщенные классы (generic) мы можем сделать это очень просто, добавив в секцию uses объявление модулей Generics.Default и Generics.Collections, а в определение типов

TPointsD2 = class(TList<TPointD2>)

public

destructor Destroy; override;

// На время забудем следующее объявление метода GetComparer класса, хотя оно

// нам понадобиться в последующем.

// class function GetComparer: TComparerPoint; virtual;

end;

Благодаря наличию механизма обобщенных классов нам не понадобиться реализовывать или наследовать всю функциональность класса TList. Все что нужно будет сделано компилятором… Немножко нужно сказать о деструкторе. Собственно, его и не нужно было определять… В данном случае он нужен лишь для демонстрации того как и когда удаляется из памяти экземпляр класса TPointsD2.

destructor TPointsD2.Destroy;

begin

ShowMessage('Удаляется экземпляр класса TPointsD2!');

inherited Destroy;

end;

В реальной задаче можно обойтись и деструктором родительского класса.

Следующим нашим шагом станет собственно первый шаг в определении "интеллектуального указателя" для типа данных "мультиточка" - TMultiPointD2:

Что это нам дает? Пока абсолютно ничего!

TMultiPointD2 = record

strict private

FValue: TPointsD2;

function GetValue: TPointsD2;

public

constructor Create( AValue: TPointsD2); overload;

property Value: TPointsD2 read GetValue;

end;

Обратите внимание на то, что мы не использовали нигде возможностями предоставляемыми механизмом обобщенных классов (generics). Собственно, этого и не нужно для данного примера.

Реализация объявленных методов может быть следующей:

constructor TMultiPointD2.Create( AValue: TPointsD2);

begin

FValue:=AValue;

end;

function TMultiPointD2.GetValue: TPointsD2;

begin

Result:=FValue;

end;

На следующей врезке показан вариант использования данного класса.

Var

VPT: TPointsD2;

MPT: TMultiPointD2;

PT: TPointD2;

begin

//.........................

VPT:=TPointsD2.Create;

MPT.Create( VPT);

with PT do

begin

X:=0.1;

Y:=221.3;

end;

VPT.Add(PT);

MPT.Value.Add(PT);

//.........................

end;

Видно, что это не дает ничего нам полезного. Более того, по завершении процедуры в памяти мы имеем мусор в виде неосвобожденного экземпляра класса TPointsD2. Мы в самом чистом виде имеем дело с утечкой памяти. Попытка вызвать его деструктор приведет к краху программы, поскольку в переменной (в закрытом поле FValue) записи MPT мы имеем ссылку на этот объект, которую сделать предварительно равной nil мы не в состоянии.

Идея техники "интеллектуальных указателей" состоит в том, чтобы определить внутри такого типа данных объект, который занимался бы высвобождением экземпляра интересующего нас прикладного класса в тот момент, когда происходит высвобождение памяти самого "интеллектуального указателя" (например, в момент завершения метода в которой переменная этого типа определена). Как это сделать? Вспомним про интерфейсы. Точнее про интерфейс IInterface.

Итак, нам необходимо добавить в определение TMultiPointD2 поле типа IInterface. Реализация этого интерфейса должна поддерживаться некоторым классом.

Сначала рассмотрим определение этого класса отдельно (см. следующую врезку).

type

TFreeTheValue = class(TInterfacedObject)

private

FObjectToFree: TObject;

public

constructor Create( AObjectToFree: TObject);

destructor Destroy; override;

end;

При таком определении реализация методов класса TFreeTheValue очень простая (см. следующую врезку). Поле FObjectToFree будет содержать ссылку на высвобождаемый объект. Его инициализация происходит в конструкторе:

constructor TFreeTheValue.Create( AObjectToFree: TObject);

begin

FObjectToFree:=AObjectToFree;

End;

Деструктор выполняет всю требуемую от этого класса работу:

destructor TFreeTheValue.Destroy;

begin

FObjectToFree.Free; // Все что нам требуется от данного класса!

inherited Destroy;

end;

Определение прикладного класса TMultiPointD2 примет вид показанный на следующей врезке.

TMultiPointD2 = record

strict private

FValue: TPointsD2;

FFreeTheValue: IInterface;

function GetValue: TPointsD2;

private

type

TFreeTheValue = class (TInterfacedObject)

private

FObjectToFree: TObject;

public

constructor Create( AObjectToFree: TObject);

destructor Destroy; override;

end;

public

constructor Create( AValue: TPoints); overload;

property Value: T read GetValue;

end;

//.........................

Как мы уже говорили, в определение класса внесли поле FFreeTheValue типа IInterface и встроенный тип TFreeTheValue.

Каким образом происходит инициализация FFreeTheValue? В соответствии с предложенной идеологией этим должен заниматься конструктор класса TMultiPointD2. Разработчики Delphi 2009 предлагают следующий вариант, показанный на следующей врезке.

constructor TMultiPointD2.Create( AValue: TPointsD2);

begin

FValue:=AValue;

FFreeTheValue:=TFreeTheValue.Create( FValue);

end;

Теперь рассмотрим полностью весь полученный код.

unit TestMultiPoints;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Controls,

Dialogs,

Generics.Collections, Generics.Defaults, ExtCtrls;

type

TPointD2 = packed record

strict private

FX,

FY: single;

private

function GetX: single;

procedure SetX( const Value: single);

function GetY: single;

procedure SetY( const Value: single);

public

procedure Empty;

function IsEmpty: boolean;

function Min( const PT: TPointD2): TPointD2;

function Max( const PT: TPointD2): TPointD2;

function Distance: single;

function Angle: single;

function Invert: TPointD2;

property X: single read GetX write SetX;

property Y: single read GetY write SetY;

end;

TPointsD2 = class(TList<TPointD2>)

public

destructor Destroy; override;

// class function GetComparer: TComparerPoint; virtual;

end;

TMultiPointD2 = record

strict private

FValue: TPointsD2;

FFreeTheValue: IInterface;

function GetValue: TPointsD2;

private

type

TFreeTheValue = class (TInterfacedObject)

private

FObjectToFree: TObject;

public

constructor Create( AObjectToFree: TObject);

destructor Destroy; override;

end;

public

constructor Create( AValue: TPoints); overload;

property Value: TPointsD2 read GetValue;

end;

implementation

uses

Math;

//===========================================================================

// TPointD2.

function TPointD2.GetX: single;

begin

Result:=FX;

end;

procedure TPointD2.SetX( const Value: single);

begin

FX:=Value;

end;

function TPointD2.GetY: single;

begin

Result:=FY;

end;

procedure TPointD2.SetY( const Value: single);

begin

FY:=Value;

end;

procedure TPointD2.Empty;

begin

Self:=Default(TPointD2); // !!!! Внимание код должен быть изменен!

end;

function TPointD2.IsEmpty: boolean;

begin

Result:=false; // !!!! Внимание код должен быть изменен!

end;

function TPointD2.Min( const PT: TPointD2): TPointD2;

begin

Result.Empty;

if(Self.IsEmpty and (not PT.IsEmpty)) then

exit(PT);

if((not IsEmpty) and PT.IsEmpty) then

exit(Self);

if(not (Self.IsEmpty or PT.IsEmpty)) then

begin

Result.X:=Math.Min( X, PT.X);

Result.Y:=Math.Min( Y, PT.Y);

end;

function TPointD2.Max( const PT: TPointD2): TPointD2;

begin

Result.Empty;

if(not (Self.IsEmpty or PT.IsEmpty)) then

begin

Result.X:=Math.Max( X, PT.X);

Result.Y:=Math.Max( Y, PT.Y);

end;

function TPointD2.Distance: single;

begin

Result:=Sqr(X)+Sqr(Y);

end;

function ArcTg( X, Y: double): double;

begin

if(X = 0.0) then

begin

Result:=Pi/2.0;

if(Y < 0.0) then

Result:=-Result;

end

else

Result:=ArcTan2( Y, X);

end;

function TPointD2.Angle: single;

begin

Result:=ArcTg( X, Y);

end;

function TPointD2.Invert: TPointD2;

begin

Result.X:=-X;

Result.Y:=-Y;

end;

//===========================================================================

// TPointsD2.

destructor TPointsD2.Destroy;

begin

ShowMessage('Удаляется экземпляр класса TPointsD2!');

inherited Destroy;

end;

//===========================================================================

// TMultiPointD2.

constructor TMultiPointD2.Create( AValue: TPoints);

begin

FValue:=AValue;

FFreeTheValue:=TFreeTheValue.Create( FValue);

end;

function TMultiPointD2.GetValue: TPointsD2;

begin

Result:=FValue;

end;

//===========================================================================

// TMultiPointD2.TFreeTheValue.

constructor TMultiPointD2.TFreeTheValue.Create( AObjectToFree: TObject);

begin

FObjectToFree:=AObjectToFree;

end;

destructor TMultiPointD2.TFreeTheValue.Destroy;

begin

FObjectToFree.Free;

inherited Destroy;

end;

end.

Таким образом, мы добились требуемой нами функциональности. Как происходит работа можно посмотреть на следующем тестовом примере.

procedure TForm1.tbTestClick( Sender: TObject);

var

VPT: TPointsD2;

MPT: TMultiPointD2;

PT: TPointD2;

begin

VPT:=TPointsD2.Create;

MPT.Create( VPT);

with PT do

begin

X:=0.1;

Y:=221.3;

end;

VPT.Add(PT);

MPT.Value.Add(PT);

end;

По своей сути этот тот же пример, к которому мы обращались выше. С учетом внесенных изменений в класс TMultiPointD2 мы добились устранения утечки памяти при вызове тестовой процедуры. О том что объект VPT успешно удаляется свидетельствует появление диалогового окна изображенного на следующем рисунке, и являющегося следствием вызова процедуры ShowMessage из деструктора объекта VPT (TPointsD2).

Сообщение класса при его деструкции

Предела совершенству нет. Да и не во всем, тем более в нашем коде. Обратим внимание на следующие две строки кода:

VPT:=TPointsD2.Create;

MPT.Create( VPT);

Опять мы вызываем конструкторы. Можно ли обойтись без них? Оказывается, можно! Тем более что массив VPT нужен только для методов нашего "интеллектуального указателя". Посмотрим, что можно для этого сделать.

Модифицируем код метода GetValue следующим образом:

function TMultiPointD2.GetValue: TPointsD2;

begin

if( not Assigned(FFreeTheValue)) then

Empty;

Result:=FValue;

end;

У нас появилась следующие операторы

//.........................

if( not Assigned(FFreeTheValue)) then

Empty;

//.........................

Перед тем как возвратить инкапсулированный экземпляр прикладного класса мы смотрим инициирована ли переменная FFreeTheValue или нет. Если переменная FFreeTheValue не инициирована, то значит, экземпляр прикладного класса не инициализирован и нам его необходимо создать. Это должен выполнить некоторый новый метод Empty.

procedure TMultiPointD2.Empty();

begin

Create( TPointsD2.Create( nil));

end;

Итак, в результате наших улучшений кода "интеллектуального указателя" мы можем опробовать следующий вариант его использования:

procedure TForm1.tbTestClick( Sender: TObject);

var

// VPT: TPointsD2; // Больше не нужно!

MPT: TMultiPointD2;

PT: TPointD2;

begin

// VPT:=TPointsD2.Create; // Больше не нужно!

// MPT.Create( VPT); // Больше не нужно!

with PT do

begin

X:=0.1;

Y:=221.3;

end;

// VPT.Add(PT); // Больше не нужно!

MPT.Value.Add(PT);

with PT do

begin

X:=Random*100;

Y:=221.3*Random;

end;

MPT.Value.Add(PT);

End;

Закомментированные операторы нам больше не нужны! Похоже на чудо, но в данном случае абсолютно рациональная реальность… С этой суровой реальностью нам придется столкнуться в этой статье чуть позже…

Что может еще нас смущать в вышеприведенном примере? Посмотрим на следующие строки кода:

//.........................

MPT.Value.Add(PT);

//.........................

MPT.Value.Add(PT);

//.........................

Конечно! Нас может смущать необходимость каждый раз обращаться к методам прикладного класса посредством вызова метода доступа GetValue "интеллектуального указателя", в данном случае в следующем виде: MPT.Value.Add(PT). Какие здесь существуют решения?

Собственно, вариантов здесь два:

Реализовать собственные методы "интеллектуального указателя", инкапсулирующие вызовы GetValue в вышеприведенном виде.
Использовать возможности, появившиеся в Delphi 2007 по перегрузке операторов класса, а именно оператора неявного приведения типов Implicit.

Для данного случая, в первом варианте можно предложить следующее решение:

procedure TMultiPointD2.Add( PT: TPointD2);

begin

if(not PT.IsEmpty) then

Value.Add( PT);

end;

procedure TMultiPointD2.Add( AValue: TMultiPointD2);

begin

Value.AddRange( AValue.Value);

end;

function TMultiPointD2.GetCount: integer;

begin

Result:=Value.Count;

end;

procedure TMultiPointD2.Clear;

begin

Value.Clear;

end;

В случае использования второго варианта мы должны перегрузить операторы неявного приведения типов:

class operator TMultiPointD2.Implicit( MPT: TMultiPointD2): TPointD2;

begin

Result:=MPT.Value;

end;

class operator TMultiPointD2.Implicit( MPT: TPointD2): TMultiPointD2;

begin

Result:=TMultiPointD2.Create(MPT);

end;

class operator TMultiPointD2.Implicit( PT: TPointD2): TMultiPointD2;

begin

Result.Clear();

Result.Add( PT);

end;

Таким образом, можно использовать следующий тестовый код:

procedure TForm1.tbTestClick( Sender: TObject);

var

MPT: TMultiPointD2;

PT: TPointD2;

begin

with PT do

begin

X:=0.1;

Y:=221.3;

end;

MPT.Add(PT);

for I:= 1 to 25 do

begin

with PT do

begin

X:=Random*100;

Y:=221.3*Random;

end;

MPT.Add(PT);

end;

for PT in MPT.Value do

Memo1.Lines.Add(format('(X:%e,Y:%e)',[PT.X, PT.Y]));

End;

В заключение можно расширить возможности работы с классом TMultiPointD2.

Например, добавим методы инкапсулирующие удаление элементов класса TMultiPointD2. И здесь мы сталкиваемся с первыми проблемами. Рассмотрим, что в этом случае получилось в следующем разделе.

Первый подводный камень. Удаление из массива.

Попробуем реализовать удаление элемента из массива 2-мерных точек. Пишем тестовую процедуру:

Объявление:

procedure Delete( const AIndex: integer);

Реализация:

procedure TMultiPointD2.Delete( const AIndex: integer);

begin

Value.Delete( AIndex);

end;

Тест:

procedure TForm1.tbTestDeleteClick( Sender: TObject);

var

MPT: TMultiPointD2<TPointsD2>;

PT: TPointD2;

begin

with PT do

begin

X:=0.1;

Y:=221.3;

end;

MPT.Add(PT);

for I:= 1 to 25 do

begin

with PT do

begin

X:=Random*100;

Y:=221.3*Random;

end;

MPT.Add(PT);

end;

for PT in MPT.Value do

Memo1.Lines.Add(format('(X:%e,Y:%e)',[PT.X, PT.Y]));

// Удаляем второй элемент массива.

MPT.Delete( 1);

end;

Компилируем и нажимаем на форме соответствующую кнопочку, а затем получаем в ответ окошечко с примерно следующим текстом:

Сообщение об ошибке, возникающей при удалении элемента массива

После нескольких часов выстраивания всевозможных гипотез и работы с отладчиком и экспериментов с кодом модуля Generics.Collections обнаруживается место которое вызывает крах:

procedure TList<T>.DoDelete(Index: Integer; Notification: TCollectionNotification);

var

OldItem: T;

begin

if (Index < 0) or (Index >= Count) then

raise EArgumentOutOfRangeException.CreateRes(@sArgumentOutOfRange);

OldItem:=FItems[Index];

FItems[Index]:=Default(T); // Вот из-за этого все происходит!

Dec(FCount);

if Index <> Count then

begin

Move(FItems[Index + 1], FItems[Index], (Count - Index) * SizeOf(T));

FillChar(FItems[Count], SizeOf(T), 0);

end;

Notify(oldItem, Notification);

end;

Заметим, что для массивов с элементами простых типов все работает нормально. Похоже, производитель не тестировал модуль Generics.Collections со сложными типами данных такими как "расширенные" записи.

Вариант исправления был найден досточно быстро:

procedure TList<T>.DoDelete(Index: Integer; Notification: TCollectionNotification);

var

OldItem: T;

DefItem: T;

begin

if (Index < 0) or (Index >= Count) then

raise EArgumentOutOfRangeException.CreateRes(@sArgumentOutOfRange);

OldItem:=FItems[Index];

// Это ошибка?!

// FItems[Index]:=Default(T);

// Так поправил!

DefItem:=Default(T);

FItems[Index]:=DefItem;

//----------------

Dec(FCount);

if Index <> Count then

begin

Move(FItems[Index + 1], FItems[Index], (Count - Index) * SizeOf(T));

FillChar(FItems[Count], SizeOf(T), 0);

end;

Notify(oldItem, Notification);

end;

Тест стал проходить. Метод удаления элементов массива удалось получить.

Для дальнейшего нам необходимо определить метод позволяющий удалять элементы класса TMultiPointD2 по их значению. Т.е. нам необходим метод:

procedure Remove( const AValue: TPointD2);

Ясно, что для этого классу TMultiPointD2 должно быть известно как сравнивать элементы типа TPointD2. Для этого случая разработчики модулей Generics.Default и Generics.Collections предусмотрели специальный класс TComparer<T>, имеющий специальны виртуальный метод function Compare( const Left, Right: T): integer; который можно переписать и реализовать собственный алгоритм сравнения элементов конкретного класса массива.

IComparer<T> = interface

function Compare(const Left, Right: T): Integer;

end;

IEqualityComparer<T> = interface

function Equals(const Left, Right: T): Boolean;

function GetHashCode(const Value: T): Integer;

end;

TComparison<T> = reference to function(const Left, Right: T): Integer;

// Abstract base class for IComparer<T> implementations, and a provider

// of default IComparer<T> implementations.

TComparer<T> = class(TInterfacedObject, IComparer<T>)

public

class function Default: IComparer<T>;

class function Construct(const Comparison: TComparison<T>): IComparer<T>;

function Compare(const Left, Right: T): Integer; virtual; abstract;

end;

Определения интерфейсов и классов, для реализации операций сравнения массивов в модуле Generics.Default.

Определим необходимый для нас класс-компаратор TLinePointsComparer:

IComparerPoint = IComparer<TPointD2>;

TComparerPoint = class(TComparer<TPointD2>, IComparerPoint)

public

constructor Create;

end;

TLinePointsComparer = class(TComparerPoint)

public

function Compare( const Left, Right: TPointD2): integer; override;

end;

В самом названии, мы выбрали алгоритм упорядочения точек массива - строчный: PTA < PTB, если PTA.X < PTB.X, или если PTA.X = PTB.X и PTA.Y < PTB.Y. Точки считаются эквивалентными если PTA.X = PTB.X и PTA.Y = PTB.Y. Реализация этого алгоритма может быть следующей:

function TLinePointsComparer.Compare( const Left, Right: TPointD2): integer;

begin

if(Abs(Left.X-Right.X)<=MinSingle) then

begin

if(Abs(Left.Y-Right.Y)<=MinSingle) then

Exit( +0);

if(Left.Y < Right.Y) then

Exit( -1);

if(Left.Y > Right.Y) then

Exit( +1);

end;

if(Left.X < Right.X) then

Exit( -1);

Exit( +1);

end;

Какой еще шаг нам предстоит выполнить, чтобы мы добились желаемого?

Вернемся к определению класса TPointsD2. Обратим свое внимание на закомментированную строку в его определении:

// class function GetComparer: TComparerPoint; virtual;

Нам ее стоит теперь "вернуть к жизни" и написать ее реализацию:

class function GetComparer: TComparerPoint; virtual;

//.........................

class function TPointsD2.GetComparer: TComparerPoint;

begin

Result:=TLinePointsComparer.Create;

End;

Где же этот метод нужно использовать? Вспомним реализацию метода Empty класса TMultiPointD2 которую мы предлагали ранее.

procedure TMultiPointD2.Empty();

begin

Create( TPointsD2.Create( nil));

end;

Дело в том, что передаваемым параметром конструктора класса TPointsD2 как раз и является экземпляр класса-компаратора. Поэтому метод Empty можно переписать следующим образом:

procedure TMultiPointD2.Empty;

begin

Create( TPointsD2.Create( TLinePointsComparer.Create));

end;

или

procedure TMultiPointD2.Empty;

begin

Create( TPointsD2.Create( TPointsD2.GetComparer));

end;

Второй вариант нам может показаться более предпочтительным, поскольку предоставляет возможность дальнейшей параметризации класса TMultiPointD2.

После этого можно протестировать метод Remove с помощью следующей процедуры

procedure TForm1.tbTestDeleteClick( Sender: TObject);

var

MPT: TMultiPointD2<TPointsD2>;

PT: TPointD2;

begin

with PT do

begin

X:=0.1;

Y:=221.3;

end;

MPT.Add(PT);

for I:= 1 to 25 do

begin

with PT do

begin

X:=Random*100;

Y:=221.3*Random;

end;

MPT.Add(PT);

end;

for PT in MPT.Value do

Memo1.Lines.Add(format('(X:%e,Y:%e)',[PT.X, PT.Y]));

// Удаляем третий элемент массива.

MPT.Remove(MPT.Value[3]);

end;

Все работает.

Улучшение класса TMultiPointD2

Продолжим расширять возможности работы с нашим классом. Скажем, введем перегрузку основных операторов:

function Equals( AValue: TMultiPointD2): boolean;

function IsEmpty: boolean;

function Min: TPointD2; overload;

function Max: TPointD2; overload;

function Min( MPT: TMultiPointD2): TPointD2; overload;

function Max( MPT: TMultiPointD2): TPointD2; overload;

procedure Offset( const PT: TPointD2);

class operator Implicit( MPT: TPointsD2): TMultiPointD2;

class operator Implicit( MPT: TMultiPointD2): TPointsD2;

class operator Implicit( PT: TPointD2): TMultiPointD2;

class operator Add( MPT: TMultiPointD2; PT: TPointD2): TMultiPointD2; overload;

class operator Add( PT: TPointD2; MPT: TMultiPointD2): TMultiPointD2; overload;

class operator Add( MPTA, MPTB: TMultiPointD2): TMultiPointD2; overload;

class operator Subtract( MPT: TMultiPointD2; PT: TPointD2): TMultiPointD2; overload;

class operator Subtract( MPTA, MPTB: TMultiPointD2): TMultiPointD2; overload;

class operator Multiply( PT: TPointD2; MPT: TMultiPointD2): TPointD2; overload;

class operator Multiply( MPT: TMultiPointD2; PT: TPointD2): TPointD2; overload;

class operator Multiply( MPTA, MPTB: TMultiPointD2): TMultiPointD2; overload;

class operator LessThan( PT: TPointD2; MPT: TMultiPointD2): boolean; overload;

class operator GreaterThan( MPT: TMultiPointD2; PT: TPointD2): boolean; overload;

class operator LessThanOrEqual( PT: TPointD2; MPT: TMultiPointD2): boolean; overload;

class operator GreaterThanOrEqual( MPT: TMultiPointD2; PT: TPointD2): boolean; overload;

Описание введенных методов и операторов класса TMultiPointD2

Конструкция	Описание
function Equals( AValue: TMultiPointD2): boolean;	Инкапсулирует стандартный метод сравнение указателей на класс TPointD2.
function IsEmpty: boolean;	Метод проверяет является ли мультиточка "пустой".
function Min: TPointD2;	Вычисляет "минимальную" точку из текущей мультиточки.
function Max: TPointD2;	Вычисляет "максимальную" точку из текущей мультиточки
function Min( MPT: TMultiPointD2): TPointD2;	Вычисляет "минимальную" точку из текущей мультиточки и мультиточки MPT.
function Max( MPT: TMultiPointD2): TPointD2;	Вычисляет "максимальную" точку из текущей мультиточки и мультиточки MPT.
class operator Add( MPT: TMultiPointD2; PT: TPointD2): TMultiPointD2	Добавление к мультиточке MPT точки MP. Синтаксис: X:=MPT+PT.
class operator Add( PT: TPointD2; MPT: TMultiPointD2): TMultiPointD2; overload;	Добавление к мультиточке MPT точки MP. Синтаксис: X:=PT+MPT.
class operator Add( MPTA, MPTB: TMultiPointD2): TMultiPointD2	Соединение двух мультиточек MPTA и MPTB в указанном порядке. Синтаксис: X:=MPTA+MPTB.
class operator Subtract( MPT: TMultiPointD2; PT: TPointD2): TMultiPointD2;	Удаление из мультиточки MPT точки PT. Аналогично: X:=MPT-PT.
class operator Subtract( MPTA, MPTB: TMultiPointD2): TMultiPointD2;	Удаление из мультиточки MPTA мультиточки MPTB. Синтаксис: X:=MPTA-MPTB.
class operator Multiply( PT: TPointD2; MPT: TMultiPointD2): TPointD2;	Определение пересечения точки PT и мультиточки MPT. Если точки PT содержится в мультиточке MPT, то возвращается эта точка PT; иначе - возвращается пустая точка. Синтаксис: X:=PT*MPT.
class operator Multiply( MPT: TMultiPointD2; PT: TPointD2): TPointD2;	Аналогично предыдущему оператору. Добавлено для обеспечения симметричности оператора. Синтаксис: X:=MPT*PT.
class operator LessThan( PT: TPointD2; MPT: TMultiPointD2): boolean;	Метод проверяет принадлежность точки PT MPT. Синтаксис: B:=PT < MPT.
class operator GreaterThan( MPT: TMultiPointD2; PT: TPointD2): boolean;	Метод проверяет принадлежность точки PT MPT. Синтаксис: B:=MPT > PT.
class operator LessThanOrEqual( PT: TPointD2; MPT: TMultiPointD2): boolean;	Метод проверяет принадлежность точки PT MPT. Синтаксис: B:=PT <= MPT.
class operator GreaterThanOrEqual( MPT: TMultiPointD2; PT: TPointD2): boolean;	Метод проверяет принадлежность точки PT MPT. Синтаксис: B:=MPT >= PT.

Рассмотрим реализацию этих методов и операторов (см. следующую врезку).

function TMultiPointD2.Equals( AValue: TMultiPointD2): boolean;

begin

Result:=Value.Equals( AValue.Value);

end;

class operator TMultiPointD2.Implicit( MPT: TMultiPointD2): TPointsD2;

begin

Result:=MPT.Value;

end;

class operator TMultiPointD2.Implicit( MPT: TPointsD2): TMultiPointD2;

begin

Result:=TMultiPointD2.Create(MPT);

end;

class operator TMultiPointD2.Implicit( PT: TPointD2): TMultiPointD2;

begin

Result.Add( PT);

end;

function TMultiPointD2.IsEmpty: boolean;

begin

Result:=(Count = 0);

end;

function TMultiPointD2.Min: TPointD2;

var

PT: TPointD2;

begin

Result.Empty;

if(not IsEmpty) then

begin

Result:=Self[0];

for PT in Value do

Result:=Result.Min( PT);

end;

function TMultiPointD2.Min( const MPT: TMultiPointD2): TPointD2;

var

MPTA,

MPTB: TPointD2;

begin

MPTA:=Self.Min;

MPTB:=MPT.Min;

Result:=MPTA.Min( MPTB);

end;

function TMultiPointD2.Max: TPointD2;

var

PT: TPointD2;

begin

Result.Empty;

if(not IsEmpty) then

begin

Result:=Self[0];

for PT in Value do

Result:=Result.Max( PT);

end;

function TMultiPointD2.Max( const MPT: TMultiPointD2): TPointD2;

var

MPTA,

MPTB: TPointD2;

begin

MPTA:=Self.Max;

MPTB:=MPT.Max;

Result:=MPTA.Max( MPTB);

end;

class operator TMultiPointD2.LessThan( const PT: TPointD2; const MPT: TMultiPointD2): boolean;

begin

Result:=(MPT.Value.IndexOf( PT) > -1);

end;

class operator TMultiPointD2.LessThanOrEqual( const PT: TPointD2; const MPT: TMultiPointD2): boolean;

begin

Result:=(PT < MPT);

end;

class operator TMultiPointD2.GreaterThan( const MPT: TMultiPointD2; const PT: TPointD2): boolean;

begin

Result:=(PT < MPT);

end;

class operator TMultiPointD2.GreaterThanOrEqual(const MPT: TMultiPointD2; const PT: TPointD2): boolean;

begin

Result:=(PT <= MPT);

end;

function TMultiPointD2.Copy: TMultiPointD2;

begin

if(not Result.Equals( Self)) then

begin

Result.Clear;

Result.Add(Self);

end;

procedure TMultiPointD2.Add( const PT: TPointD2);

begin

if(not PT.IsEmpty) then

Value.Add( PT);

end;

procedure TMultiPointD2.Add( const AValue: TMultiPointD2);

begin

Value.AddRange( AValue.Value);

end;

function TMultiPointD2.GetCount: integer;

begin

Result:=Value.Count;

end;

class operator TMultiPointD2.Add( const MPT: TMultiPointD2; const PT: TPointD2): TMultiPointD2;

begin

if(not Result.Equals( MPT)) then // X:=A+PT

begin

Result.Clear;

Result.Value.AddRange(MPT);

end;

Result.Add(PT);

end;

class operator TMultiPointD2.Add( const PT: TPointD2; const MPT: TMultiPointD2): TMultiPointD2;

begin

if(not Result.Equals( MPT)) then // X:=PT+A;

Result.Clear;

Result.Value.Insert( 0, PT);

if(not Result.Equals( MPT)) then // not A:=PT+A;

Result.Value.AddRange(MPT);

end;

class operator TMultiPointD2.Add( const MPTA, MPTB: TMultiPointD2): TMultiPointD2;

begin

if(Result.Equals( MPTA)) then

begin

if(not Result.Equals( MPTB)) then // A:=A+B.

// Случай A:=A+A не обрабатывается! Это может привести к зацикливанию!

Result.Value.AddRange(MPTB)

end

else if(Result.Equals( MPTB)) then // B:=A+B.

Result.Value.InsertRange( 0, MPTA)

else

begin // X:=A+B.

Result.Clear;

Result.Value.AddRange(MPTA);

Result.Value.AddRange(MPTB);

end;

class operator TMultiPointD2.Subtract( const MPT: TMultiPointD2; const PT: TPointD2): TMultiPointD2;

begin

if(not Result.Equals( MPT)) then // X:=A-PT.

begin

Result.Clear;

Result.Value.AddRange( MPT);

end;

Result.Delete(PT); // X:=A-PT или A:=A-PT.

end;

class operator TMultiPointD2.Subtract( const MPTA, MPTB: TMultiPointD2): TMultiPointD2;

var

PT: TPointD2;

VP: TMultiPointD2;

begin

if(Result.Equals( MPTA)) then

begin

if(not Result.Equals( MPTB)) then // A:=A-B.

begin

for PT in MPTB.Value do

Result.Delete( PT);

end;

end

else if(Result.Equals( MPTB)) then // B:=A-B.

begin

VP:=MPTA.Copy();

VP:=VP - MPTB;

Result:=VP.Copy();

end

else

begin // X:=A-B.

Result:=MPTA.Copy();

for PT in MPTB.Value do

Result.Delete( PT);

end;

class operator TMultiPointD2.Multiply( const PT: TPointD2; const MPT: TMultiPointD2): TPointD2;

begin

Result.Empty;

if((not (PT.IsEmpty or MPT.IsEmpty)) and (PT < MPT)) then

Result:=PT;

end;

class operator TMultiPointD2.Multiply( const MPT: TMultiPointD2; const PT: TPointD2): TPointD2;

begin

Result:=PT*MPT;

end;

class operator TMultiPointD2.Multiply( const MPTA, MPTB: TMultiPointD2): TMultiPointD2;

var

PT: TPointD2;

begin

Result.Empty;

for PT in MPTA.Value do

Result.Add(PT*MPTB);

end;

Все просто замечательно. На этом можно было бы и закончить. Все хорошо - что хорошо заканчивается. Однако, как всегда жизнь преподносит нам и неприятные сюрпризы.

Казалось бы, материал, изложенный в этом разделе, имеет косвенное отношение к объявленной теме статьи. Украшательство - да и только… и т.д. и т.п. Автору самому не хотелось его излагать. Однако код, приведенный в текущем разделе, и параметризация классов в стиле generic связаны с решением одной проблемы, о которой я хотел бы рассказать в следующем разделе.

У всего, что мы до сих пор сделали, имеется одна неприметная, но серьезная проблема, о которой я упоминал выше. Она связана с тем, что при данном варианте реализации метода удаления по значению фактически мы можем использовать лишь один фиксированный способ сравнения (упорядочивания) элементов экземпляра класса TMultiPointD2 типа TPointD2. Нам необходимо каким-то образом добиться параметризации созданных классов относительно класса-компаратора. Иначе какие-либо достоинства использования "интеллектуальных указателей" с точки зрения автора статьи отсутствуют. Решению этой задачи будет посвящен следующий раздел нашей статьи.

Параметризация сравнения элементов

Для чего это нужно?

Предположим, что кроме класса "мультиточка" TMultiPointD2 нам необходимо реализовать класс "полигон" TPolygonD2 (который является 2-мерной областью, ограниченной несамопересекающейся ломанной, строго говоря, включая и саму границу). Другим отличием является отсутствие в полигоне эквивалентных точек - требуется уникальность элементов массива по содержанию. При этом нам необходимо реализовать его не собственно как класс, а в виде "интеллектуального указателя", с соответствующим набором методов и перегруженных операторов.

Таким образом, класс "полигон" TPolygonD2 представляет собой туже "мультиточку", но имеющую иной способ сортировки элементов (2-мерных точек). Этот способ сортировки предполагает, что элементы массива должны быть упорядочены по углу между вектором, направленным из центра полигона на указанную точку, и осью ординат по часовой стрелке, а также с учетом расстояния между центром полигона и указанной точкой: чем больше расстояние тем "больше" элемент при приблизительно одинаковом угле. Т.о., мы должны каким-то образом изменить в "интеллектуальном указателе" класс-компаратор, заданный по умолчанию, практически не изменяя остальную функциональность.

Для метода удаления такой проблемы нет. Метод удаления по значению использует лишь отношение эквивалентности двух элементов. Собственно, какая разница для метода удаления, какой класс-компаратор будет использован? Для него достаточно того, что реализация разных алгоритмов сравнения для отношения эквивалентности будет выдавать адекватный результат: два элемента (передаваемый образец и удаляемый элемент массива) эквивалентные (тождественные) при одном способе сравнения должны оставаться эквивалентными (тождественными) и при другом способе сравнения, с условием, что они имеют одинаковое содержимое - одинаковые значения. Строго формально это не так.

Надо сразу заметить, что эта проблема вытекает из реализации разработчиками модуля Generics.Collections метода передачи экземпляра класса-компаратора, используемого классом-контейнером TList<T> по умолчанию. Подменить его можно только на время проведения какой-либо специфической сортировки, снапример, с использованием перегруженного метода procedure Sort(const AComparer: IComparer<T>). Никаких других способов передачи компаратора в классе TList<T> нет. При других способах реализации класса-контейнера нам, возможно, не понадобилось бы проходить весь этот путь.

Данной проблемы для классов объектов мы можем избежать, используя наследование: переписав соответствующие методы для класса-наследника. Но в нашей задаче мы имеем дело с ограничением в реализации: мы хотим использовать расширенные структуры ("интеллектуальные указатели"), а они не поддерживают наследования.

Что же можно предложить? Во-первых, использование делегирования, в том числе с использованием с использованием анонимных методов. Во-вторых, использование параметризации класса TMultiPointD2 классами-компараторами или прикладными классами….

Делегирование

Идея данного решения проста: ввести в определение TMultiPointD2 классовую переменную (и связанное с ней свойство) типа ссылки на класс-компаратор и перед первым использованием данного "интеллектуального указателя" выполнить ее инициализацию.

Сделаем это как показано на следующих врезках:

Объявляем ссылки на классы-компараторы:

IComparerPoint = IComparer<TPointD2>;

TComparerPoint = class(TComparer<TPointD2>, IComparerPoint)

public

constructor Create;

end;

TClassComparerPoint = class of TComparerPoint;

TLinePointsComparer = class(TComparerPoint)

public

function Compare( const Left, Right: TPointD2): integer; override;

end;

TClassLinePointsComparer = class of TLinePointsComparer;

TPolygonPointsComparer = class(TComparerPoint)

public

function Compare( const Left, Right: TPointD2): integer; override;

end;

TClassPolygonPointsComparer = class of TPolygonPointsComparer;

Реализуем переписанный метод в классе наследнике

function TPolygonPointsComparer.Compare( const Left, Right: TPointD2): integer;

var

AL, AR: single;

DL, DR: single;

begin

AL:=Left.Angle;

AR:=Right.Angle;

if(Abs(AL-AR) <= MinSingle) then

begin

DL:=Left.Distance;

DR:=Right.Distance;

if(Abs(DL-DR) <= MinSingle) then

exit(+0);

if(DL < DR) then

exit(-1)

else

exit(+1);

end;

if(AL < AR) then

exit(-1);

exit(+1);

end;

Вводим необходимые классовые переменную и связанное с ней свойство:

TMultiPointD2 = record

strict private

//........................................

FValue: TPointsD2;

FFreeTheValue: IInterface;

FComparer: TClassComparerPoint;

//........................................

public

//........................................

property Comparer: TClassComparerPoint read FComparer write FComparer;

end;

Переопределяем метод Empty:

procedure TMultiPointD2.Empty;

begin

Create( TPointsD2.Create( FComparer.Create));

end;

Проверяем. Для этого нам необходимо реализовать следующую процедуру:

procedure TForm4.Button7Click(Sender: TObject);

var

I: integer;

MPTR: TMultiPointD2; // "мультиточка"

MPTP: TMultiPointD2; // "полигон".

PT: TPointD2;

PTB: TPointD2;

PTC: TPointD2;

begin

// Используем строчную сортировку.

MPTR.Comparer:=TLinePointsComparer;

// Используем "полигональную" сортировку.

MPTP.Comparer:=TPolygonPointsComparer;

for I:= 1 to 25 do

begin

PT.X:=100.0*Random;

PT.Y:=100.0*Random;

MPTR.Add( PT);

end;

MPTP:=MPTR.Copy;

Memo1.Lines.Add('До сортировки: мультиточка.');

for PT in MPTR.Value do

Memo1.Lines.Add(format('(X:%e, Y:%e)',[PT.X, PT.Y]));

Memo1.Lines.Add('До сортировки: полигон.');

for PT in MPTP.Value do

Memo1.Lines.Add(format('(X:%e, Y:%e)',[PT.X, PT.Y]));

//================================.

// Сортируем "мультиточку".

MPTR.Value.Sort;

//================================.

//Сортируем "полигон".

PTC:=MPTP.Center;

PTB:=PTC.Invert;

MPTP.Offset(PTB);

MPTP.Value.Sort;

MPTP.Offset(PTC);

//================================.

Memo1.Lines.Add(''После сортировки: мультиточка.');

for PT in MPTR.Value do

Memo1.Lines.Add(format('(X:%e, Y:%e)',[PT.X, PT.Y]));

Memo1.Lines.Add('После сортировки: полигон.');

for PT in MPTP.Value do

Memo1.Lines.Add(format('(X:%e, Y:%e)',[PT.X, PT.Y]));

end;

Результат работы процедуры можно посмотреть в следующей таблице:

Результаты вывода тестовой процедуры.

До сортировки
Мультиточка	Полигон
(X:2,328306E-008, Y:3,137994E+000)	(X:2,328306E-008, Y:3,137994E+000)
(X:8,610484E+001, Y:2,025809E+001)	(X:8,610484E+001, Y:2,025809E+001)
(X:2,729212E+001, Y:6,716544E+001)	(X:2,729212E+001, Y:6,716544E+001)
(X:3,186912E+001, Y:1,617954E+001)	(X:3,186912E+001, Y:1,617954E+001)
(X:3,722383E+001, Y:4,256737E+001)	(X:3,722383E+001, Y:4,256737E+001)
(X:8,201215E+000, Y:4,747940E+001)	(X:8,201215E+000, Y:4,747940E+001)
(X:7,056932E+000, Y:8,408544E+001)	(X:7,056932E+000, Y:8,408544E+001)
(X:5,972423E+000, Y:2,932965E+001)	(X:5,972423E+000, Y:2,932965E+001)
(X:9,172846E+001, Y:3,679064E+001)	(X:9,172846E+001, Y:3,679064E+001)
(X:7,746649E+001, Y:3,279255E+001)	(X:7,746649E+001, Y:3,279255E+001)
(X:6,976749E+001, Y:8,441709E+001)	(X:6,976749E+001, Y:8,441709E+001)
(X:7,179828E+001, Y:3,066413E+001)	(X:7,179828E+001, Y:3,066413E+001)
(X:1,626258E+001, Y:3,294964E+001)	(X:1,626258E+001, Y:3,294964E+001)
(X:4,660204E+001, Y:2,466536E+001)	(X:4,660204E+001, Y:2,466536E+001)
(X:8,256764E+001, Y:2,790294E+001)	(X:8,256764E+001, Y:2,790294E+001)
(X:4,817663E+001, Y:1,491849E+001)	(X:4,817663E+001, Y:1,491849E+001)
(X:8,743350E+001, Y:2,872941E+001)	(X:8,743350E+001, Y:2,872941E+001)
(X:7,727532E+001, Y:9,764598E+001)	(X:7,727532E+001, Y:9,764598E+001)
(X:4,925279E+001, Y:8,879360E+001)	(X:4,925279E+001, Y:8,879360E+001)
(X:8,272766E+001, Y:2,029689E+000)	(X:8,272766E+001, Y:2,029689E+000)
(X:1,410562E+001, Y:1,435042E+001)	(X:1,410562E+001, Y:1,435042E+001)
(X:5,008077E+001, Y:2,167585E+000)	(X:5,008077E+001, Y:2,167585E+000)
(X:5,929344E+001, Y:9,648999E-001)	(X:5,929344E+001, Y:9,648999E-001)
(X:7,744779E+001, Y:6,506576E+001)	(X:7,744779E+001, Y:6,506576E+001)
(X:7,704886E+001, Y:7,081069E+001)	(X:7,704886E+001, Y:7,081069E+001)
После сортировки
Мультиточка	Полигон
(X:2,328306E-008, Y:3,137994E+000)	(X:1,626258E+001, Y:3,294964E+001)
(X:5,972423E+000, Y:2,932965E+001)	(X:5,972423E+000, Y:2,932965E+001)
(X:7,056932E+000, Y:8,408544E+001)	(X:1,410562E+001, Y:1,435042E+001)
(X:8,201215E+000, Y:4,747940E+001)	(X:0,000000E+000, Y:3,137992E+000)
(X:1,410562E+001, Y:1,435042E+001)	(X:3,186912E+001, Y:1,617954E+001)
(X:1,626258E+001, Y:3,294964E+001)	(X:4,660204E+001, Y:2,466536E+001)
(X:2,729212E+001, Y:6,716544E+001)	(X:4,817663E+001, Y:1,491849E+001)
(X:3,186912E+001, Y:1,617954E+001)	(X:5,008077E+001, Y:2,167583E+000)
(X:3,722383E+001, Y:4,256737E+001)	(X:5,929344E+001, Y:9,649009E-001)
(X:4,660204E+001, Y:2,466536E+001)	(X:8,272766E+001, Y:2,029689E+000)
(X:4,817663E+001, Y:1,491849E+001)	(X:8,610484E+001, Y:2,025809E+001)
(X:4,925279E+001, Y:8,879360E+001)	(X:7,179828E+001, Y:3,066413E+001)
(X:5,008077E+001, Y:2,167585E+000)	(X:8,256764E+001, Y:2,790294E+001)
(X:5,929344E+001, Y:9,648999E-001)	(X:8,743350E+001, Y:2,872941E+001)
(X:6,976749E+001, Y:8,441709E+001)	(X:7,746649E+001, Y:3,279255E+001)
(X:7,179828E+001, Y:3,066413E+001)	(X:9,172846E+001, Y:3,679064E+001)
(X:7,704886E+001, Y:7,081069E+001)	(X:7,744779E+001, Y:6,506576E+001)
(X:7,727532E+001, Y:9,764598E+001)	(X:7,704886E+001, Y:7,081069E+001)
(X:7,744779E+001, Y:6,506576E+001)	(X:7,727532E+001, Y:9,764598E+001)
(X:7,746649E+001, Y:3,279255E+001)	(X:6,976749E+001, Y:8,441709E+001)
(X:8,256764E+001, Y:2,790294E+001)	(X:4,925279E+001, Y:8,879360E+001)
(X:8,272766E+001, Y:2,029689E+000)	(X:2,729212E+001, Y:6,716544E+001)
(X:8,610484E+001, Y:2,025809E+001)	(X:7,056934E+000, Y:8,408544E+001)
(X:8,743350E+001, Y:2,872941E+001)	(X:3,722383E+001, Y:4,256737E+001)
(X:9,172846E+001, Y:3,679064E+001)	(X:8,201213E+000, Y:4,747940E+001)

Сразу обратим внимание читателя на следующий момент: нам потребовалось изменить реализацию процедуры procedure TMultiPointD2.Offset( const PT: TPointD2) (см. следующую врезку).

procedure TMultiPointD2.Offset( const PT: TPointD2);

var

PTA,

PTB: TPointD2;

MPT: TMultiPointD2;

begin

MPT.Comparer:=Comparer; // необходимо ввести следующее присваивание!

for PTA in Value do

begin

PTB.X:=PTA.X+PT.X;

PTB.Y:=PTA.Y+PT.Y;

MPT.Add(PTB);

end;

Self.Clear;

Self.Add(MPT);

end;

Аналогичные вставки обязательно нужно сделать во всех методах, где используется внутренние переменные типа нашего "интеллектуального указателя".

Казалось бы, можно вместо этого просто изменить процедуру Empty:

procedure TMultiPointD2.Empty;

begin

if(not Assigned(FComparer)) then

FComparer:=TLinePointsComparer; // Компаратор по умолчанию!

Create( TPointsD2.Create( FComparer.Create));

end;

И это возможно наиболее правильное решение для данного варианта? Но оно не работает, поскольку FComparer может быть неинициализировано nil (и его негде инициализировать).

Решение может быть следующим:

procedure TMultiPointD2.Empty;

begin

if( FComparer <> Default(TClassComparerPoint)) then

FComparer:=TLinePointsComparer;

Create( TPointsD2.Create( FComparer.Create));

end;

Преимущества и недостатки этого варианта можно обсуждать еще очень долго...

Параметризация классами-компараторами

Главная идея этого варианта состоит в том, чтобы написать некоторый родительский класс, наследуемый скажем от TList<TPointD2>, определяющий основные методы и свойства его "семейства". А затем, параметризовать "интеллектуальный указатель" этого "семейства" на основе полученного таким образом базового класса. Посмотрим как это сделать.

1. Определяем базовый прикладной класс и его наследника, с минимальным набором методов

TPointsD2 = class(TList<TPointD2>)

public

// Некоторый псевдоконструктор.

function Empty: TPointsD2; virtual;

destructor Destroy; override;

function IsEmpty: boolean;

procedure Sort; virtual;

procedure Add( const Value: TPointD2); virtual;

procedure Offset( const PT: TPointD2); virtual;

function Center: TPointD2;

end;

TPolygonPointsD2 = class(TPointsD2)

public

function Empty: TPointsD2; override;

destructor Destroy; override;

procedure Sort; override;

procedure Add( const Value: TPointD2); override;

end;

2. Реализуем методы этих классов:

// TPointsD2.

function TPointsD2.Empty: TPointsD2;

begin

Result:=TPointsD2.Create( TLinePointsComparer.Create);

end;

function TPointsD2.IsEmpty: boolean;

begin

Result:=(Count = 0);

end;

destructor TPointsD2.Destroy;

begin

inherited Destroy;

end;

function TPointsD2.Center: TPointD2;

var

PT: TPointD2;

begin

Result.Empty;

if(not IsEmpty) then

begin

Result.X:=0.0;

Result.Y:=0.0;

for PT in Self do

begin

Result.X:=Result.X+PT.X;

Result.Y:=Result.Y+PT.Y;

end;

Result.X:=Result.X/Count;

Result.Y:=Result.Y/Count;

end;

procedure TPointsD2.Offset( const PT: TPointD2);

var

TPT: TPointD2;

begin

for TPT in Self do

begin

TPT.X:=TPT.X+PT.X;

TPT.Y:=TPT.Y+PT.Y;

end;

procedure TPointsD2.Sort;

begin

inherited Sort;

end;

procedure TPointsD2.Add( const Value: TPointD2);

begin

inherited Add( Value);

end;

//================================================================

// TPolygonPointsD2.

function TPolygonPointsD2.Empty: TPointsD2;

begin

Result:=TPointsD2.Create( TPolygonPointsComparer.Create);

end;

destructor TPolygonPointsD2.Destroy;

begin

inherited Destroy;

end;

procedure TPolygonPointsD2.Sort;

var

PTB: TPointD2;

PTC: TPointD2;

begin

PTC:=Center;

PTB:=PTC.Invert;

Offset( PTB);

inherited Sort;

Offset(PTC);

end;

procedure TPolygonPointsD2.Add( const Value: TPointD2);

begin

inherited Add( Value);

// Пересортируем после добавления!

Sort;

end;

3. Определяем "интеллектуальный указатель":

Объявление TMultiPointD2<TPoints: TPointsD2>

TMultiPointD2<TPoints: TPointsD2> = record

strict private

FValue: TPointsD2;

FFreeTheValue: IInterface;

function GetValue: TPointsD2;

private

type

TFreeTheValue = class (TInterfacedObject)

private

FObjectToFree: TObject;

public

constructor Create( AObjectToFree: TObject);

destructor Destroy; override;

end;

private

function GetCount: integer;

function GetPoint( const Index: integer): TPointD2;

procedure SetPoint( const Index: integer; const AValue: TPointD2);

public

constructor Create( AValue: TPointsD2); overload;

procedure Empty; overload;

function IsEmpty: boolean;

function Equals( AValue: TMultiPointD2<TPoints>): boolean;

procedure Clear;

procedure Add( const PT: TPointD2); overload;

procedure Add( const AValue: TMultiPointD2<TPoints>); overload;

function Copy: TMultiPointD2<TPoints>;

procedure Delete( const AValue: TPointD2);

procedure Remove( const AValue: TPointD2);

function Min: TPointD2; overload;

function Max: TPointD2; overload;

function Min( const MPT: TMultiPointD2<TPoints>): TPointD2; overload;

function Max( const MPT: TMultiPointD2<TPoints>): TPointD2; overload;

procedure Offset( const PT: TPointD2);

class operator Implicit( const MPT: TPointsD2): TMultiPointD2<TPoints>;

class operator Implicit( const MPT: TMultiPointD2<TPoints>): TPointsD2;

class operator Implicit( const PT: TPointD2): TMultiPointD2<TPoints>;

class operator Add( const MPT: TMultiPointD2<TPoints>; const PT: TPointD2): TMultiPointD2<TPoints>; overload;

class operator Add( const PT: TPointD2; const MPT: TMultiPointD2<TPoints>): TMultiPointD2<TPoints>; overload;

class operator Add( const MPTA, MPTB: TMultiPointD2<TPoints>): TMultiPointD2<TPoints>; overload;

class operator Subtract( const MPT: TMultiPointD2<TPoints>; const PT: TPointD2): TMultiPointD2<TPoints>; overload;

class operator Subtract( const MPTA, MPTB: TMultiPointD2<TPoints>): TMultiPointD2<TPoints>; overload;

class operator Multiply( const PT: TPointD2; const MPT: TMultiPointD2<TPoints>): TPointD2; overload;

class operator Multiply( const MPT: TMultiPointD2<TPoints>; const PT: TPointD2): TPointD2; overload;

class operator Multiply( const MPTA, MPTB: TMultiPointD2<TPoints>): TMultiPointD2<TPoints>; overload;

class operator LessThan( const PT: TPointD2; const MPT: TMultiPointD2<TPoints>): boolean; overload;

class operator GreaterThan( const MPT: TMultiPointD2<TPoints>; const PT: TPointD2): boolean; overload;

class operator LessThanOrEqual( const PT: TPointD2; const MPT: TMultiPointD2<TPoints>): boolean; overload;

class operator GreaterThanOrEqual( const MPT: TMultiPointD2<TPoints>; const PT: TPointD2): boolean; overload;

function Center: TPointD2;

property Value: TPointsD2 read GetValue;

property Count: integer read GetCount;

property Points[ const Index: integer]: TPointD2 read GetPoint write SetPoint; default;

property Comparer: TClassComparerPoint read FComparer write FComparer;

end;

4. Реализуем методы TMultiPointD2<TPoints: TPointsD2>:

Реализация методов TMultiPointD2<TPoints: TPointsD2>

constructor TMultiPointD2<TPoints>.Create( AValue: TPointsD2);

begin

FValue:=AValue;

FFreeTheValue:=TFreeTheValue.Create( FValue);

end;

procedure TMultiPointD2<TPoints>.Empty;

begin

Create( TPoints.Empty);

end;

function TMultiPointD2<TPoints>.IsEmpty: boolean;

begin

Result:=(Count = 0);

end;

function TMultiPointD2<TPoints>.Center: TPointD2;

var

PT: TPointD2;

begin

Result.Empty;

if(not IsEmpty) then

begin

Result.X:=0.0;

Result.Y:=0.0;

for PT in Value do

begin

Result.X:=Result.X+PT.X;

Result.Y:=Result.Y+PT.Y;

end;

Result.X:=Result.X/Count;

Result.Y:=Result.Y/Count;

end;

procedure TMultiPointD2<TPoints>.Clear;

begin

Value.Clear;

end;

function TMultiPointD2<TPoints>.GetValue: TPointsD2;

begin

if( not Assigned(FFreeTheValue)) then

Empty;

Result:=FValue;

end;

function TMultiPointD2<TPoints>.GetCount: integer;

begin

Result:=Value.Count;

end;

function TMultiPointD2<TPoints>.GetPoint( const Index: integer): TPointD2;

begin

Result:=Self.Value[ Index];

end;

procedure TMultiPointD2<TPoints>.SetPoint( const Index: integer; const AValue: TPointD2);

begin

Self.Value[ Index]:=AValue;

end;

function TMultiPointD2<TPoints>.Equals( AValue: TMultiPointD2<TPoints>): boolean;

begin

Result:=Value.Equals( AValue.Value);

end;

function TMultiPointD2<TPoints>.Min: TPointD2;

var

PT: TPointD2;

begin

Result.Empty;

if(not IsEmpty) then

begin

Result:=Self[0];

for PT in Value do

Result:=Result.Min( PT);

end;

function TMultiPointD2<TPoints>.Max: TPointD2;

var

PT: TPointD2;

begin

Result.Empty;

if(not IsEmpty) then

begin

Result:=Self[0];

for PT in Value do

Result:=Result.Max( PT);

end;

function TMultiPointD2<TPoints>.Min( const MPT: TMultiPointD2<TPoints>): TPointD2;

var

MPTA,

MPTB: TPointD2;

begin

MPTA:=Self.Min;

MPTB:=MPT.Min;

Result:=MPTA.Min( MPTB);

end;

function TMultiPointD2<TPoints>.Max( const MPT: TMultiPointD2<TPoints>): TPointD2;

var

MPTA,

MPTB: TPointD2;

begin

MPTA:=Max;

MPTB:=MPT.Max;

Result:=MPTA.Max( MPTB);

end;

class operator TMultiPointD2<TPoints>.Implicit( const MPT: TMultiPointD2<TPoints>): TPointsD2;

begin

Result:=MPT.Value;

end;

class operator TMultiPointD2<TPoints>.Implicit( const MPT: TPointsD2): TMultiPointD2<TPoints>;

begin

Result:=TMultiPointD2<TPoints>.Create(MPT);

end;

class operator TMultiPointD2<TPoints>.Implicit( const PT: TPointD2): TMultiPointD2<TPoints>;

begin

Result.Add( PT);

end;

class operator TMultiPointD2<TPoints>.LessThan( const PT: TPointD2; const MPT: TMultiPointD2<TPoints>): boolean;

begin

Result:=(MPT.Value.IndexOf( PT) > -1);

end;

class operator TMultiPointD2<TPoints>.LessThanOrEqual( const PT: TPointD2; const MPT: TMultiPointD2<TPoints>): boolean;

begin

Result:=(PT < MPT);

end;

class operator TMultiPointD2<TPoints>.GreaterThan( const MPT: TMultiPointD2<TPoints>; const PT: TPointD2): boolean;

begin

Result:=(PT < MPT);

end;

class operator TMultiPointD2<TPoints>.GreaterThanOrEqual( const MPT: TMultiPointD2<TPoints>; const PT: TPointD2): boolean;

begin

Result:=(PT <= MPT);

end;

function TMultiPointD2<TPoints>.Copy: TMultiPointD2<TPoints>;

begin

if(not Result.Equals( Self)) then

begin

Result.Clear;

Result.Add(Self);

end;

procedure TMultiPointD2<TPoints>.Add( const PT: TPointD2);

begin

if(not PT.IsEmpty) then

Value.Add( PT);

end;

procedure TMultiPointD2<TPoints>.Add( const AValue: TMultiPointD2<TPoints>);

begin

Value.AddRange( AValue.Value);

end;

class operator TMultiPointD2<TPoints>.Add( const MPT: TMultiPointD2<TPoints>; const PT: TPointD2): TMultiPointD2<TPoints>;

begin

if(not Result.Equals( MPT)) then // X:=A+PT

begin

Result.Clear;

Result.Add(MPT);

end;

Result.Add(PT);

end;

class operator TMultiPointD2<TPoints>.Add( const PT: TPointD2; const MPT: TMultiPointD2<TPoints>): TMultiPointD2<TPoints>;

begin

if(not Result.Equals( MPT)) then // X:=PT+A;

Result.Clear;

Result.Value.Insert( 0, PT);

if(not Result.Equals( MPT)) then // not A:=PT+A;

Result.Add(MPT);

end;

class operator TMultiPointD2<TPoints>.Add( const MPTA, MPTB: TMultiPointD2<TPoints>): TMultiPointD2<TPoints>;

begin

if(Result.Equals( MPTA)) then

begin

if(not Result.Equals( MPTB)) then // A:=A+B.

// Случай A:=A+A не обрабатывается! Это может привести к зацикливанию!

Result.Add(MPTB)

end

else if(Result.Equals( MPTB)) then // B:=A+B.

Result.Value.InsertRange( 0, MPTA.Value)

else

begin // X:=A+B.

Result.Clear;

Result.Add(MPTA);

Result.Add(MPTB);

end;

class operator TMultiPointD2<TPoints>.Subtract( const MPT: TMultiPointD2<TPoints>; const PT: TPointD2): TMultiPointD2<TPoints>;

begin

if(not Result.Equals( MPT)) then // X:=A-PT.

begin

Result.Clear;

Result.Add( MPT);

end;

Result.Delete(PT); // X:=A-PT или A:=A-PT.

end;

class operator TMultiPointD2<TPoints>.Subtract( const MPTA, MPTB: TMultiPointD2<TPoints>): TMultiPointD2<TPoints>;

var

PT: TPointD2;

VP: TMultiPointD2<TPoints>;

begin

if(Result.Equals( MPTA)) then

begin

if(not Result.Equals( MPTB)) then // A:=A-B.

begin

for PT in MPTB.Value do

Result.Delete( PT);

end;

end

else if(Result.Equals( MPTB)) then // B:=A-B.

begin

VP:=MPTA.Copy();

VP:=VP - MPTB;

Result:=VP.Copy();

end

else

begin // X:=A-B.

Result:=MPTA.Copy();

for PT in MPTB.Value do

Result.Delete( PT);

end;

class operator TMultiPointD2<TPoints>.Multiply( const PT: TPointD2; const MPT: TMultiPointD2<TPoints>): TPointD2;

begin

Result.Empty;

if((not (PT.IsEmpty or MPT.IsEmpty)) and (PT < MPT)) then

Result:=PT;

end;

class operator TMultiPointD2<TPoints>.Multiply( const MPT: TMultiPointD2<TPoints>; const PT: TPointD2): TPointD2;

begin

Result:=PT*MPT;

end;

class operator TMultiPointD2<TPoints>.Multiply( const MPTA, MPTB: TMultiPointD2<TPoints>): TMultiPointD2<TPoints>;

var

PT: TPointD2;

begin

Result.Empty;

if(not (MPTA.IsEmpty or MPTB.IsEmpty)) then

begin

for PT in MPTA.Value do

begin

if((not PT.IsEmpty) and (PT < MPTB)) then

Result.Add(PT);

end;

procedure TMultiPointD2<TPoints>.Delete( const AValue: TPointD2);

begin

Value.Remove( AValue);

end;

procedure TMultiPointD2<TPoints>.Remove( const AValue: TPointD2);

begin

Value.Remove( AValue);

end;

// TPointsD2.TFreeTheValue.

constructor TMultiPointD2<TPoints>.TFreeTheValue.Create( AObjectToFree: TObject);

begin

FObjectToFree:=AObjectToFree;

end;

destructor TMultiPointD2.TFreeTheValue.Destroy;

begin

FObjectToFree.Free;

inherited Destroy;

end;

Начинаем компилировать, и в ответ получаем следующие предупреждения об ошибках:

Сообщение об ошибке E2037 Declaration of "… " differs from previous declaration

Данная ошибка повторяется для реализации всех перегруженных операторов. Источник этой ошибки я так и не нашел. Хотя "лекарство" на нее нашлось: достаточно везде в списках параметров определений и реализаций перегруженных операторов убрать ключевое слово const как все данная ошибка исчезает. Но при этом мы получаем следующий список ошибок (см. Рисунок 4).

Решаем эту проблему прямыми подстановками кода перегруженных операторов. Например, код реализации

class operator TMultiPointD2<TPoints>.LessThanOrEqual( PT: TPointD2; MPT: TMultiPointD2<TPoints>): boolean;

begin

Result:=(PT < MPT);

end;

Сообщение об ошибке E2015 Operator not applicable to this operand type.

может быть заменен следующим кодом:

Пример исправления кода прегруженного оператора

class operator TMultiPointD2<TPoints>.LessThanOrEqual( PT: TPointD2; MPT: TMultiPointD2<TPoints>): boolean;

begin

Result:=(MPT.Value.IndexOf( PT) > -1);

end;

5. Пробуем снова компилировать. Получаем ошибку внутри кода тестовой процедуры:

Сообщение об ошибки при компиляции кода тестовой процедуры.

procedure TForm4.Button7Click(Sender: TObject);

var

I: integer;

MPTR: TMultiPointD2; // "мультиточка"

MPTP: TMultiPointD2; // "полигон".

PT: TPointD2;

PTB: TPointD2;

PTC: TPointD2;

begin

for I:= 1 to 25 do

begin

PT.X:=100.0*Random;

PT.Y:=100.0*Random;

MPTR.Add( PT);

end;

MPTP:=MPTR.Copy;

Memo1.Lines.Add('До сортировки: мультиточка.');

for PT in MPTR.Value do

Memo1.Lines.Add(format('(X:%e, Y:%e)',[PT.X, PT.Y]));

Memo1.Lines.Add('До сортировки: полигон.');

for PT in MPTP.Value do

Memo1.Lines.Add(format('(X:%e, Y:%e)',[PT.X, PT.Y]));

//================================.

// Сортируем "мультиточку".

MPTR.Value.Sort;

//================================.

//Сортируем "полигон".

MPTP.Value.Sort;

//================================.

Memo1.Lines.Add(''После сортировки: мультиточка.');

for PT in MPTR.Value do

Memo1.Lines.Add(format('(X:%e, Y:%e)',[PT.X, PT.Y]));

Memo1.Lines.Add('После сортировки: полигон.');

for PT in MPTP.Value do

Memo1.Lines.Add(format('(X:%e, Y:%e)',[PT.X, PT.Y]));

end;

Строка кода тестовой процедуры вызвавашая сообщение о синтаксической ошибке.

//........................................

MPTP:=MPTR.Copy;

//........................................

Ее можно разрешить, добавив в базовый прикладной класс метод Copy:

Код метода Copy.

procedure TPointsD2.Copy( AValue: TPointsD2);

var

PT: TPointD2;

begin

AValue.Clear;

for PT in Self do

AValue.Add( PT);

end;

Что приведет к следующему изменению кода тестовой процедуры:

Исправленная реализация вызова метода Copy.

//........................................

MPTR.Value.Copy( MPTP.Value);

//........................................

Все остальные правки тестового кода напрямую не затрагивают логику реорганизации "интеллектуального указателя" в соответствии с принятой идеологией. Надо заметить, что синтаксис перегруженных операторов оказывается доступным в тестовой программе.

Остается только удивляться и надеяться, что кто-то из заинтересовавшихся талантливых читателей поймет в чем дело и объяснит автору этих строк причину его мытарств! Кто укажет путь истинный?!… Автор после всего этого хочет лишь повторить многозначительное восклицание Кисы Воробьянинова: "Да-а-а-а…уж…". Стоит ли игра свеч????!

Заключение

Эту статью я хотел полностью посвятить применению так называемых smart pointers при написании программ в среде Delphi 2009. В целом, как мне кажется, это удалось.

Техника и приемы, которые носят название "smart pointers" конечно очень мощные и их применение позволило бы создавать гибкие и удобные для использования прикладными программистами библиотеки классов. Я надеюсь, что использование "smart pointers" не может быть ограничено использованием их в качестве некоторых временных хранилищ данных.

Однако, похоже, не бывает бочки меда без ложки дегтя. Это касается тех проблем, с которыми я столкнулся и которые описал в последнем разделе. Решат ли их разработчики Delphi - большой вопрос…

Литература

1. Cantu M. Delphi 2009. Handbook. pp. 171-176.

2. Cantu M. Delphi 2007. Handbook.

3. Kelly B. Smart pointers in Delphi. - http://blog.barrkel.com/2008/09/smart-pointers-in-delphi.html

Ссылки по теме

Smart pointers в Object Pascal Delphi 2009. В поисках решения

Вступление.