среда, 24 декабря 2014 г.

Коротко. "О языках"

По мотивам - Objective-C и Delphi

Несмотря на то, что "мне всё равно на чём программировать", скажу - на данный момент Objective-C++ - "мой кумир".

Почему?

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

Итак.

Об удачном.

От С++:

1. Объекты на стеке и как следствие - RAII.
2. Переопределение операторов.
3. Возможность использования STL.
4. Большое количество стандартных и открытых библиотек.
5. Лямбды.
6. Множественное наследование и как следствие - примеси.
7. Итераторы в стиле for (auto Element : Container).
8. Строгая типизация.
9. Шаблоны.

От Objective-C:

1. Подсчёт ссылок.
2. "Встроенная" сериализация.
3. NSProxy.
4. Мета-классы.
5. Протоколы.
6. Общий базовый предок для всех объектов.
7. NSOperation.
8. Категории.
9. try..finally.
10. NSDictionary.
11. Блоки (аналоги лямбд).
12. Duck-typing (оно же правда и минус).
13. Итераторы в стиле for (ElementType Element in Container).
14. Одиночное наследование и как следствие - "отсутствие бардака".

На стыке технологий:

1. Возможность положить объект C++ в объект Objective-C и как следствие - Holder'ы.
2. Возможность положить объект Objective-C в объект C++ и как следствие - Var'ы и динамические фабрики.

В итоге - C++ и Objective-C - это принципиально РАЗНЫЕ языки, со своими плюсами и минусами, а вот Objective-C++ это их удачная комбинация позволяющая комбинировать как плюсы, так и минусы.

Ну можно конечно "скомбинировать ОДНИ минусы" :-) Но тут уж как говориться - "каждый сам себе злобный буратина" :-)

Коротко. "Ни о чём". Какие "практики" я использую при написании кода

"практики" - какое заумное слово..

но...

что я использую

1. Наследование
2. Виртуальные функции
3. Лямбды (когда виртуальностью не обойдёшься)
4. Шаблон Publisher/Subscriber.
5. Параметризованные контейнеры (Generic'и или stl).
6. Интерфейсы.
7. Примеси (когда другим не обойдёшься)
8. Понимание того, что бизнес-логика НЕ ДОЛЖНА зависеть от GUI

по большому счёту- ВСЁ
никакой "высшей математики"
не..ну ещё...

9. Шаблон Декоратор

Это я к чему?

Просто к тому, что я тут пытался человека убедить, что "мой код простой как пробка".

Это код "ремесленника", который "знает три аккорда" и "лабает на них".

никакой "высшей математики"...

И да! Это не "повод для гордости".

Просто - делюсь.

Ну и:

10. Тесты. Просто тесты. "Всегда и везде".

вторник, 23 декабря 2014 г.

MindStream в движении. Развиваем "предметную область". Только код №4

По мотивам - MindStream в движении. Развиваем "предметную область". Только код №3

Делаем "подъём" от текущей диаграммы  к "предыдущей".

Главное это - ImsDiagrammsHolder.

Только код.

unit msInterfaces;

interface

uses
 System.Types,
 System.Classes,
 FMX.Graphics,
 System.UITypes,
 msSerializeInterfaces,
 Generics.Collections
 ;

type
 ImsShape = interface;

 ImsShapeByPt = interface
  function ShapeByPt(const aPoint: TPointF): ImsShape;
 end;//ImsShapeByPt

 ImsShapesController = interface(ImsShapeByPt)
  procedure RemoveShape(const aShape: ImsShape);
 end;//ImsShapesController
 // - тут бы иметь МНОЖЕСТВЕННОЕ наследование интерфейсов, но Delphi его не поддерживает
 // А вот с UML - мы его ПОТОМ СГЕНЕРИРУЕМ

 TmsDrawContext  = record
 // Контекст рисования.
 // "Лирика" - тут - http://habrahabr.ru/post/170125/
 // Ну и "связанное" - https://ru.wikipedia.org/wiki/%D0%A1%D1%82%D1%80%D0%B0%D1%82%D0%B5%D0%B3%D0%B8%D1%8F_(%D1%88%D0%B0%D0%B1%D0%BB%D0%BE%D0%BD_%D0%BF%D1%80%D0%BE%D0%B5%D0%BA%D1%82%D0%B8%D1%80%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F)
 //
 // Зачем же НАМ нужен "контекст"?
 //
 // Всё - БАНАЛЬНО. Чтобы НЕ ТРОГАТЬ сигнатуры методов. Мысль понятна?
  public
   rCanvas : TCanvas;
   rMoving : Boolean; // - определяем, что текущий рисуемый примитив - двигается
   constructor Create(const aCanvas : TCanvas);
 end;//TmsDrawContext

 ImsDiagrammsHolder = interface;

 TmsMakeShapeContext = record
  public
   rStartPoint: TPointF;
   rShapesController: ImsShapesController;
   rDiagrammsHolder: ImsDiagrammsHolder;
   constructor Create(aStartPoint: TPointF; const aShapesController: ImsShapesController; aDiagrammsHolder: ImsDiagrammsHolder);
 end;//TmsMakeShapeContext

 TmsEndShapeContext = TmsMakeShapeContext;

 TmsDrawOptionsContext = record
  public
   rFillColor: TAlphaColor;
   rStrokeDash: TStrokeDash;
   rStrokeColor: TAlphaColor;
   rStrokeThickness: Single;
   constructor Create(const aCtx: TmsDrawContext);
 end;//TmsDrawOptionsContext

 ImsDiagramm = interface;

 TmsDiagrammsEnumerator = TEnumerator;

 ImsShapesProvider = interface(ImsPersistent)
  procedure ShapesForToolbarToList(aList: TStrings);
 end;//ImsShapesProvider

 ImsDiagrammsList = interface(ImsShapesProvider)
  function GetEnumerator: TmsDiagrammsEnumerator;
  function IndexOf(const anItem: ImsDiagramm): Integer;
  function AddNewDiagramm: ImsDiagramm;
  procedure AddDiagramm(const aDiagramm: ImsDiagramm);
  function  SelectDiagramm(const aDiagrammName: String): ImsDiagramm;
  function FirstDiagramm: ImsDiagramm;
  procedure DiagrammsForToolbarToList(aList: TStrings);
  function pm_GetCount: Integer;
  property Count: Integer
   read pm_GetCount;
 end;//ImsDiagrammsList

 ImsShape = interface(ImsDiagrammsList)
 ['{70D5F6A0-1025-418B-959B-0CF524D8E394}']
  procedure DrawTo(const aCtx: TmsDrawContext);
  function IsNeedsSecondClick : Boolean;
  procedure EndTo(const aCtx: TmsEndShapeContext);
  function ContainsPt(const aPoint: TPointF): Boolean;
  procedure MoveTo(const aFinishPoint: TPointF);
  function pm_GetStartPoint: TPointF;
  property StartPoint: TPointF
   read pm_GetStartPoint;
 end;//ImsShape

 TmsShapesEnumerator = TEnumerator;

 ImsShapeCreator = interface
  function CreateShape(const aContext: TmsMakeShapeContext): ImsShape;
 end;//ImsShapeCreator

 ImsDiagrammsHolder = interface
  procedure UpToParent;
  // - сигнализируем о том, что нам надо перейти к РОДИТЕЛЬСКОЙ диаграмме
  procedure SwapParents;
  // - сигнализируем о том, что надо ПОМЕНЯТЬ местами РОДИТЕЛЬСКИЕ диаграммы
  function pm_GetCurrentDiagramms: ImsDiagrammsList;
  procedure pm_SetCurrentDiagramms(const aValue: ImsDiagrammsList);
  property CurrentDiagramms : ImsDiagrammsList
   read pm_GetCurrentDiagramms
   write pm_SetCurrentDiagramms;
 end;//ImsDiagrammsHolder

 TmsClickContext = record
  public
   rShapeCreator: ImsShapeCreator;
   rClickPoint: TPointF;
   rDiagrammsHolder : ImsDiagrammsHolder;
   constructor Create(const aShapeCreator: ImsShapeCreator; const aClickPoint: TPointF; const aDiagrammsHolder : ImsDiagrammsHolder);
 end;//TmsClickContext

 ImsDiagramm = interface(ImsShapesProvider)
 ['{59F2D068-F06F-4378-9ED4-888DFE8DFAF2}']
  function Get_Name: String;
  procedure Invalidate;
  procedure ProcessClick(const aClickContext: TmsClickContext);
  procedure Clear;
  procedure DrawTo(const aCanvas: TCanvas);
  function AddShape(const aShape: ImsShape): ImsShape;
  function GetEnumerator: TmsShapesEnumerator;
  function ItemsCount: Integer;
  property Name: String
   read Get_Name;
 end;//ImsDiagramm

 ImsDiagramms = interface(ImsDiagrammsList)
 ['{819BEEBA-97BB-48F1-906E-107E67706D19}']
  procedure Serialize;
  procedure DeSerialize;
 end;//ImsDiagramms

 ImsIvalidator = interface
  procedure InvalidateDiagramm(const aDiagramm: ImsDiagramm);
  procedure DiagrammAdded(const aDiagramms: ImsDiagrammsList; const aDiagramm: ImsDiagramm);
 end;//ImsIvalidator

 ImsDiagrammsController = interface
  procedure Clear;
  procedure DrawTo(const aCanvas: TCanvas);
 end;//ImsDiagrammsController

implementation

// TmsDrawContext

constructor TmsDrawContext.Create(const aCanvas : TCanvas);
begin
 rCanvas := aCanvas;
 rMoving := false;
end;

// TmsMakeShapeContext

constructor TmsMakeShapeContext.Create(aStartPoint: TPointF; const aShapesController: ImsShapesController; aDiagrammsHolder: ImsDiagrammsHolder);
begin
 rStartPoint := aStartPoint;
 rShapesController := aShapesController;
 rDiagrammsHolder := aDiagrammsHolder;
end;

// TmsDrawOptionsContext

constructor TmsDrawOptionsContext.Create(const aCtx: TmsDrawContext);
begin
 rFillColor :=  TAlphaColorRec.Null;
 if aCtx.rMoving then
 begin
  rStrokeDash := TStrokeDash.sdDashDot;
  rStrokeColor := TAlphaColors.Darkmagenta;
  rStrokeThickness := 4;
 end//aCtx.rMoving
 else
 begin
  rStrokeDash := TStrokeDash.sdSolid;
  rStrokeColor := TAlphaColorRec.Black;
  rStrokeThickness := 1;
 end;//aCtx.rMoving
end;

// TmsClickContext

constructor TmsClickContext.Create(const aShapeCreator: ImsShapeCreator; const aClickPoint: TPointF; const aDiagrammsHolder : ImsDiagrammsHolder);
begin
 rShapeCreator := aShapeCreator;
 rClickPoint := aClickPoint;
 rDiagrammsHolder := aDiagrammsHolder;
end;

end.

воскресенье, 21 декабря 2014 г.

суббота, 20 декабря 2014 г.

MindStream в движении. Развиваем "предметную область". Только код №3

По мотивам - MindStream в движении. Развиваем "предметную область". Только код №2

- ну что сказать? Мы ГОТОВИМСЯ к проваливанию ВНУТРЬ примитива. Для этого "подтачиваем" наши интерфейсы.

https://bitbucket.org/ingword/mindstream/src/6f0b5fa223241aa5a3ec2128e1048183264275fb/msInterfaces.pas?at=MS-7_Lulin_Upgrade

Только код.

unit msInterfaces;

interface

uses
 System.Types,
 System.Classes,
 FMX.Graphics,
 System.UITypes,
 msSerializeInterfaces,
 Generics.Collections
 ;

type
 ImsShape = interface;

 ImsShapeByPt = interface
  function ShapeByPt(const aPoint: TPointF): ImsShape;
 end;//ImsShapeByPt

 ImsShapesController = interface(ImsShapeByPt)
  procedure RemoveShape(const aShape: ImsShape);
 end;//ImsShapesController
 // - тут бы иметь МНОЖЕСТВЕННОЕ наследование интерфейсов, но Delphi его не поддерживает
 // А вот с UML - мы его ПОТОМ СГЕНЕРИРУЕМ

 TmsDrawContext  = record
 // Контекст рисования.
 // "Лирика" - тут - http://habrahabr.ru/post/170125/
 // Ну и "связанное" - https://ru.wikipedia.org/wiki/%D0%A1%D1%82%D1%80%D0%B0%D1%82%D0%B5%D0%B3%D0%B8%D1%8F_(%D1%88%D0%B0%D0%B1%D0%BB%D0%BE%D0%BD_%D0%BF%D1%80%D0%BE%D0%B5%D0%BA%D1%82%D0%B8%D1%80%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F)
 //
 // Зачем же НАМ нужен "контекст"?
 //
 // Всё - БАНАЛЬНО. Чтобы НЕ ТРОГАТЬ сигнатуры методов. Мысль понятна?
  public
   rCanvas : TCanvas;
   rMoving : Boolean; // - определяем, что текущий рисуемый примитив - двигается
   constructor Create(const aCanvas : TCanvas);
 end;//TmsDrawContext

 ImsDiagrammsHolder = interface;

 TmsMakeShapeContext = record
  public
   rStartPoint: TPointF;
   rShapesController: ImsShapesController;
   rDiagrammsHolder: ImsDiagrammsHolder;
   constructor Create(aStartPoint: TPointF; const aShapesController: ImsShapesController; aDiagrammsHolder: ImsDiagrammsHolder);
 end;//TmsMakeShapeContext

 TmsEndShapeContext = TmsMakeShapeContext;

 TmsDrawOptionsContext = record
  public
   rFillColor: TAlphaColor;
   rStrokeDash: TStrokeDash;
   rStrokeColor: TAlphaColor;
   rStrokeThickness: Single;
   constructor Create(const aCtx: TmsDrawContext);
 end;//TmsDrawOptionsContext

 ImsDiagramm = interface;

 TmsDiagrammsEnumerator = TEnumerator;

 ImsShapesProvider = interface(ImsPersistent)
  procedure ShapesForToolbarToList(aList: TStrings);
 end;//ImsShapesProvider

 ImsDiagrammsList = interface(ImsShapesProvider)
  function GetEnumerator: TmsDiagrammsEnumerator;
  function IndexOf(const anItem: ImsDiagramm): Integer;
  function AddNewDiagramm: ImsDiagramm;
  procedure AddDiagramm(const aDiagramm: ImsDiagramm);
  function  SelectDiagramm(const aDiagrammName: String): ImsDiagramm;
 end;//ImsDiagrammsList

 ImsShape = interface(ImsDiagrammsList)
 ['{70D5F6A0-1025-418B-959B-0CF524D8E394}']
  procedure DrawTo(const aCtx: TmsDrawContext);
  function IsNeedsSecondClick : Boolean;
  procedure EndTo(const aCtx: TmsEndShapeContext);
  function ContainsPt(const aPoint: TPointF): Boolean;
  procedure MoveTo(const aFinishPoint: TPointF);
  function pm_GetStartPoint: TPointF;
  property StartPoint: TPointF
   read pm_GetStartPoint;
 end;//ImsShape

 TmsShapesEnumerator = TEnumerator;

 ImsShapeCreator = interface
  function CreateShape(const aContext: TmsMakeShapeContext): ImsShape;
 end;//ImsShapeCreator

 ImsDiagrammsHolder = interface
  function pm_GetCurrentDiagramms: ImsDiagrammsList;
  procedure pm_SetCurrentDiagramms(const aValue: ImsDiagrammsList);
  property CurrentDiagramms : ImsDiagrammsList
   read pm_GetCurrentDiagramms
   write pm_SetCurrentDiagramms;
 end;//ImsDiagrammsHolder

 TmsClickContext = record
  public
   rShapeCreator: ImsShapeCreator;
   rClickPoint: TPointF;
   rDiagrammsHolder : ImsDiagrammsHolder;
   constructor Create(const aShapeCreator: ImsShapeCreator; const aClickPoint: TPointF; const aDiagrammsHolder : ImsDiagrammsHolder);
 end;//TmsClickContext

 ImsDiagramm = interface(ImsShapesProvider)
 ['{59F2D068-F06F-4378-9ED4-888DFE8DFAF2}']
  function Get_Name: String;
  procedure Invalidate;
  procedure ProcessClick(const aClickContext: TmsClickContext);
  procedure Clear;
  procedure DrawTo(const aCanvas: TCanvas);
  function AddShape(const aShape: ImsShape): ImsShape;
  function GetEnumerator: TmsShapesEnumerator;
  function ItemsCount: Integer;
  property Name: String
   read Get_Name;
 end;//ImsDiagramm

 ImsDiagramms = interface(ImsDiagrammsList)
 ['{819BEEBA-97BB-48F1-906E-107E67706D19}']
  procedure Serialize;
  procedure DeSerialize;
 end;//ImsDiagramms

 ImsIvalidator = interface
  procedure InvalidateDiagramm(const aDiagramm: ImsDiagramm);
  procedure DiagrammAdded(const aDiagramms: ImsDiagrammsList; const aDiagramm: ImsDiagramm);
 end;//ImsIvalidator

 ImsDiagrammsController = interface
  procedure Clear;
  procedure DrawTo(const aCanvas: TCanvas);
 end;//ImsDiagrammsController

implementation

// TmsDrawContext

constructor TmsDrawContext.Create(const aCanvas : TCanvas);
begin
 rCanvas := aCanvas;
 rMoving := false;
end;

// TmsMakeShapeContext

constructor TmsMakeShapeContext.Create(aStartPoint: TPointF; const aShapesController: ImsShapesController; aDiagrammsHolder: ImsDiagrammsHolder);
begin
 rStartPoint := aStartPoint;
 rShapesController := aShapesController;
 rDiagrammsHolder := aDiagrammsHolder;
end;

// TmsDrawOptionsContext

constructor TmsDrawOptionsContext.Create(const aCtx: TmsDrawContext);
begin
 rFillColor :=  TAlphaColorRec.Null;
 if aCtx.rMoving then
 begin
  rStrokeDash := TStrokeDash.sdDashDot;
  rStrokeColor := TAlphaColors.Darkmagenta;
  rStrokeThickness := 4;
 end//aCtx.rMoving
 else
 begin
  rStrokeDash := TStrokeDash.sdSolid;
  rStrokeColor := TAlphaColorRec.Black;
  rStrokeThickness := 1;
 end;//aCtx.rMoving
end;

// TmsClickContext

constructor TmsClickContext.Create(const aShapeCreator: ImsShapeCreator; const aClickPoint: TPointF; const aDiagrammsHolder : ImsDiagrammsHolder);
begin
 rShapeCreator := aShapeCreator;
 rClickPoint := aClickPoint;
 rDiagrammsHolder := aDiagrammsHolder;
end;

end.

MindStream в движении. Развиваем "предметную область". Только код №2

По мотивам - MindStream в движении. Развиваем "предметную область". Только код

Оказалось, что TmsDiagrammsController - ПАДАЕТ в результате предыдущих коммитов.

ПОЧЕМУ?

Объяснять - НЕ БУДУ.

Намекну - "из-за ImsDiagrammsHolder".

"используем ImsDiagrammsController, а НЕ TmsDiagrammsController. Embarcadero нас к этому ТОЛКАЕТ."

https://bitbucket.org/ingword/mindstream/src/fd5306a0575a10f8a8bf10bedeca955af9788caa/msInterfaces.pas?at=MS-7_Lulin_Upgrade

Только код.

unit msInterfaces;

interface

uses
 System.Types,
 System.Classes,
 FMX.Graphics,
 System.UITypes,
 msSerializeInterfaces,
 Generics.Collections
 ;

type
 ImsShape = interface;

 ImsShapeByPt = interface
  function ShapeByPt(const aPoint: TPointF): ImsShape;
 end;//ImsShapeByPt

 ImsShapesController = interface(ImsShapeByPt)
  procedure RemoveShape(const aShape: ImsShape);
 end;//ImsShapesController
 // - тут бы иметь МНОЖЕСТВЕННОЕ наследование интерфейсов, но Delphi его не поддерживает
 // А вот с UML - мы его ПОТОМ СГЕНЕРИРУЕМ

 TmsDrawContext  = record
 // Контекст рисования.
 // "Лирика" - тут - http://habrahabr.ru/post/170125/
 // Ну и "связанное" - https://ru.wikipedia.org/wiki/%D0%A1%D1%82%D1%80%D0%B0%D1%82%D0%B5%D0%B3%D0%B8%D1%8F_(%D1%88%D0%B0%D0%B1%D0%BB%D0%BE%D0%BD_%D0%BF%D1%80%D0%BE%D0%B5%D0%BA%D1%82%D0%B8%D1%80%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F)
 //
 // Зачем же НАМ нужен "контекст"?
 //
 // Всё - БАНАЛЬНО. Чтобы НЕ ТРОГАТЬ сигнатуры методов. Мысль понятна?
  public
   rCanvas : TCanvas;
   rMoving : Boolean; // - определяем, что текущий рисуемый примитив - двигается
   constructor Create(const aCanvas : TCanvas);
 end;//TmsDrawContext

 TmsMakeShapeContext = record
  public
   rStartPoint: TPointF;
   rShapesController: ImsShapesController;
   constructor Create(aStartPoint: TPointF; const aShapesController: ImsShapesController);
 end;//TmsMakeShapeContext

 TmsEndShapeContext = TmsMakeShapeContext;

 TmsDrawOptionsContext = record
  public
   rFillColor: TAlphaColor;
   rStrokeDash: TStrokeDash;
   rStrokeColor: TAlphaColor;
   rStrokeThickness: Single;
   constructor Create(const aCtx: TmsDrawContext);
 end;//TmsDrawOptionsContext

 ImsDiagramm = interface;

 TmsDiagrammsEnumerator = TEnumerator;

 ImsShapesProvider = interface(ImsPersistent)
  procedure ShapesForToolbarToList(aList: TStrings);
 end;//ImsShapesProvider

 ImsDiagrammsList = interface(ImsShapesProvider)
  function GetEnumerator: TmsDiagrammsEnumerator;
  function IndexOf(const anItem: ImsDiagramm): Integer;
  function AddNewDiagramm: ImsDiagramm;
  procedure AddDiagramm(const aDiagramm: ImsDiagramm);
  function  SelectDiagramm(const aDiagrammName: String): ImsDiagramm;
 end;//ImsDiagrammsList

 ImsShape = interface(ImsDiagrammsList)
 ['{70D5F6A0-1025-418B-959B-0CF524D8E394}']
  procedure DrawTo(const aCtx: TmsDrawContext);
  function IsNeedsSecondClick : Boolean;
  procedure EndTo(const aCtx: TmsEndShapeContext);
  function ContainsPt(const aPoint: TPointF): Boolean;
  procedure MoveTo(const aFinishPoint: TPointF);
  function pm_GetStartPoint: TPointF;
  property StartPoint: TPointF
   read pm_GetStartPoint;
 end;//ImsShape

 TmsShapesEnumerator = TEnumerator;

 ImsShapeCreator = interface
  function CreateShape(const aContext: TmsMakeShapeContext): ImsShape;
 end;//ImsShapeCreator

 ImsDiagrammsHolder = interface
  function pm_GetCurrentDiagramms: ImsDiagrammsList;
  procedure pm_SetCurrentDiagramms(const aValue: ImsDiagrammsList);
  property CurrentDiagramms : ImsDiagrammsList
   read pm_GetCurrentDiagramms
   write pm_SetCurrentDiagramms;
 end;//ImsDiagrammsHolder

 TmsClickContext = record
  public
   rShapeCreator: ImsShapeCreator;
   rClickPoint: TPointF;
   rDiagrammsHolder : ImsDiagrammsHolder;
   constructor Create(const aShapeCreator: ImsShapeCreator; const aClickPoint: TPointF; const aDiagrammsHolder : ImsDiagrammsHolder);
 end;//TmsClickContext

 ImsDiagramm = interface(ImsShapesProvider)
 ['{59F2D068-F06F-4378-9ED4-888DFE8DFAF2}']
  function Get_Name: String;
  procedure Invalidate;
  procedure ProcessClick(const aClickContext: TmsClickContext);
  procedure Clear;
  procedure DrawTo(const aCanvas: TCanvas);
  function AddShape(const aShape: ImsShape): ImsShape;
  function GetEnumerator: TmsShapesEnumerator;
  function ItemsCount: Integer;
  property Name: String
   read Get_Name;
 end;//ImsDiagramm

 ImsDiagramms = interface(ImsDiagrammsList)
 ['{819BEEBA-97BB-48F1-906E-107E67706D19}']
  procedure Serialize;
  procedure DeSerialize;
 end;//ImsDiagramms

 ImsIvalidator = interface
  procedure InvalidateDiagramm(const aDiagramm: ImsDiagramm);
  procedure DiagrammAdded(const aDiagramms: ImsDiagrammsList; const aDiagramm: ImsDiagramm);
 end;//ImsIvalidator

 ImsDiagrammsController = interface
  procedure Clear;
  procedure DrawTo(const aCanvas: TCanvas);
 end;//ImsDiagrammsController

implementation

// TmsDrawContext

constructor TmsDrawContext.Create(const aCanvas : TCanvas);
begin
 rCanvas := aCanvas;
 rMoving := false;
end;

// TmsMakeShapeContext

constructor TmsMakeShapeContext.Create(aStartPoint: TPointF; const aShapesController: ImsShapesController);
begin
 rStartPoint := aStartPoint;
 rShapesController := aShapesController;
end;

// TmsDrawOptionsContext

constructor TmsDrawOptionsContext.Create(const aCtx: TmsDrawContext);
begin
 rFillColor :=  TAlphaColorRec.Null;
 if aCtx.rMoving then
 begin
  rStrokeDash := TStrokeDash.sdDashDot;
  rStrokeColor := TAlphaColors.Darkmagenta;
  rStrokeThickness := 4;
 end//aCtx.rMoving
 else
 begin
  rStrokeDash := TStrokeDash.sdSolid;
  rStrokeColor := TAlphaColorRec.Black;
  rStrokeThickness := 1;
 end;//aCtx.rMoving
end;

// TmsClickContext

constructor TmsClickContext.Create(const aShapeCreator: ImsShapeCreator; const aClickPoint: TPointF; const aDiagrammsHolder : ImsDiagrammsHolder);
begin
 rShapeCreator := aShapeCreator;
 rClickPoint := aClickPoint;
 rDiagrammsHolder := aDiagrammsHolder;
end;

end.

...

unit msDiagrammsController;

interface

uses
 {$Include msIvalidator.mixin.pas}
 ,
 FMX.Objects,
 FMX.ListBox,
 FMX.StdCtrls,
 FMX.Graphics,
 msDiagramms,
 System.Types,
 FMX.Forms,
 System.Classes,
 System.UITypes,
 msCoreObjects,
 msInterfacedRefcounted,
 msShape,
 msInterfaces
 ;

type
 TmsIvalidatorParent = TmsInterfacedRefcounted;
 {$Include msIvalidator.mixin.pas}
 TmsDiagrammsController = class(TmsIvalidator, ImsDiagrammsController)
 private
  imgMain: TPaintBox;
  cbShapes: TComboBox;
  cbDiagramm: TComboBox;
  btAddDiagramm: TButton;
  btSaveDiagramm: TButton;
  btLoadDiagramm: TButton;
  f_DiagrammsRoot: ImsDiagramms;
  f_CurrentDiagramms : ImsDiagrammsList;
  f_CurrentDiagramm : ImsDiagramm;
  procedure cbDiagrammChange(Sender: TObject);
  procedure btAddDiagrammClick(Sender: TObject);
  procedure imgMainMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
  procedure btSaveDiagrammClick(Sender: TObject);
  procedure btLoadDiagrammClick(Sender: TObject);
  function pm_GetCurrentDiagramm: ImsDiagramm;
  procedure pm_SetCurrentDiagramm(const aValue: ImsDiagramm);
  function pm_GetCurrentDiagramms: ImsDiagrammsList;
  procedure pm_SetCurrentDiagramms(const aValue: ImsDiagrammsList);
 protected
  procedure DoInvalidateDiagramm(const aDiagramm: ImsDiagramm); override;
  procedure DoDiagrammAdded(const aDiagramms: ImsDiagrammsList; const aDiagramm: ImsDiagramm); override;
  property CurrentDiagramms : ImsDiagrammsList
   read pm_GetCurrentDiagramms
   write pm_SetCurrentDiagramms;
 public
  constructor Create(aImage: TPaintBox; aShapes: TComboBox; aDiagramm: TComboBox; aAddDiagramm: TButton; aSaveDiagramm: TButton; aLoadDiagramm: TButton);
  destructor Destroy; override;
  procedure Clear;
  procedure ProcessClick(const aStart: TPointF);
  property CurrentDiagramm: ImsDiagramm
   read pm_GetCurrentDiagramm
   write pm_SetCurrentDiagramm;
  procedure DrawTo(const aCanvas: TCanvas);
 end;//TmsDiagrammsController

implementation

uses
 {$Include msIvalidator.mixin.pas}
 ,
 System.SysUtils,
 FMX.Types,
 msShapesForToolbar,
 Math,
 msShapeCreator
 ;

type
 TmsDiagrammsHolder = class(TmsInterfacedRefcounted, ImsDiagrammsHolder)
 private
  f_DiagrammsController : TmsDiagrammsController;
  constructor CreatePrim(aDiagrammsController : TmsDiagrammsController);
 protected
  function pm_GetCurrentDiagramms: ImsDiagrammsList;
  procedure pm_SetCurrentDiagramms(const aValue: ImsDiagrammsList);
 public
  class function Create(aDiagrammsController : TmsDiagrammsController): ImsDiagrammsHolder;
 end;//TmsDiagrammsHolder

constructor TmsDiagrammsHolder.CreatePrim(aDiagrammsController : TmsDiagrammsController);
begin
 inherited Create;
 f_DiagrammsController := aDiagrammsController;
end;

class function TmsDiagrammsHolder.Create(aDiagrammsController : TmsDiagrammsController): ImsDiagrammsHolder;
begin
 Result := CreatePrim(aDiagrammsController);
end;

function TmsDiagrammsHolder.pm_GetCurrentDiagramms: ImsDiagrammsList;
begin
 Result := f_DiagrammsController.CurrentDiagramms;
end;

procedure TmsDiagrammsHolder.pm_SetCurrentDiagramms(const aValue: ImsDiagrammsList);
begin
 f_DiagrammsController.CurrentDiagramms := aValue;
end;

{$Include msIvalidator.mixin.pas}

// TmsDiagrammsController

constructor TmsDiagrammsController.Create(aImage: TPaintBox;
                                          aShapes: TComboBox;
                                          aDiagramm: TComboBox;
                                          aAddDiagramm: TButton;
                                          aSaveDiagramm: TButton;
                                          aLoadDiagramm: TButton);
begin
 inherited Create;
 imgMain := aImage;
 cbShapes := aShapes;
 cbDiagramm := aDiagramm;
 btAddDiagramm := aAddDiagramm;
 btSaveDiagramm := aSaveDiagramm;
 btLoadDiagramm := aLoadDiagramm;
 cbDiagramm.OnChange := cbDiagrammChange;
 btAddDiagramm.OnClick := btAddDiagrammClick;
 btSaveDiagramm.OnClick := btSaveDiagrammClick;
 btLoadDiagramm.OnClick := btLoadDiagrammClick;
 imgMain.OnMouseDown := imgMainMouseDown;
 imgMain.Align := TAlignLayout.alClient;
 f_DiagrammsRoot := TmsDiagramms.Create;
 CurrentDiagramms := f_DiagrammsRoot;
 CurrentDiagramms.AddNewDiagramm;
end;

procedure TmsDiagrammsController.DoInvalidateDiagramm(const aDiagramm: ImsDiagramm);
begin
 if (imgMain <> nil) then
  if (aDiagramm.EQ(CurrentDiagramm)) then
   imgMain.Repaint;
end;

function TmsDiagrammsController.pm_GetCurrentDiagramm: ImsDiagramm;
begin
 Result := f_CurrentDiagramm;
end;

procedure TmsDiagrammsController.pm_SetCurrentDiagramm(const aValue: ImsDiagramm);
begin
 if not aValue.EQ(f_CurrentDiagramm) then
 begin
  f_CurrentDiagramm := aValue;
  cbDiagramm.ItemIndex := cbDiagramm.Items.IndexOf(aValue.Name);
  f_CurrentDiagramm.Invalidate;
 end;//not aValue.EQ(f_CurrentDiagramm)
end;

function TmsDiagrammsController.pm_GetCurrentDiagramms: ImsDiagrammsList;
begin
 Result := f_CurrentDiagramms;
end;

procedure TmsDiagrammsController.pm_SetCurrentDiagramms(const aValue: ImsDiagrammsList);
var
 l_Index : Integer;
begin
 if (f_CurrentDiagramms <> aValue) then
 begin
  f_CurrentDiagramms := aValue;
  l_Index := cbShapes.ItemIndex;
  cbShapes.Items.Clear;
  if (f_CurrentDiagramms <> nil) then
  begin
   f_CurrentDiagramms.ShapesForToolbarToList(cbShapes.Items);
   if (l_Index < 0) then
    if (cbShapes.Count > 0) then
     l_Index := 0;
   cbShapes.ItemIndex := Min(cbShapes.Count-1, l_Index);
  end;//f_CurrentDiagramms <> nil
 end;//f_CurrentDiagramms <> aValue
end;

procedure TmsDiagrammsController.btLoadDiagrammClick(Sender: TObject);
var
 l_D : ImsDiagramm;
 l_I : Integer;
begin
 l_I := cbDiagramm.ItemIndex;
 f_DiagrammsRoot.DeSerialize;
 cbDiagramm.Clear;
 Assert(f_DiagrammsRoot.EQ(CurrentDiagramms));
 for l_D in f_DiagrammsRoot do
  cbDiagramm.Items.Add(l_D.Name);
 cbDiagramm.ItemIndex := l_I;
end;

procedure TmsDiagrammsController.btSaveDiagrammClick(Sender: TObject);
begin
 f_DiagrammsRoot.Serialize;
end;

procedure TmsDiagrammsController.cbDiagrammChange(Sender: TObject);
begin
 CurrentDiagramm := CurrentDiagramms.SelectDiagramm(cbDiagramm.Items[cbDiagramm.ItemIndex]);
 CurrentDiagramm.Invalidate;
end;

procedure TmsDiagrammsController.btAddDiagrammClick(Sender: TObject);
begin
 CurrentDiagramms.AddNewDiagramm;
end;

destructor TmsDiagrammsController.Destroy;
begin
 f_CurrentDiagramm := nil;
 CurrentDiagramms := nil;
 f_DiagrammsRoot := nil;
 inherited;
end;

procedure TmsDiagrammsController.Clear;
begin
 CurrentDiagramm.Clear;
end;

procedure TmsDiagrammsController.ProcessClick(const aStart: TPointF);
begin
 CurrentDiagramm.ProcessClick(TmsClickContext.Create(TmsShapeCreator.Create(TmsShapesForToolbar.Instance.Items[cbShapes.ItemIndex]), aStart, TmsDiagrammsHolder.Create(Self)));
end;

procedure TmsDiagrammsController.DrawTo(const aCanvas: TCanvas);
begin
 CurrentDiagramm.DrawTo(aCanvas);
end;

procedure TmsDiagrammsController.imgMainMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
 Self.ProcessClick(TPointF.Create(X, Y));
end;

procedure TmsDiagrammsController.DoDiagrammAdded(const aDiagramms: ImsDiagrammsList; const aDiagramm: ImsDiagramm);
begin
 Assert(CurrentDiagramms <> nil);
 if not CurrentDiagramms.EQ(aDiagramms) then
  Exit;
 if (CurrentDiagramms <> nil) then
 begin
  if (CurrentDiagramms.IndexOf(aDiagramm) >= 0) then
  begin
   cbDiagramm.Items.Add(aDiagramm.Name);
   CurrentDiagramm := aDiagramm;
  end;//CurrentDiagramms.IndexOf(aDiagramm) >= 0
 end;//CurrentDiagramms <> nil
end;

end.

А вообще на Borland и Embarcadero - "у меня давно зуб".

MindStream в движении. Развиваем "предметную область". Только код

https://bitbucket.org/ingword/mindstream/src/d40b6c43974ba6ddeec818919d298418f953b409/msInterfaces.pas?at=MS-7_Lulin_Upgrade

unit msInterfaces;

interface

uses
 System.Types,
 System.Classes,
 FMX.Graphics,
 System.UITypes,
 msSerializeInterfaces,
 Generics.Collections
 ;

type
 ImsShape = interface;

 ImsShapeByPt = interface
  function ShapeByPt(const aPoint: TPointF): ImsShape;
 end;//ImsShapeByPt

 ImsShapesController = interface(ImsShapeByPt)
  procedure RemoveShape(const aShape: ImsShape);
 end;//ImsShapesController
 // - тут бы иметь МНОЖЕСТВЕННОЕ наследование интерфейсов, но Delphi его не поддерживает
 // А вот с UML - мы его ПОТОМ СГЕНЕРИРУЕМ

 TmsDrawContext  = record
 // Контекст рисования.
 // "Лирика" - тут - http://habrahabr.ru/post/170125/
 // Ну и "связанное" - https://ru.wikipedia.org/wiki/%D0%A1%D1%82%D1%80%D0%B0%D1%82%D0%B5%D0%B3%D0%B8%D1%8F_(%D1%88%D0%B0%D0%B1%D0%BB%D0%BE%D0%BD_%D0%BF%D1%80%D0%BE%D0%B5%D0%BA%D1%82%D0%B8%D1%80%D0%BE%D0%B2%D0%B0%D0%BD%D0%B8%D1%8F)
 //
 // Зачем же НАМ нужен "контекст"?
 //
 // Всё - БАНАЛЬНО. Чтобы НЕ ТРОГАТЬ сигнатуры методов. Мысль понятна?
  public
   rCanvas : TCanvas;
   rMoving : Boolean; // - определяем, что текущий рисуемый примитив - двигается
   constructor Create(const aCanvas : TCanvas);
 end;//TmsDrawContext

 TmsMakeShapeContext = record
  public
   rStartPoint: TPointF;
   rShapesController: ImsShapesController;
   constructor Create(aStartPoint: TPointF; const aShapesController: ImsShapesController);
 end;//TmsMakeShapeContext

 TmsEndShapeContext = TmsMakeShapeContext;

 TmsDrawOptionsContext = record
  public
   rFillColor: TAlphaColor;
   rStrokeDash: TStrokeDash;
   rStrokeColor: TAlphaColor;
   rStrokeThickness: Single;
   constructor Create(const aCtx: TmsDrawContext);
 end;//TmsDrawOptionsContext

 ImsDiagramm = interface;

 TmsDiagrammsEnumerator = TEnumerator;

 ImsShapesProvider = interface(ImsPersistent)
  procedure ShapesForToolbarToList(aList: TStrings);
 end;//ImsShapesProvider

 ImsDiagrammsList = interface(ImsShapesProvider)
  function GetEnumerator: TmsDiagrammsEnumerator;
  function IndexOf(const anItem: ImsDiagramm): Integer;
  function AddNewDiagramm: ImsDiagramm;
  procedure AddDiagramm(const aDiagramm: ImsDiagramm);
 end;//ImsDiagrammsList

 ImsShape = interface(ImsDiagrammsList)
 ['{70D5F6A0-1025-418B-959B-0CF524D8E394}']
  procedure DrawTo(const aCtx: TmsDrawContext);
  function IsNeedsSecondClick : Boolean;
  procedure EndTo(const aCtx: TmsEndShapeContext);
  function ContainsPt(const aPoint: TPointF): Boolean;
  procedure MoveTo(const aFinishPoint: TPointF);
  function pm_GetStartPoint: TPointF;
  property StartPoint: TPointF
   read pm_GetStartPoint;
 end;//ImsShape

 TmsShapesEnumerator = TEnumerator;

 ImsShapeCreator = interface
  function CreateShape(const aContext: TmsMakeShapeContext): ImsShape;
 end;//ImsShapeCreator

 ImsDiagrammsHolder = interface
 end;//ImsDiagrammsHolder

 TmsClickContext = record
  public
   rShapeCreator: ImsShapeCreator;
   rClickPoint: TPointF;
   constructor Create(const aShapeCreator: ImsShapeCreator; const aClickPoint: TPointF);
 end;//TmsClickContext

 ImsDiagramm = interface(ImsShapesProvider)
 ['{59F2D068-F06F-4378-9ED4-888DFE8DFAF2}']
  function Get_Name: String;
  procedure Invalidate;
  procedure ProcessClick(const aClickContext: TmsClickContext);
  procedure Clear;
  procedure DrawTo(const aCanvas: TCanvas);
  function AddShape(const aShape: ImsShape): ImsShape;
  function GetEnumerator: TmsShapesEnumerator;
  function ItemsCount: Integer;
  property Name: String
   read Get_Name;
 end;//ImsDiagramm

 ImsDiagramms = interface(ImsDiagrammsList)
 ['{819BEEBA-97BB-48F1-906E-107E67706D19}']
  procedure Serialize;
  procedure DeSerialize;
  function  SelectDiagramm(const aDiagrammName: String): ImsDiagramm;
 end;//ImsDiagramms

 ImsIvalidator = interface
  procedure InvalidateDiagramm(const aDiagramm: ImsDiagramm);
  procedure DiagrammAdded(const aDiagramms: ImsDiagrammsList; const aDiagramm: ImsDiagramm);
 end;//ImsIvalidator

implementation

// TmsDrawContext

constructor TmsDrawContext.Create(const aCanvas : TCanvas);
begin
 rCanvas := aCanvas;
 rMoving := false;
end;

// TmsMakeShapeContext

constructor TmsMakeShapeContext.Create(aStartPoint: TPointF; const aShapesController: ImsShapesController);
begin
 rStartPoint := aStartPoint;
 rShapesController := aShapesController;
end;

// TmsDrawOptionsContext

constructor TmsDrawOptionsContext.Create(const aCtx: TmsDrawContext);
begin
 rFillColor :=  TAlphaColorRec.Null;
 if aCtx.rMoving then
 begin
  rStrokeDash := TStrokeDash.sdDashDot;
  rStrokeColor := TAlphaColors.Darkmagenta;
  rStrokeThickness := 4;
 end//aCtx.rMoving
 else
 begin
  rStrokeDash := TStrokeDash.sdSolid;
  rStrokeColor := TAlphaColorRec.Black;
  rStrokeThickness := 1;
 end;//aCtx.rMoving
end;

// TmsClickContext

constructor TmsClickContext.Create(const aShapeCreator: ImsShapeCreator; const aClickPoint: TPointF);
begin
 rShapeCreator := aShapeCreator;
 rClickPoint := aClickPoint;
end;

end.

среда, 17 декабря 2014 г.

Ссылка. DelphiArmy


http://jonlennartaasenden.wordpress.com/2014/12/16/delphiarmy-com-is-now-a-reality/

В двух словах, парень хочет сделать всемирный сайт поиска работы, для делфи программистов. На днях обещает запустить. 

Ссылка. Простейшие Lock-Free объекты для двух потоков

Коротко. О клиентах к git

Поставил сегодня себе на работе на Мак SmartGIT вместо SourceTree.

Не НАРАДУЮСЬ.

На больших объёмах он раз в СТО быстрее.

Хотя есть и минусы. Пользуюсь теперь обоими. Попеременно.

суббота, 13 декабря 2014 г.

Ссылка. Интерфейсы vs. Абстрактные классы

http://sergeyteplyakov.blogspot.ru/2014/12/interfaces-vs-abstract-classes.html

Для Delphi эта статья - ОСОБЕННО АКТУАЛЬНО читается.

Особенно в "разрезе" InterlockedIncrenent.

В общем - "мои мысли" Тепляков - озвучил - "более чем".

Одно хочу добавить - у Теплякова нет "количественных оценок", а они - ИМХО - важны.

Если методов - "один-два-пять". Ну в крайнем случае - "десять", то это интерфейс.

Иначе это - "должен быть" - абстрактный класс.

Ибо "количественная оценка" говорит о том, что "такой интерфейс реализовать КРАЙНЕ сложно".

Я про "количественные оценки" и Интерфейсы vs. Абстрактные классы когда-то хотел написать.

Но потом - "забил". Понял, что "не поймут".

"Из своей практики" всё же добавлю.

Вот "это" - НЕ ИНТЕРФЕЙС.

А ужас:

 Il3Canvas = interface(Il3InfoCanvas)
  {* Канва для рисования }
   ['{F14964DA-11A9-490F-8D5C-A02BEAF85B84}']
   function pm_GetWindowOrg: Tl3Point;
   procedure pm_SetWindowOrg(const aValue: Tl3Point);
   function pm_GetSWindowOrg: Tl3SPoint;
   procedure pm_SetSWindowOrg(const aValue: Tl3SPoint);
   function pm_GetClipRect: Tl3Rect;
   procedure pm_SetClipRect(const aValue: Tl3Rect);
   function pm_GetGlobalClipRect: Tl3Rect;
   function pm_GetBackColor: Tl3Color;
   procedure pm_SetBackColor(aValue: Tl3Color);
   function pm_GetDrawEnabled: Boolean;
   procedure pm_SetDrawEnabled(aValue: Boolean);
   function pm_GetDrawSpecial: Boolean;
   function pm_GetCanDrawSubs: Boolean;
   function pm_GetShowCursor: Boolean;
   procedure pm_SetShowCursor(aValue: Boolean);
   function pm_GetFontIndexSet: Tl3FontIndexes;
   procedure pm_SetFontIndexSet(aValue: Tl3FontIndexes);
   function pm_GetPrinted: Boolean;
   procedure pm_SetPrinted(aValue: Boolean);
   function pm_GetPenWidth: Integer;
   function pm_GetPageOrientation: Tl3PageOrientation;
   procedure pm_SetPageOrientation(aValue: Tl3PageOrientation);
   function pm_GetSectionExtent: Tl3Point;
   procedure pm_SetSectionExtent(const aValue: Tl3Point);
   procedure pm_SetNotFocused(aValue: Boolean);
   function pm_GetRegionBottomRight: Tl3Point;
   function Get_EffectiveColors: Il3EffectiveColors;
   function pm_GetPageSetup: Il3PageSetup;
   procedure pm_SetPainter(const aValue: Il3HAFPainter);
   function pm_GetCanvas: TCanvas;
   function Get_AbortChecker: Il3AbortChecker;
   procedure Set_AbortChecker(const aValue: Il3AbortChecker);
   procedure MoveWindowOrg(const Delta: Tl3Point); overload; 
   procedure MoveWindowOrg(const Delta: Tl3SPoint); overload; 
   procedure FillForeRect(const R: Tl3SRect);
   procedure FillRect(const R: Tl3SRect); overload; 
   procedure FillRect(const R: Tl3Rect); overload; 
   procedure FillEmptyRect(const R: Tl3Rect); overload; 
   procedure FillEmptyRect(const R: Tl3SRect); overload; 
   function FillRgn(const Region: Il3Region): Boolean;
   function TextOut(const P: Tl3Point;
    const S: Tl3PCharLen;
    FC: Tl3Color = clDefault;
    BC: Tl3Color = clDefault): Tl3Point;
   procedure SetCaret(const Origin: Tl3Point;
    const Extent: Tl3Point;
    Hidden: Boolean = false);
   procedure IncCaret(aDeltaX: Integer);
   procedure BeginPaint;
   procedure StartObject(anObjectID: Integer);
   procedure SetPageTop;
   procedure EndPaint;
   function DrawRgnOrBlock: Boolean;
   function HasToDraw: Boolean;
   procedure StretchDraw(const R: Tl3Rect;
    Graphic: VCLGraphic);
   procedure DrawSub(const aSubTarget: IUnknown;
    const R: Tl3Rect;
    LayerHandle: Integer;
    const aSub: IUnknown);
   procedure ExtTextOut(const P: Tl3Point;
    const R: Tl3Rect;
    const S: Tl3WString;
    F: Tl3TextFormatFlag = l3_tffLeft;
    Dx: PInteger = nil); overload; 
   procedure ExtTextOut(const P: Tl3SPoint;
    const R: Tl3SRect;
    const S: Tl3WString;
    F: Tl3TextFormatFlag = l3_tffLeft;
    Dx: PInteger = nil); overload; 
   function CaretLineOut(const aSt: Tl3WString;
    LineHeight: Integer;
    aHidden: Boolean;
    var CaretPos: Integer): Tl3Point;
     {* выводит строку текста высотой LineHeight, со сдвигом курсора отрисовки. устанавливает курсор в CaretPos. возвращает размеры выведенной строки. }
   function StringOut(const P: Tl3Point;
    const Text: Tl3WString): Tl3Point;
   procedure TabbedTextOut(const P: Tl3Point;
    const R: Tl3Rect;
    const S: Tl3WString;
    const aTabStops: Il3TabStops); overload; 
   procedure TabbedTextOut(const P: Tl3SPoint;
    const R: Tl3SRect;
    const S: Tl3WString;
    const aTabStops: Il3TabStops); overload; 
   function NewPage(ByWidth: Boolean = false): Boolean;
     {* начать новую страницу. }
   procedure Line(const A: Tl3Point;
    const B: Tl3Point); overload; 
     {* нарисовать линию. }
   procedure Line(const A: Tl3SPoint;
    const B: Tl3SPoint); overload; 
     {* нарисовать линию. }
   procedure MoveTo(const Pt: Tl3Point); overload; 
   procedure LineTo(const Pt: Tl3Point); overload; 
   procedure MoveTo(const Pt: Tl3SPoint); overload; 
   procedure LineTo(const Pt: Tl3SPoint); overload; 
   function WO(const aRect: Tl3Rect): Tl3SRect; overload; 
   function WO(const aPt: Tl3Point): Tl3SPoint; overload; 
   function WO(const aPt: Tl3SPoint): Tl3SPoint; overload; 
   procedure DrawFocusRect(const aRect: Tl3SRect);
   procedure StartRegion;
   procedure FinishRegion;
   procedure PushWO;
   procedure PopWO;
   function GetClientRect: Tl3Rect;
   property WindowOrg: Tl3Point
     read pm_GetWindowOrg
     write pm_SetWindowOrg;
     {* смещение начала координат в дюймах. }
   property SWindowOrg: Tl3SPoint
     read pm_GetSWindowOrg
     write pm_SetSWindowOrg;
     {* смещение начала координат в пикселях. }
   property ClipRect: Tl3Rect
     read pm_GetClipRect
     write pm_SetClipRect;
     {* прямоугольник отсечения. }
   property GlobalClipRect: Tl3Rect
     read pm_GetGlobalClipRect;
   property BackColor: Tl3Color
     read pm_GetBackColor
     write pm_SetBackColor;
   property DrawEnabled: Boolean
     read pm_GetDrawEnabled
     write pm_SetDrawEnabled;
     {* разрешено рисование? }
   property DrawSpecial: Boolean
     read pm_GetDrawSpecial;
     {* рисовать спецсимволы? }
   property CanDrawSubs: Boolean
     read pm_GetCanDrawSubs;
     {* можем рисовать Sub'ы? }
   property ShowCursor: Boolean
     read pm_GetShowCursor
     write pm_SetShowCursor;
     {* отображать курсор? }
   property FontIndexSet: Tl3FontIndexes
     read pm_GetFontIndexSet
     write pm_SetFontIndexSet;
     {* текущий набор индексов шрифта. }
   property Printed: Boolean
     read pm_GetPrinted
     write pm_SetPrinted;
     {* все напечатано? }
   property PenWidth: Integer
     read pm_GetPenWidth;
     {* ширина пера. }
   property PageOrientation: Tl3PageOrientation
     read pm_GetPageOrientation
     write pm_SetPageOrientation;
     {* ориентация страницы. }
   property SectionExtent: Tl3Point
     read pm_GetSectionExtent
     write pm_SetSectionExtent;
     {* размеры текущего раздела с дюймах. }
   property NotFocused: Boolean
     write pm_SetNotFocused;
   property RegionBottomRight: Tl3Point
     read pm_GetRegionBottomRight;
   property EffectiveColors: Il3EffectiveColors
     read Get_EffectiveColors;
   property PageSetup: Il3PageSetup
     read pm_GetPageSetup;
   property Painter: Il3HAFPainter
     write pm_SetPainter;
   property Canvas: TCanvas
     read pm_GetCanvas;
   property AbortChecker: Il3AbortChecker
     read Get_AbortChecker
     write Set_AbortChecker;
  // Ml3WindowOrg
   function Get_InitialDCOffset: Tl3Point;
   function Get_InitialDCOffsetStored: Tl3Point;
   property InitialDCOffset: Tl3Point
     read Get_InitialDCOffset;
   property InitialDCOffsetStored: Tl3Point
     read Get_InitialDCOffsetStored;
  // Ml3CanvasState
   procedure Set_ClipRegion(const aValue: Il3Region);
   function PushClipRect: Tl3Rect;
   procedure PopClipRect;
   property ClipRegion: Il3Region
     write Set_ClipRegion;
  // Ml3CanvasInvert
   function pm_GetInvert: Boolean;
   procedure BeginInvert;
   procedure EndInvert;
   property Invert: Boolean
     read pm_GetInvert;
 end;//Il3Canvas

Этот "интерфейс" - НЕВОЗМОЖНО реализовать. БОЛЕЕ одного раза.

Ибо он содержит в себе - МНОЖЕСТВО "побочных знаний".

И "протоколы взаимодействия".

А ЗНАЧИТ - это НЕ ИНТЕРФЕЙС, а "заготовка класса". Пусть и не ЧИСТО абстрактная. Пусть и ЧАСТИЧНО абстрактная.

То что я продемонстрировал выше - это ОДНО из десятков (а то и сотен) ИДИОТСКИХ проектных решений, которые я воплотил в жизнь. Могу продемонстрировать их ВСЕ. С ДЕТАЛЬНЫМ разбором. Был бы только толк.

И кстати - "до конца" проблема станет ясна только под AQTime.

Когда мы УВИДИМ накладные расходы на "подсчёт ссылок". Это уж если про "экономию на спичках".

БЕЗОТНОСИТЕЛЬНО того, что подобные "интерфейсы" в ПРИНЦИПЕ сложно реализовывать.

Или вот ещё:

 Ik2Tag = interface(Ik2Base)
  {* Объект содержащий подъобекты и атомарные атрибуты }
   ['{2345D08B-36E3-4B6A-ABA8-82C74B3431DF}']
   {iterator} function IterateChildrenF(anAction: Ik2Tag_IterateChildrenF_Action;
    aLo: Tl3Index = l3MinIndex;
    aHi: Tl3Index = l3MaxIndex;
    aLoadedOnly: Boolean = false): Integer;
   {iterator} function IterateChildrenBack(anAction: Ik2Tag_IterateChildrenBack_Action;
    aHi: Tl3Index = l3MaxIndex;
    aLo: Tl3Index = l3MinIndex;
    aLoadedOnly: Boolean = false): Integer;
   {iterator} function IterateChildrenBackF(anAction: Ik2Tag_IterateChildrenBack_Action;
    aHi: Tl3Index = l3MaxIndex;
    aLo: Tl3Index = l3MinIndex;
    aLoadedOnly: Boolean = false): Integer;
   {iterator} procedure IterateProperties(anAction: Ik2Tag_IterateProperties_Action;
    anAll: Boolean
    {* Перебирать все возможные свойства или только РЕАЛЬНО заданные});
     {* перебирает все существующие свойства }
   {iterator} procedure IteratePropertiesF(anAction: Ik2Tag_IterateProperties_Action;
    anAll: Boolean
    {* Перебирать все возможные свойства или только РЕАЛЬНО заданные});
     {* перебирает все существующие свойства }
   function Box: Ik2Tag;
     {* ссылка на тег - для сохранения. }
   function IsSame(const aTag: Ik2Tag): Boolean;
     {* указывает, что инструменты работают с одним и тем же тегом. }
   procedure CheckSort(aProp: Tk2ArrayPropertyPrim);
   function AssignTag(const Source: Ik2Tag;
    AssignMode: Tk2AssignModes = k2_amAll;
    const Context: Ik2Op = nil): Boolean;
   function CloneTag: Ik2Tag;
   procedure AssignCloneParams(const aSource: Ik2Tag;
    AssignMode: Tk2AssignModes = k2_amAll;
    const Context: Ik2Op = nil);
   procedure Write(const G: Ik2TagGenerator;
    Flags: Tk2StorePropertyFlags = l3_spfAll;
    Exclude: TByteSet = []);
     {* записать тег в генератор. }
  // Mk2Value
   function pm_GetAsString: AnsiString;
   function pm_GetAsPCharLen: Tl3PCharLen;
   function AsBool: Boolean;
     {* преобразовать к Boolean. }
   function AsLong: Integer;
   function AsObject: TObject;
   property AsString: AnsiString
     read pm_GetAsString;
     {* свойство для преобразования к строкам Delphi }
   property AsPCharLen: Tl3PCharLen
     read pm_GetAsPCharLen;
     {* свойство для преобразования к типу Tl3PCharLen }
  // Mk2TypeInfo
   function IsOrd: Boolean;
   function InheritsFrom(anID: Integer): Boolean; overload; 
     {* проверить наследование. }
   function InheritsFrom(const anIDs: array of Integer): Boolean; overload; 
     {* проверить наследование. }
   function InheritsFrom(anAtomTypeID: Integer;
    const Exclude: array of Integer): Boolean; overload; 
     {* проверить наследование. }
  // Mk2Children
   function pm_GetChildrenCount: Integer;
   function pm_GetChild(anIndex: Integer): Ik2Tag;
   procedure Set_ChildrenCapacity(aValue: Integer);
   function AddChild(var aChild: Ik2Tag;
    const aContext: Ik2Op = nil): Integer;
     {* добавить ребенка. }
   procedure InsertChild(anIndex: Integer;
    var aChild: Ik2Tag;
    const aContext: Ik2Op = nil);
     {* вставить ребенка. }
   function IndexOfChild(const aChild: Ik2Tag): Integer;
   function FindChild(anAtom: Integer;
    aValue: Integer;
    const aContext: Ik2Op = nil;
    aNeedCreate: Boolean = false;
    theIndex: PLong = nil): Ik2Tag;
   procedure DeleteChildren(const Context: Ik2Op = nil);
     {* удалить всех детей. }
   function DeleteChild(anIndex: Integer;
    const anOp: Ik2Op;
    out theChild: Ik2Tag): Boolean; overload; 
     {* удалить ребенка. }
   function DeleteChild(const aChild: Ik2Tag;
    const Context: Ik2Op = nil): Boolean; overload; 
     {* удалить ребенка. }
   function DeleteChild(anIndex: Integer;
    const anOp: Ik2Op = nil): Boolean; overload; 
   property ChildrenCount: Integer
     read pm_GetChildrenCount;
     {* Количество дочерних тегов. }
   property Child[anIndex: Integer]: Ik2Tag
     read pm_GetChild;
   property ChildrenCapacity: Integer
     write Set_ChildrenCapacity;
     {* Потенциально возможное число детей }
  // Mk2RefCount
   function IntRef: Integer;
   procedure SetIntRef(out aRef: Integer);
  // Mk2Storable
   procedure DoLoad;
   procedure ForceStore;
   function MarkModified: Boolean;
  // Mk2Owned
   function Get_Owner: Ik2Tag;
   procedure Set_Owner(const aValue: Ik2Tag);
   property Owner: Ik2Tag
     read Get_Owner
     write Set_Owner;
  // Mk2IntegerHolder
   function pm_GetIntA(anIndex: Integer): Integer;
   procedure pm_SetIntA(anIndex: Integer; aValue: Integer);
   procedure pm_SetIntW(anIndex: Integer; const aContext: Ik2Op; aValue: Integer);
   function RLong(anIndex: Integer;
    aDefault: Integer): Integer;
   property IntA[anIndex: Integer]: Integer
     read pm_GetIntA
     write pm_SetIntA;
   property IntW[anIndex: Integer; const aContext: Ik2Op]: Integer
     write pm_SetIntW;
  // Mk2PCharLenHolder
   function pm_GetPCharLenA(anIndex: Integer): Tl3PCharLen;
   procedure pm_SetPCharLenA(anIndex: Integer; const aValue: Tl3PCharLen);
   procedure pm_SetPCharLenW(anIndex: Integer; const aContext: Ik2Op; const aValue: Tl3WString);
   property PCharLenA[anIndex: Integer]: Tl3PCharLen
     read pm_GetPCharLenA
     write pm_SetPCharLenA;
   property PCharLenW[anIndex: Integer; const aContext: Ik2Op]: Tl3WString
     write pm_SetPCharLenW;
  // Mk2BooleanHolder
   function pm_GetBoolA(anIndex: Integer): Boolean;
   procedure pm_SetBoolA(anIndex: Integer; aValue: Boolean);
   procedure pm_SetBoolW(anIndex: Integer; const aContext: Ik2Op; aValue: Boolean);
   function RBool(anIndex: Integer;
    aDefault: Boolean): Boolean;
   property BoolA[anIndex: Integer]: Boolean
     read pm_GetBoolA
     write pm_SetBoolA;
   property BoolW[anIndex: Integer; const aContext: Ik2Op]: Boolean
     write pm_SetBoolW;
  // Mk2StringHolder
   function pm_GetStrA(anIndex: Integer): AnsiString;
   procedure pm_SetStrA(anIndex: Integer; const aValue: AnsiString);
   procedure pm_SetStrW(anIndex: Integer; const aContext: Ik2Op; const aValue: AnsiString);
   property StrA[anIndex: Integer]: AnsiString
     read pm_GetStrA
     write pm_SetStrA;
   property StrW[anIndex: Integer; const aContext: Ik2Op]: AnsiString
     write pm_SetStrW;
  // Mk2ObjectHolder
   procedure pm_SetObjW(anIndex: Integer; const aContext: Ik2Op; aValue: TObject);
   property ObjW[anIndex: Integer; const aContext: Ik2Op]: TObject
     write pm_SetObjW;
  // Mk2TypeHolder
   function pm_GetTagType: Tk2TypePrim;
   property TagType: Tk2TypePrim
     read pm_GetTagType;
  // Mk2TagHolder
   function pm_GetAttr(anIndex: Integer): Ik2Tag;
   procedure pm_SetAttr(anIndex: Integer; const aValue: Ik2Tag);
   procedure pm_SetAttrW(anIndex: Integer; const aContext: Ik2Op; const aValue: Ik2Tag);
   function RAtomEx(const Path: array of Integer;
    theIndex: PLong = nil): Ik2Tag;
     {* вернуть подтег. }
   function ROwnAtom(anIndex: Integer): Ik2Tag;
   function CAtom(anIndex: Integer;
    const aContext: Ik2Op = nil;
    anAtomType: Tk2TypePrim = nil): Ik2Tag;
     {* проверить существование подтега и создать его при необходимости. }
   function CAtomEx(const aPath: array of Integer;
    const aContext: Ik2Op;
    theIndex: PLong = nil): Ik2Tag;
     {* проверить существование подтега и создать его при необходимости. }
   property Attr[anIndex: Integer]: Ik2Tag
     read pm_GetAttr
     write pm_SetAttr;
     default;
   property AttrW[anIndex: Integer; const aContext: Ik2Op]: Ik2Tag
     write pm_SetAttrW;
  // Mk2Compare
   function CompareWithInt(aValue: Integer;
    anIndex: Integer): Integer;
     {* Сравнивает тег с целым. }
   function CompareWithTag(const aTag: Ik2Tag;
    aSortIndex: Tl3SortIndex): Integer;
  // Mk2AtomHolder
   function HasSubAtom(anIndex: Integer): Boolean;
  // Mk2TagInfo
   function IsNull: Boolean;
     {* пустой тег? }
   function IsValid: Boolean;
     {* тег имеет значение? }
   function IsTransparent: Boolean;
     {* тег "прозрачный"? }
   function IsStream(out theStream: IStream): Boolean;
     {* Проверяет может ли тег приводиться к потоку. И приводит к потоку - если указатель на поток - не нулевой. }
  // Mk2TagToolProvider
   function QT(const IID: TGUID;
    out Obj;
    const aProcessor: Ik2Processor = nil): Boolean;
     {* возвращает инструмент для работы с тегом, к которому привязан исходный инструмент. }
  // Mk2InterfaceProvider
   function GetOwnInterface(const IID: TGUID;
    out Obj): Boolean;
     {* возвращает интерфейс НЕПОСРЕДСТВЕННО поддерживаемый реализацией инструмента. }
   function GetLinkedInterface(const IID: TGUID;
    out Obj): Boolean;
  // Mk2Int64Holder
   function Get_Int64A(aTagID: Integer): Int64;
   procedure Set_Int64A(aTagID: Integer; aValue: Int64);
   procedure Set_Int64W(aTagID: Integer; const aContext: Ik2Op; aValue: Int64);
   property Int64A[aTagID: Integer]: Int64
     read Get_Int64A
     write Set_Int64A;
   property Int64W[aTagID: Integer; const aContext: Ik2Op]: Int64
     write Set_Int64W;
 end;//Ik2Tag

Это тоже - УЖАС, а НЕ "интерфейс".

И он к нынешнему моменту - распался на НЕСКОЛЬКО интерфейсов и "примесей".

пятница, 12 декабря 2014 г.

Offtopic. Offtopic. "О солнечной системе"

http://www.lib.ru/AKONANDOJL/sh_scarl.txt

"Невежество Холмса было так же поразительно, как и его знания. О
современной  литературе,  политике  и   философии   он   почти   не   имел
представления. Мне случилось упомянуть имя Томаса Карлейля, и Холмс наивно
спросил, кто он такой и чем знаменит. Но когда  оказалось,  что  он  ровно
ничего не знает ни о теории Коперника, ни о строении солнечной системы,  я
просто опешил  от  изумления.  Чтобы  цивилизованный  человек,  живущий  в
девятнадцатом веке, не знал, что Земля вертится вокруг Солнца, -  этому  я
просто не мог поверить!
     - Вы, кажется, удивлены, - улыбнулся он,  глядя  на  мое  растерянное
лицо. - Спасибо, что вы меня просветили, но теперь я постараюсь как  можно
скорее все это забыть.
     - Забыть?!
     - Видите ли, - сказал он, - мне представляется, что человеческий мозг
похож на маленький пустой чердак, который вы можете обставить, как хотите.
Дурак натащит туда всякой рухляди, какая попадется под руку,  и  полезные,
нужные вещи уже некуда будет всунуть, или в лучшем  случае  до  них  среди
всей этой завали и не докопаешься. А человек толковый  тщательно  отбирает
то, что он поместит в свой мозговой чердак. Он возьмет  лишь  инструменты,
которые понадобятся ему для работы, но зато их будет множество, и  все  он
разложит в образцовом порядке. Напрасно люди думают, что у этой  маленькой
комнатки эластичные стены и их можно растягивать  сколько  угодно.  Уверяю
вас, придет время, когда, приобретая новое, вы будете забывать  что-то  из
прежнего. Поэтому страшно важно,  чтобы  ненужные  сведения  не  вытесняли
собой нужных.
     - Да, но не знать о солнечной системе!.. - воскликнул я.
     - На кой черт она мне? - перебил он нетерпеливо. - Ну хорошо,  пусть,
как вы говорите, мы вращаемся вокруг Солнца. А если бы  я  узнал,  что  мы
вращаемся вокруг Луны, много бы это помогло мне или моей работе?"

Про generic'и, "примеси", интерфейсы и енумераторы. Только код

Интерфейс:

 ImsDiagramm = interface(ImsObjectWrap)
 ['{59F2D068-F06F-4378-9ED4-888DFE8DFAF2}']
  function Get_Name: String;
  procedure Invalidate;
  procedure ProcessClick(const aStart: TPointF);
  procedure Clear;
  procedure SelectShape(aList: TStrings; anIndex: Integer);
  procedure AllowedShapesToList(aList: TStrings);
  function CurrentShapeClassIndex: Integer;
  procedure DrawTo(const aCanvas: TCanvas);
  property Name: String
   read Get_Name;
 end;//ImsDiagramm

 TmsDiagrammsEnumerator = TEnumerator<ImsDiagramm>;

 ImsDiagramms = interface(ImsObjectWrap)
 ['{819BEEBA-97BB-48F1-906E-107E67706D19}']
  procedure AllowedShapesToList(aList: TStrings);
  function CurrentShapeClassIndex: Integer;
  function CurrentDiagrammIndex: Integer;
  function pm_GetCurrentDiagramm: ImsDiagramm;
  procedure AddDiagramm(aList: TStrings);
  procedure Serialize;
  procedure DeSerialize;
  procedure Clear;
  procedure SelectDiagramm(anIndex: Integer);
  procedure SelectShape(aList: TStrings; anIndex: Integer);
  procedure ProcessClick(const aStart: TPointF);
  function GetEnumerator: TmsDiagrammsEnumerator;
  property CurrentDiagramm: ImsDiagramm
   read pm_GetCurrentDiagramm;
 end;//ImsDiagramms

Обращаем внимание на function GetEnumerator: TmsDiagrammsEnumerator.

Теперь примесь:

{$IfNDef TmsItemsHolder_uses_intf}
// Объект содержащий список других объектов

// interface

{$Define TmsItemsHolder_uses_intf}

// uses
 Generics.Collections,
 Data.DBXJSONReflect,
 System.Rtti

{$Else TmsItemsHolder_uses_intf}

{$IfNDef TmsItemsHolder_intf}
// http://programmingmindstream.blogspot.ru/2014/12/generic-2.html

{$Define TmsItemsHolder_intf}

 TmsRttiFieldLambda = reference to procedure (aField: TRttiField);

 TmsItemsList = TList<TmsItem>;
 TmsItemsListEnumerator = TEnumerator<TmsItem>;

 TmsItemsHolder = class(TmsItemsHolderParent)
 private
  [JSONMarshalled(True)]
  f_Items : TmsItemsList;
  function pm_GetItems: TmsItemsList;
  procedure pm_SetItems(aValue: TmsItemsList);
  class procedure RegisterItemsLike(aLambda: TmsRttiFieldLambda);
 public
  constructor Create;
  destructor Destroy; override;
  property Items: TmsItemsList read pm_GetItems write pm_SetItems;
  procedure Assign(anOther : TmsItemsHolder);
  class procedure RegisterInMarshal(aMarshal: TJSONMarshal);
  class procedure RegisterInUnMarshal(aMarshal: TJSONUnMarshal);
  function GetEnumerator: TmsItemsListEnumerator;
 end;//TmsItemsHolder

{$Else TmsItemsHolder_intf}

// implementation

{$IfNDef TmsItemsHolder_uses_impl}

// uses
  System.TypInfo

{$Define TmsItemsHolder_uses_impl}

{$Else TmsItemsHolder_uses_impl}

// TmsItemsHolder

constructor TmsItemsHolder.Create;
begin
 inherited;
 Assert(f_Items = nil);
 f_Items := TmsItemsList.Create;
end;

destructor TmsItemsHolder.Destroy;
begin
 FreeAndNil(f_Items);
 inherited;
end;

function TmsItemsHolder.pm_GetItems: TmsItemsList;
begin
 if (f_Items = nil) then
  f_Items := TmsItemsList.Create;
 Result := f_Items;
end;

procedure TmsItemsHolder.pm_SetItems(aValue: TmsItemsList);
var
 l_Item : TmsItem;
begin
 if (f_Items <> nil) then
  f_Items.Clear;
 if (aValue <> nil) then
  for l_Item in aValue do
  begin
   if (f_Items = nil) then
    f_Items := TmsItemsList.Create;
   f_Items.Add(l_Item);
  end;//for l_Shape in aValue
end;

procedure TmsItemsHolder.Assign(anOther : TmsItemsHolder);
begin
 Self.Items := anOther.Items;
end;

class procedure TmsItemsHolder.RegisterItemsLike(aLambda: TmsRttiFieldLambda);
var
 l_Field : TRttiField;
begin
 for l_Field in TRttiContext.Create.GetType(Self).GetFields do
  if (l_Field.Visibility = mvPrivate) then
   if (l_Field.Name = 'f_Items') then
   begin
    aLambda(l_Field);
    Exit;
   end;//l_Field.Name = 'f_Items'
 Assert(false, 'Не найдено поля для Items');
end;

class procedure TmsItemsHolder.RegisterInMarshal(aMarshal: TJSONMarshal);
begin
 RegisterItemsLike(
  procedure (aField: TRttiField)
  var
   l_FieldName : String;
  begin
   l_FieldName := aField.Name;
   aMarshal.RegisterConverter(Self, l_FieldName,
    function (Data: TObject; Field: String): TListOfObjects
    var
     l_Item: TmsItem;
     l_Index: Integer;
    begin
     Assert(Field = l_FieldName);
     SetLength(Result, (Data As TmsItemsHolder).Items.Count);
     l_Index := 0;
     for l_Item in (Data As TmsItemsHolder).Items do
     begin
      Result[l_Index] := l_Item.toObject;
      Inc(l_Index);
     end;//for l_Item
    end
   );//aMarshal.RegisterConverter
  end
 );//RegisterItemsLike
 aMarshal.RegisterJSONMarshalled(Self, 'FRefCount', false);
end;

class procedure TmsItemsHolder.RegisterInUnMarshal(aMarshal: TJSONUnMarshal);
begin
 RegisterItemsLike(
  procedure (aField: TRttiField)
  var
   l_FieldName : String;
  begin
   l_FieldName := aField.Name;
   aMarshal.RegisterReverter(Self, l_FieldName,
    procedure (Data: TObject; Field: String; Args: TListOfObjects)
    var
     l_Object: TObject;
     l_Holder : TmsItemsHolder;
     l_ItemI : TmsItem;
    begin
     Assert(Field = l_FieldName);
     l_Holder := Data As TmsItemsHolder;
     Assert(l_Holder <> nil);

     for l_Object in Args do
     begin
      if Supports(l_Object, TmsItem, l_ItemI) then
       l_Holder.Items.Add(l_ItemI)
      else
       raise Exception.Create(l_Object.ClassName + ' не поддерживает нужный интерфейс');
     end//for l_Object
    end
   );//aMarshal.RegisterReverter
  end
 );//RegisterItemsLike
end;

function TmsItemsHolder.GetEnumerator: TmsItemsListEnumerator;
begin
 Result := f_Items.GetEnumerator;
end;

{$EndIf TmsItemsHolder_uses_impl}

{$EndIf TmsItemsHolder_intf}
{$EndIf TmsItemsHolder_uses_intf}

Обращаем внимание на:

 TmsItemsListEnumerator = TEnumerator<TmsItem>
и
 function GetEnumerator: TmsItemsListEnumerator.

Теперь реализация:

unit msCustomDiagramms;

interface

uses
 {$Include msItemsHolder.mixin.pas}
 ,
 msShape,
 msDiagramm,
 msInterfaces,
 msDiagrammsPrim
;

type
 TmsItemsHolderParent = TmsDiagrammsPrim;
 TmsItem = ImsDiagramm;
 {$Include msItemsHolder.mixin.pas}
 TmsCustomDiagramms = class abstract(TmsItemsHolder, ImsDiagramms)
 end;//TmsCustomDiagramms

implementation

uses
 {$Include msItemsHolder.mixin.pas}
 ,
 System.SysUtils
 ;

{$Include msItemsHolder.mixin.pas}

end.

Ссылки:

https://bitbucket.org/ingword/mindstream/src/39ba55201bbe26fff14e321a7e216ab018bf6b22/msInterfaces.pas?at=MS-7_Lulin_Upgrade

https://bitbucket.org/ingword/mindstream/src/39ba55201bbe26fff14e321a7e216ab018bf6b22/msItemsHolder.mixin.pas?at=MS-7_Lulin_Upgrade

https://bitbucket.org/ingword/mindstream/src/39ba55201bbe26fff14e321a7e216ab018bf6b22/msCustomDiagramms.pas?at=MS-7_Lulin_Upgrade

четверг, 11 декабря 2014 г.

Ссылка. NSProxy

Ссылка. Форматирование текста с помощью Markdown

Ещё про примеси. Отвязываем данные от View. Только код

По мотивам - Ещё про примеси. Выделяем класс-примесь TmsIvalidator. Только код

Теперь стало:

https://bitbucket.org/ingword/mindstream/src/e075ee861e2d86776e652391e443782b21da4071/msDiagrammsController.pas?at=MS-7_Lulin_Upgrade

unit msDiagrammsController;

interface

uses
 {$Include msIvalidator.mixin.pas}
 ,
 FMX.Objects,
 FMX.ListBox,
 FMX.StdCtrls,
 FMX.Graphics,
 msDiagramms,
 System.Types,
 FMX.Forms,
 System.Classes,
 System.UITypes,
 msCoreObjects,
 msWatchedObjectInstance,
 msInterfacedRefcounted
 ;

type
 TmsIvalidatorParent = TmsInterfacedRefcounted;
 {$Include msIvalidator.mixin.pas}
 TmsDiagrammsController = class(TmsIvalidator)
 private
  imgMain: TPaintBox;
  cbShapes: TComboBox;
  cbDiagramm: TComboBox;
  btAddDiagramm: TButton;
  btSaveDiagramm: TButton;
  btLoadDiagramm: TButton;
  FDiagramms: TmsDiagramms;
  procedure cbDiagrammChange(Sender: TObject);
  procedure imgMainResize(Sender: TObject);
  procedure cbShapesChange(Sender: TObject);
  procedure btAddDiagrammClick(Sender: TObject);
  procedure imgMainMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Single);
  procedure btSaveDiagrammClick(Sender: TObject);
  procedure btLoadDiagrammClick(Sender: TObject);
  function pm_GetCurrentDiagramm: TmsDiagramm;
 protected
  procedure DoInvalidateDiagramm(aDiagramm: TmsDiagramm); override;
 public
  constructor Create(aImage: TPaintBox; aShapes: TComboBox; aDiagramm: TComboBox; aAddDiagramm: TButton; aSaveDiagramm: TButton; aLoadDiagramm: TButton);
  destructor Destroy; override;
  procedure Clear;
  procedure ProcessClick(const aStart: TPointF);
  property CurrentDiagramm: TmsDiagramm read pm_GetCurrentDiagramm;
  procedure DrawTo(const aCanvas: TCanvas);
 end;//TmsDiagrammsController

implementation

uses
 {$Include msIvalidator.mixin.pas}
 ,
 System.SysUtils,
 FMX.Types
 ;

{$Include msIvalidator.mixin.pas}

// TmsDiagrammsController

constructor TmsDiagrammsController.Create(aImage: TPaintBox;
                                          aShapes: TComboBox;
                                          aDiagramm: TComboBox;
                                          aAddDiagramm: TButton;
                                          aSaveDiagramm: TButton;
                                          aLoadDiagramm: TButton);
begin
 inherited Create;
 imgMain := aImage;
 cbShapes := aShapes;
 cbDiagramm := aDiagramm;
 btAddDiagramm := aAddDiagramm;
 btSaveDiagramm := aSaveDiagramm;
 btLoadDiagramm := aLoadDiagramm;
 FDiagramms := TmsDiagramms.Create(cbDiagramm.Items);
 FDiagramms.AllowedShapesToList(cbShapes.Items);
 cbShapes.ItemIndex := FDiagramms.CurrentShapeClassIndex;
 cbDiagramm.ItemIndex := FDiagramms.CurrentDiagrammIndex;
 cbDiagramm.OnChange := cbDiagrammChange;
 imgMain.OnResize := imgMainResize;
 cbShapes.OnChange := cbShapesChange;
 btAddDiagramm.OnClick := btAddDiagrammClick;
 btSaveDiagramm.OnClick := btSaveDiagrammClick;
 btLoadDiagramm.OnClick := btLoadDiagrammClick;
 imgMain.OnMouseDown := imgMainMouseDown;
 imgMain.Align := TAlignLayout.alClient;
end;

procedure TmsDiagrammsController.DoInvalidateDiagramm(aDiagramm: TmsDiagramm);
begin
 if (imgMain <> nil) then
  if (aDiagramm = CurrentDiagramm) then
   imgMain.Repaint;
end;

function TmsDiagrammsController.pm_GetCurrentDiagramm: TmsDiagramm;
begin
 Result := FDiagramms.CurrentDiagramm;
end;

procedure TmsDiagrammsController.btLoadDiagrammClick(Sender: TObject);
var
 l_D : ImsDiagramm;
 l_I : Integer;
begin
 l_I := FDiagramms.CurrentDiagrammIndex;
 FDiagramms.DeSerialize;
 cbDiagramm.Clear;
 for l_D in FDiagramms.Items do
  cbDiagramm.Items.Add((l_D.toObject As TmsDiagramm).Name);
 cbDiagramm.ItemIndex := l_I;
end;

procedure TmsDiagrammsController.btSaveDiagrammClick(Sender: TObject);
begin
 FDiagramms.Serialize;
end;

procedure TmsDiagrammsController.cbDiagrammChange(Sender: TObject);
begin
 FDiagramms.SelectDiagramm(cbDiagramm.ItemIndex);
 cbShapes.ItemIndex := FDiagramms.CurrentShapeClassIndex;
end;

procedure TmsDiagrammsController.imgMainResize(Sender: TObject);
begin
end;

procedure TmsDiagrammsController.cbShapesChange(Sender: TObject);
begin
 FDiagramms.SelectShape(cbShapes.Items, cbShapes.ItemIndex);
end;

procedure TmsDiagrammsController.btAddDiagrammClick(Sender: TObject);
begin
 FDiagramms.AddDiagramm(cbDiagramm.Items);
 cbDiagramm.ItemIndex := FDiagramms.CurrentDiagrammIndex;
 cbShapes.ItemIndex := FDiagramms.CurrentShapeClassIndex;
end;

destructor TmsDiagrammsController.Destroy;
begin
 FreeAndNil(FDiagramms);
 inherited;
end;

procedure TmsDiagrammsController.Clear;
begin
 FDiagramms.Clear;
end;

procedure TmsDiagrammsController.ProcessClick(const aStart: TPointF);
begin
 FDiagramms.ProcessClick(aStart);
end;

procedure TmsDiagrammsController.DrawTo(const aCanvas: TCanvas);
begin
 CurrentDiagramm.DrawTo(aCanvas);
end;

procedure TmsDiagrammsController.imgMainMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
 Self.ProcessClick(TPointF.Create(X, Y));
end;

end.

Ссылка. Использование замыканий и функций высших порядков в Delphi

Ссылка. TreeView With Images Demo Source Code For Delphi XE7 Firemonkey On Android And IOS

Ещё про примеси. Выделяем класс-примесь TmsIvalidator. Только код

По мотивам - И ещё про "примеси". Только код

https://bitbucket.org/ingword/mindstream/src/b43af5d8e14b393491618198fbfd92dab64dd087/msDiagramms.pas?at=MS-7_Lulin_Upgrade

Было:

unit msDiagramms;

interface

uses
 msDiagramm,
 System.Types,
 FMX.Objects,
 System.Classes,
 msCoreObjects,
 msWatchedObjectInstance,
 msInterfacedNonRefcounted,
 msShape,
 msCustomDiagramms,
 Data.DBXJSONReflect
 ;

type
 TmsDiagramms = class(TmsCustomDiagramms, ImsIvalidator)
 private
  [JSONMarshalled(True)]
  f_CurrentDiagramm : Integer;
  [JSONMarshalled(False)]
  f_Image: TPaintBox;
  function pm_GetCurrentDiagramm: TmsDiagramm;
  procedure InvalidateDiagramm(aDiagramm: TmsDiagramm);
 public
  constructor Create(anImage: TPaintBox; aList: TStrings);
  procedure AfterConstruction; override;
  procedure ProcessClick(const aStart: TPointF);
  procedure Clear;
  procedure SelectShape(aList: TStrings; anIndex: Integer);
  procedure AllowedShapesToList(aList: TStrings);
  procedure AddDiagramm(aList: TStrings);
  function CurrentDiagrammIndex: Integer;
  procedure SelectDiagramm(anIndex: Integer);
  function CurrentShapeClassIndex: Integer;
  procedure Serialize;
  procedure DeSerialize;
  property CurrentDiagramm: TmsDiagramm read pm_GetCurrentDiagramm;
  procedure Assign(anOther: TmsDiagramms);
  destructor Destroy; override;
 end;//TmsDiagramms

implementation

uses
 System.SysUtils,
 FMX.Graphics,
 System.UITypes,
 msDiagrammsMarshal,
 msRegisteredShapes,
 msInvalidators
 ;

// TmsDiagramms

constructor TmsDiagramms.Create(anImage: TPaintBox; aList: TStrings);
begin
 inherited Create;
 f_Image := anImage;
 AddDiagramm(aList);
end;

procedure TmsDiagramms.AfterConstruction;
begin
 TmsInvalidators.Subscribe(Self);
 inherited;
end;

destructor TmsDiagramms.Destroy;
begin
 TmsInvalidators.UnSubscribe(Self);
 inherited;
end;

function TmsDiagramms.pm_GetCurrentDiagramm: TmsDiagramm;
begin
 Result := Items[f_CurrentDiagramm].toObject As TmsDiagramm;
end;

procedure TmsDiagramms.InvalidateDiagramm(aDiagramm: TmsDiagramm);
var
 l_Canvas : TCanvas;
begin
 if (f_Image <> nil) then
  if (aDiagramm = CurrentDiagramm) then
   f_Image.Repaint;
end;

procedure TmsDiagramms.AddDiagramm(aList: TStrings);
var
 l_D : ImsDiagramm;
begin
 l_D := TmsDiagramm.Create('Диаграмма №' + IntToStr(Items.Count + 1));
 Items.Add(l_D);
 f_CurrentDiagramm := Items.IndexOf(l_D);
 if (aList <> nil) then
  aList.Add(l_D.Name);
end;

function TmsDiagramms.CurrentDiagrammIndex: Integer;
begin
 Result := f_CurrentDiagramm;
end;

procedure TmsDiagramms.SelectDiagramm(anIndex: Integer);
begin
 if (anIndex < 0) OR (anIndex >= Items.Count) then
  Exit;
 f_CurrentDiagramm := anIndex;
 CurrentDiagramm.Invalidate;
end;

const
 c_FileName = 'All.json';

procedure TmsDiagramms.DeSerialize;
begin
 TmsDiagrammsMarshal.DeSerialize(c_FileName, self);
end;

procedure TmsDiagramms.Assign(anOther: TmsDiagramms);
var
 l_D : ImsDiagramm;
begin
 inherited Assign(anOther);
 for l_D in Items do
 begin
  (l_D.toObject As TmsDiagramm).CurrentClass := TmsRegisteredShapes.Instance.First;
 end;//for l_D
 Self.f_CurrentDiagramm := anOther.CurrentDiagrammIndex;
 CurrentDiagramm.Invalidate;
end;

procedure TmsDiagramms.ProcessClick(const aStart: TPointF);
begin
 CurrentDiagramm.ProcessClick(aStart);
end;

procedure TmsDiagramms.Clear;
begin
 CurrentDiagramm.Clear;
end;

procedure TmsDiagramms.SelectShape(aList: TStrings; anIndex: Integer);
begin
 CurrentDiagramm.SelectShape(aList, anIndex);
end;

procedure TmsDiagramms.Serialize;
begin
 TmsDiagrammsMarshal.Serialize(c_FileName, self);
end;

procedure TmsDiagramms.AllowedShapesToList(aList: TStrings);
begin
 CurrentDiagramm.AllowedShapesToList(aList);
end;

function TmsDiagramms.CurrentShapeClassIndex: Integer;
begin
 Result := CurrentDiagramm.CurrentShapeClassIndex;
end;

end.

Стало:

https://bitbucket.org/ingword/mindstream/src/4a018ef0ba8d5c7ae8f8ee8bbde32c4803702337/msInvalidators.pas?at=master

https://bitbucket.org/ingword/mindstream/src/4a018ef0ba8d5c7ae8f8ee8bbde32c4803702337/msDiagramms.pas?at=master

msIvalidator.mixin.pas:

{$IfNDef TmsIvalidator_intf}

// interface

{$Define TmsIvalidator_intf}

// uses
 msDiagramm

{$Else TmsIvalidator_intf}

{$IfNDef TmsMixIn_intf}
// http://programmingmindstream.blogspot.ru/2014/12/generic-2.html

 TmsIvalidator = class(TmsIvalidatorParent, ImsIvalidator)
 private
  procedure InvalidateDiagramm(aDiagramm: TmsDiagramm);
 protected
  procedure DoInvalidateDiagramm(aDiagramm: TmsDiagramm); virtual; abstract;
 public
  procedure AfterConstruction; override;
  destructor Destroy; override;
 end;//TmsIvalidator

{$Define TmsMixIn_intf}

{$Else TmsMixIn_intf}

// implementation

{$IfNDef TmsIvalidator_impl}

// uses

{$Define TmsIvalidator_impl}

{$Else TmsIvalidator_impl}

// TmsIvalidator

procedure TmsIvalidator.InvalidateDiagramm(aDiagramm: TmsDiagramm);
begin
 DoInvalidateDiagramm(aDiagramm);
end;

procedure TmsIvalidator.AfterConstruction;
begin
 TmsInvalidators.Subscribe(Self);
 inherited;
end;

destructor TmsIvalidator.Destroy;
begin
 TmsInvalidators.UnSubscribe(Self);
 inherited;
end;

{$EndIf TmsIvalidator_impl}

{$EndIf TmsMixIn_intf}
{$EndIf TmsIvalidator_intf}

msDiagramms:

unit msDiagramms;

interface

uses
 {$Include msIvalidator.mixin.pas}
 ,
 System.Types,
 FMX.Objects,
 System.Classes,
 msCoreObjects,
 msWatchedObjectInstance,
 msInterfacedNonRefcounted,
 msShape,
 msCustomDiagramms,
 Data.DBXJSONReflect
 ;

type
 TmsIvalidatorParent = TmsCustomDiagramms;
 {$Include msIvalidator.mixin.pas}
 TmsDiagramms = class(TmsIvalidator)
 private
  [JSONMarshalled(True)]
  f_CurrentDiagramm : Integer;
  [JSONMarshalled(False)]
  f_Image: TPaintBox;
  function pm_GetCurrentDiagramm: TmsDiagramm;
  procedure DoInvalidateDiagramm(aDiagramm: TmsDiagramm); override;
 public
  constructor Create(anImage: TPaintBox; aList: TStrings);
  procedure ProcessClick(const aStart: TPointF);
  procedure Clear;
  procedure SelectShape(aList: TStrings; anIndex: Integer);
  procedure AllowedShapesToList(aList: TStrings);
  procedure AddDiagramm(aList: TStrings);
  function CurrentDiagrammIndex: Integer;
  procedure SelectDiagramm(anIndex: Integer);
  function CurrentShapeClassIndex: Integer;
  procedure Serialize;
  procedure DeSerialize;
  property CurrentDiagramm: TmsDiagramm read pm_GetCurrentDiagramm;
  procedure Assign(anOther: TmsDiagramms);
 end;//TmsDiagramms

implementation

uses
 {$Include msIvalidator.mixin.pas}
 System.SysUtils,
 FMX.Graphics,
 System.UITypes,
 msDiagrammsMarshal,
 msRegisteredShapes,
 msInvalidators
 ;

{$Include msIvalidator.mixin.pas}

// TmsDiagramms

constructor TmsDiagramms.Create(anImage: TPaintBox; aList: TStrings);
begin
 inherited Create;
 f_Image := anImage;
 AddDiagramm(aList);
end;

function TmsDiagramms.pm_GetCurrentDiagramm: TmsDiagramm;
begin
 Result := Items[f_CurrentDiagramm].toObject As TmsDiagramm;
end;

procedure TmsDiagramms.DoInvalidateDiagramm(aDiagramm: TmsDiagramm);
var
 l_Canvas : TCanvas;
begin
 if (f_Image <> nil) then
  if (aDiagramm = CurrentDiagramm) then
   f_Image.Repaint;
end;

procedure TmsDiagramms.AddDiagramm(aList: TStrings);
var
 l_D : ImsDiagramm;
begin
 l_D := TmsDiagramm.Create('Диаграмма №' + IntToStr(Items.Count + 1));
 Items.Add(l_D);
 f_CurrentDiagramm := Items.IndexOf(l_D);
 if (aList <> nil) then
  aList.Add(l_D.Name);
end;

function TmsDiagramms.CurrentDiagrammIndex: Integer;
begin
 Result := f_CurrentDiagramm;
end;

procedure TmsDiagramms.SelectDiagramm(anIndex: Integer);
begin
 if (anIndex < 0) OR (anIndex >= Items.Count) then
  Exit;
 f_CurrentDiagramm := anIndex;
 CurrentDiagramm.Invalidate;
end;

const
 c_FileName = 'All.json';

procedure TmsDiagramms.DeSerialize;
begin
 TmsDiagrammsMarshal.DeSerialize(c_FileName, self);
end;

procedure TmsDiagramms.Assign(anOther: TmsDiagramms);
var
 l_D : ImsDiagramm;
begin
 inherited Assign(anOther);
 for l_D in Items do
 begin
  (l_D.toObject As TmsDiagramm).CurrentClass := TmsRegisteredShapes.Instance.First;
 end;//for l_D
 Self.f_CurrentDiagramm := anOther.CurrentDiagrammIndex;
 CurrentDiagramm.Invalidate;
end;

procedure TmsDiagramms.ProcessClick(const aStart: TPointF);
begin
 CurrentDiagramm.ProcessClick(aStart);
end;

procedure TmsDiagramms.Clear;
begin
 CurrentDiagramm.Clear;
end;

procedure TmsDiagramms.SelectShape(aList: TStrings; anIndex: Integer);
begin
 CurrentDiagramm.SelectShape(aList, anIndex);
end;

procedure TmsDiagramms.Serialize;
begin
 TmsDiagrammsMarshal.Serialize(c_FileName, self);
end;

procedure TmsDiagramms.AllowedShapesToList(aList: TStrings);
begin
 CurrentDiagramm.AllowedShapesToList(aList);
end;

function TmsDiagramms.CurrentShapeClassIndex: Integer;
begin
 Result := CurrentDiagramm.CurrentShapeClassIndex;
end;

end.

"Почувствуйте разницу", что называется.

Мало кому понравится.

Я знаю.

среда, 10 декабря 2014 г.

Коротко. MindStream. Как мы пишем ПО под FireMonkey. Часть 4 Serialization

http://habrahabr.ru/post/245441/

Ещё надо будет  написать про расход памяти и производительность.

И провести соответствующие тесты.

Коротко. Про TDD и "догматику". Только код

Коротко. Про TDD и "догматику". Только код.

procedure TmsShapeTestPrim.DeserializeDiargammAndCheck(aCheck: TmsDiagrammCheck; aShapeClass: RmsShape);
begin
 CreateDiagrammAndCheck(
  procedure (const aDiagramm : ImsDiagramm)
  begin
   TmsDiagrammMarshal.DeSerialize(MakeFileName(TestSerializeMethodName, aShapeClass), aDiagramm.toObject As TmsDiagramm);
   // - берём результаты от ПРЕДЫДУЩИХ тестов, НЕКОШЕРНО с точки зрения TDD
   //   НО! Чертовски эффективно.
   aCheck(aDiagramm);
  end
  , ''
 );
end;
...
procedure TmsDiagrammTest.TestDeSerialize;
var
 l_Diagramms : TmsDiagramms;
 l_FileName : String;
begin
 l_Diagramms := TmsDiagramms.Create(nil, nil);
 try
  TmsDiagrammsMarshal.DeSerialize(MakeFileName(TestSerializeMethodName, f_Context.rShapeClass), l_Diagramms);
  // - берём результаты от ПРЕДЫДУЩИХ тестов, НЕКОШЕРНО с точки зрения TDD
  //   НО! Чертовски эффективно.
  l_FileName := TestResultsFileName(f_Context.rShapeClass);
  TmsDiagrammsMarshal.Serialize(l_FileName, l_Diagramms);
  CheckFileWithEtalon(l_FileName);
 finally
  FreeAndNil(l_Diagramms);
 end;//try..finally
end;

По мне надо делать то, что "эффективно", а не то, что "догматично".

https://bitbucket.org/ingword/mindstream/src/027273a583c70d3ba588b056cb2a5cd4c9dd8014/Tests/Module/TestmsSerializeController.pas?at=MS-7_Lulin_Upgrade

https://bitbucket.org/ingword/mindstream/src/027273a583c70d3ba588b056cb2a5cd4c9dd8014/Tests/Module/msParametrizedShapeTestSuite.pas?at=MS-7_Lulin_Upgrade

вторник, 9 декабря 2014 г.

Коротко. Про афинные преобразования. Только код

Коротко. Про афинные преобразования. Только код

https://bitbucket.org/ingword/mindstream/src/e0239b6d47ed4a74d4095731b3180e576ad5f5fa/ConcreteShapes/msLineWithArrow.pas?at=MS-7_Lulin_Upgrade

Было:

procedure TmsLineWithArrow.DoDrawTo(const aCtx: TmsDrawContext);
var
 l_Proxy : TmsShape;
 l_OriginalMatrix: TMatrix;
 l_Matrix: TMatrix;
 l_Angle : Single;
 l_CenterPoint : TPointF;

 l_TextRect : TRectF;
begin
 inherited;
 if (StartPoint <> FinishPoint) then
 begin
  l_OriginalMatrix := aCtx.rCanvas.Matrix;
  try
   l_Proxy := TmsSmallTriangle.CreateInner(FinishPoint);
   try
    // in Radian
    l_Angle := GetArrowAngleRotation;

    // create a point around which will rotate
    l_CenterPoint := TPointF.Create(FinishPoint.X, FinishPoint.Y);

    l_Matrix := l_OriginalMatrix;
    l_Matrix := l_Matrix * TMatrix.CreateTranslation(-l_CenterPoint.X,-l_CenterPoint.Y);
    l_Matrix := l_Matrix * TMatrix.CreateRotation(l_Angle);
    l_Matrix := l_Matrix * TMatrix.CreateTranslation(l_CenterPoint.X,l_CenterPoint.Y);

    aCtx.rCanvas.SetMatrix(l_Matrix);

    l_Proxy.DrawTo(aCtx);
   finally
    FreeAndNil(l_Proxy);
   end;//try..finally
  finally
    aCtx.rCanvas.SetMatrix(l_OriginalMatrix);
  end;
 end;//(StartPoint <> FinishPoint)
end;

А правильно так:

procedure TmsLineWithArrow.DoDrawTo(const aCtx: TmsDrawContext);
var
 l_Proxy : TmsShape;
 l_OriginalMatrix: TMatrix;
 l_Matrix: TMatrix;
 l_Angle : Single;
 l_CenterPoint : TPointF;

 l_TextRect : TRectF;
begin
 inherited;
 if (StartPoint <> FinishPoint) then
 begin
  l_OriginalMatrix := aCtx.rCanvas.Matrix;
  try
   l_Proxy := TmsSmallTriangle.CreateInner(FinishPoint);
   try
    // in Radian
    l_Angle := GetArrowAngleRotation;

    // create a point around which will rotate
    l_CenterPoint := TPointF.Create(FinishPoint.X, FinishPoint.Y);

    l_Matrix := l_OriginalMatrix * l_OriginalMatrix.Inverse;
    l_Matrix := l_Matrix * TMatrix.CreateTranslation(-l_CenterPoint.X,-l_CenterPoint.Y);
    l_Matrix := l_Matrix * TMatrix.CreateRotation(l_Angle);
    l_Matrix := l_Matrix * TMatrix.CreateTranslation(l_CenterPoint.X,l_CenterPoint.Y);
    l_Matrix := l_Matrix * l_OriginalMatrix;

    aCtx.rCanvas.SetMatrix(l_Matrix);

    l_Proxy.DrawTo(aCtx);
   finally
    FreeAndNil(l_Proxy);
   end;//try..finally
  finally
    aCtx.rCanvas.SetMatrix(l_OriginalMatrix);
  end;
 end;//(StartPoint <> FinishPoint)
end;

Что изменилось?

l_Matrix := l_OriginalMatrix * l_OriginalMatrix.Inverse;
// - СНИМАЕМ оригинальную матрицу

Обратная матрица.

"Квадратная матрица обратима тогда и только тогда, когда она невырожденная, то есть её определитель не равен нулю. Для неквадратных матриц и вырожденных матриц обратных матриц не существует. Однако возможно обобщить это понятие и ввести псевдообратные матрицы, похожие на обратные по многим свойствам."

l_Matrix := l_Matrix * l_OriginalMatrix;
// - ПРИМЕНЯЕМ оригинальную матрицу

Иначе например ОРИГИНАЛЬНЫЙ параллельный перенос - не будет работать.

Делайте выводы.

P.S. l_OriginalMatrix * l_OriginalMatrix.Inverse == TMatrix.Identity ;-)

Единичная матрица.

P.S.S. Итоговый код:

procedure TmsLineWithArrow.DoDrawTo(const aCtx: TmsDrawContext);
var
 l_Proxy : TmsShape;
 l_OriginalMatrix: TMatrix;
 l_Matrix: TMatrix;
 l_Angle : Single;
 l_CenterPoint : TPointF;

 l_TextRect : TRectF;
begin
 inherited;
 if (StartPoint <> FinishPoint) then
 begin
  l_OriginalMatrix := aCtx.rCanvas.Matrix;
  try
   l_Proxy := TmsSmallTriangle.CreateInner(FinishPoint);
   try
    // in Radian
    l_Angle := GetArrowAngleRotation;

    l_CenterPoint := FinishPoint;

    l_Matrix := TMatrix.Identity;
    // - СНИМАЕМ оригинальную матрицу, точнее берём ЕДИНИЧНУЮ матрицу
    // https://ru.wikipedia.org/wiki/%D0%95%D0%B4%D0%B8%D0%BD%D0%B8%D1%87%D0%BD%D0%B0%D1%8F_%D0%BC%D0%B0%D1%82%D1%80%D0%B8%D1%86%D0%B0
    l_Matrix := l_Matrix * TMatrix.CreateTranslation(-l_CenterPoint.X,-l_CenterPoint.Y);
    // - задаём точку, вокруг которой вертим
    l_Matrix := l_Matrix * TMatrix.CreateRotation(l_Angle);
    // - задаём угол поворота
    l_Matrix := l_Matrix * TMatrix.CreateTranslation(l_CenterPoint.X,l_CenterPoint.Y);
    // - задаём начало координат
    l_Matrix := l_Matrix * l_OriginalMatrix;
    // - ПРИМЕНЯЕМ оригинальную матрицу
    // Иначе например ОРИГИНАЛЬНЫЙ параллельный перенос - не будет работать.
    // https://ru.wikipedia.org/wiki/%D0%9F%D0%B0%D1%80%D0%B0%D0%BB%D0%BB%D0%B5%D0%BB%D1%8C%D0%BD%D1%8B%D0%B9_%D0%BF%D0%B5%D1%80%D0%B5%D0%BD%D0%BE%D1%81

    aCtx.rCanvas.SetMatrix(l_Matrix);
    // - применяем нашу "комплексную" матрицу

    l_Proxy.DrawTo(aCtx);
    // - отрисовываем примитив с учётом матрицы преобразований
   finally
    FreeAndNil(l_Proxy);
   end;//try..finally
  finally
    aCtx.rCanvas.SetMatrix(l_OriginalMatrix);
    // - восстанавливаем ОРИГИНАЛЬНУЮ матрицу
  end;//try..finally
 end;//(StartPoint <> FinishPoint)
end;

Из этого делаем простой вывод.

Что перемножение матриц - НЕ коммутативно.

Что и "логично" - A * B != B * A.

\tbinom{5\ 4}{8\ 0} \tbinom{2\ 9}{6\ 1} = \tbinom{34\ 49}{16\ 72} , но \tbinom{2\ 9}{6\ 1} \tbinom{5\ 4}{8\ 0} = \tbinom{82\ \,8\,}{38\ 24}


https://bitbucket.org/ingword/mindstream/issue/11/

MindStream. Как мы пишем ПО под FireMonkey. Часть 4 Serialization

понедельник, 8 декабря 2014 г.

И ещё про "примеси". Только код

По мотивам:

Про "примеси", шаблоны и Generic'и №3
И ещё раз про "примеси". Теперь - "серьёзно"
Коротко. Контроль за созданием/освобождением объектов. Только код. №4

Теперь вот какая штука.

Есть:

TmsDiagramms - это список TmsDiagramm.
TmsDiagramm - это список TmsShape.

Явно - "рекурсивное решение".

Как это обобщить?

Ну примерно так:

https://bitbucket.org/ingword/mindstream/src/18a744357c57406fc89a5e5498d01394abe6cb4c/?at=MS-6_AddTestToMindStream

TmsItemsHolder.mixin.pas:

{$IfNDef TmsItemsHolder_uses_intf}
// Объект содержащий список других объектов

// interface

{$Define TmsItemsHolder_uses_intf}

// uses
 Generics.Collections,
 Data.DBXJSONReflect,
 System.Rtti

{$Else TmsItemsHolder_uses_intf}

{$IfNDef TmsItemsHolder_intf}
// http://programmingmindstream.blogspot.ru/2014/12/generic-2.html

{$Define TmsItemsHolder_intf}

 TmsRttiFieldLambda = reference to procedure (aField: TRttiField);

 TmsItemsList = TList<TmsItem>;

 TmsItemsHolder = class(TmsItemsHolderParent)
 private
  [JSONMarshalled(True)]
  f_Items : TmsItemsList;
  function pm_GetItems: TmsItemsList;
  procedure pm_SetItems(aValue: TmsItemsList);
  class procedure RegisterItemsLike(aLambda: TmsRttiFieldLambda);
 public
  constructor Create;
  destructor Destroy; override;
  property Items: TmsItemsList read pm_GetItems write pm_SetItems;
  procedure Assign(anOther : TmsItemsHolder);
  class procedure RegisterInMarshal(aMarshal: TJSONMarshal);
  class procedure RegisterInUnMarshal(aMarshal: TJSONUnMarshal);
 end;//TmsItemsHolder

{$Else TmsItemsHolder_intf}

// implementation

{$IfNDef TmsItemsHolder_uses_impl}

// uses
  System.TypInfo

{$Define TmsItemsHolder_uses_impl}

{$Else TmsItemsHolder_uses_impl}

// TmsItemsHolder

constructor TmsItemsHolder.Create;
begin
 inherited;
 Assert(f_Items = nil);
 f_Items := TmsItemsList.Create;
end;

destructor TmsItemsHolder.Destroy;
begin
 FreeAndNil(f_Items);
 inherited;
end;

function TmsItemsHolder.pm_GetItems: TmsItemsList;
begin
 if (f_Items = nil) then
  f_Items := TmsItemsList.Create;
 Result := f_Items;
end;

procedure TmsItemsHolder.pm_SetItems(aValue: TmsItemsList);
var
 l_Item : TmsItem;
begin
 if (f_Items <> nil) then
  f_Items.Clear;
 if (aValue <> nil) then
  for l_Item in aValue do
  begin
   if (f_Items = nil) then
    f_Items := TmsItemsList.Create;
   f_Items.Add(l_Item);
  end;//for l_Shape in aValue
end;

procedure TmsItemsHolder.Assign(anOther : TmsItemsHolder);
begin
 Self.Items := anOther.Items;
end;

class procedure TmsItemsHolder.RegisterItemsLike(aLambda: TmsRttiFieldLambda);
var
 l_Field : TRttiField;
begin
 for l_Field in TRttiContext.Create.GetType(Self).GetFields do
  if (l_Field.Visibility = mvPrivate) then
   if (l_Field.Name = 'f_Items') then
   begin
    aLambda(l_Field);
    Exit;
   end;//l_Field.Name = 'f_Items'
 Assert(false, 'Не найдено поля для Items');
end;

class procedure TmsItemsHolder.RegisterInMarshal(aMarshal: TJSONMarshal);
begin
 RegisterItemsLike(
  procedure (aField: TRttiField)
  var
   l_FieldName : String;
  begin
   l_FieldName := aField.Name;
   aMarshal.RegisterConverter(Self, l_FieldName,
    function (Data: TObject; Field: String): TListOfObjects
    var
     l_Item: TmsItem;
     l_Index: Integer;
    begin
     Assert(Field = l_FieldName);
     SetLength(Result, (Data As TmsItemsHolder).Items.Count);
     l_Index := 0;
     for l_Item in (Data As TmsItemsHolder).Items do
     begin
      Result[l_Index] := l_Item.toObject;
      Inc(l_Index);
     end;//for l_Item
    end
   );//aMarshal.RegisterConverter
  end
 );//RegisterItemsLike
end;

class procedure TmsItemsHolder.RegisterInUnMarshal(aMarshal: TJSONUnMarshal);
begin
 RegisterItemsLike(
  procedure (aField: TRttiField)
  var
   l_FieldName : String;
  begin
   l_FieldName := aField.Name;
   aMarshal.RegisterReverter(Self, l_FieldName,
    procedure (Data: TObject; Field: String; Args: TListOfObjects)
    var
     l_Object: TObject;
     l_Holder : TmsItemsHolder;
     l_ItemI : TmsItem;
    begin
     Assert(Field = l_FieldName);
     l_Holder := Data As TmsItemsHolder;
     Assert(l_Holder <> nil);

     for l_Object in Args do
     begin
      if Supports(l_Object, TmsItem, l_ItemI) then
       l_Holder.Items.Add(l_ItemI)
      else
       raise Exception.Create(l_Object.ClassName + ' не поддерживает нужный интерфейс');
     end//for l_Object
    end
   );//aMarshal.RegisterReverter
  end
 );//RegisterItemsLike
end;

{$EndIf TmsItemsHolder_uses_impl}

{$EndIf TmsItemsHolder_intf}
{$EndIf TmsItemsHolder_uses_intf}

msDiagramm.pas:

unit msDiagramm;

interface

uses
 {$Include msItemsHolder.mixin.pas}
 ,
 FMX.Graphics,
 System.SysUtils,
 System.Types,
 System.UITypes,
 msShape,
 msPointCircle,
 System.Classes,
 FMX.Objects,
 msRegisteredShapes,
 FMX.Dialogs,
 System.JSON,
 msCoreObjects,
 msSerializeInterfaces,
 msInterfacedNonRefcounted,
 msInterfacedRefcounted
 ;

type
 ImsDiagramm = interface
 ['{59F2D068-F06F-4378-9ED4-888DFE8DFAF2}']
  function toObject: TObject;
  function Get_Name: String;
  property Name: String read Get_Name;
 end;//ImsDiagramm

 TmsItemsHolderParent = TmsInterfacedRefcounted{TmsInterfacedNonRefcounted};
 TmsItem = ImsShape;
 {$Include msItemsHolder.mixin.pas}
 TmsDiagramm = class(TmsItemsHolder, ImsDiagramm, ImsShapeByPt, ImsShapesController)
 // - Выделяем интерфейс ImsObjectWrap.
 //   Смешно - если TmsDiagramm его реализет НАПРЯМУЮ, то всё хорошо.
 //   А если через ImsSerializable, то - AV.
 //   Про это можно писать отдельную статью.
 private
  [JSONMarshalled(False)]
  FCurrentClass: RmsShape;
  [JSONMarshalled(False)]
  FCurrentAddedShape: ImsShape;
  [JSONMarshalled(False)]
  FCanvas: TCanvas;
  [JSONMarshalled(True)]
  fName: String;
 private
  procedure DrawTo(const aCanvas: TCanvas);
  function CurrentAddedShape: ImsShape;
  procedure BeginShape(const aStart: TPointF);
  procedure EndShape(const aFinish: TPointF);
  function ShapeIsEnded: Boolean;
  class function AllowedShapes: TmsRegisteredShapes;
  procedure CanvasChanged(aCanvas: TCanvas);
  function ShapeByPt(const aPoint: TPointF): ImsShape;
  procedure RemoveShape(const aShape: ImsShape);
  function Get_Name: String;
  constructor CreatePrim(anImage: TImage; const aName: String);
 public
  class function Create(anImage: TImage; const aName: String): ImsDiagramm;
  procedure ResizeTo(anImage: TImage);
  procedure ProcessClick(const aStart: TPointF);
  procedure Clear;
  procedure Invalidate;
  procedure AllowedShapesToList(aList: TStrings);
  procedure SelectShape(aList: TStrings; anIndex: Integer);
  property Name: String read fName write fName;
  function CurrentShapeClassIndex: Integer;
  procedure Serialize;
  procedure DeSerialize;
  procedure Assign(const anOther : TmsDiagramm);
  property CurrentClass: RmsShape read FCurrentClass write FCurrentClass;
 end;//TmsDiagramm

implementation

uses
 {$Include msItemsHolder.mixin.pas}
 ,
 msMover,
 msCircle,
 msDiagrammMarshal
 ;

{$Include msItemsHolder.mixin.pas}

const
 c_FileName = '.json';

class function TmsDiagramm.AllowedShapes: TmsRegisteredShapes;
begin
 Result := TmsRegisteredShapes.Instance;
end;

procedure TmsDiagramm.AllowedShapesToList(aList: TStrings);
var
 l_Class: RmsShape;
begin
 aList.Clear;
 for l_Class in AllowedShapes do
  if l_Class.IsForToolbar then
   aList.AddObject(l_Class.ClassName, TObject(l_Class));
end;

function TmsDiagramm.CurrentShapeClassIndex: Integer;
begin
 Result := AllowedShapes.IndexOf(FCurrentClass);
end;

procedure TmsDiagramm.SelectShape(aList: TStrings; anIndex: Integer);
begin
 if (anIndex < 0) then
  CurrentClass :=  TmsRegisteredShapes.Instance.First
 else
  CurrentClass := RmsShape(aList.Objects[anIndex]);
end;

procedure TmsDiagramm.Serialize;
begin
 TmsDiagrammMarshal.Serialize(Self.Name + c_FileName, self);
end;

procedure TmsDiagramm.ProcessClick(const aStart: TPointF);
begin
 if ShapeIsEnded then
  // - мы НЕ ДОБАВЛЯЛИ примитива - надо его ДОБАВИТЬ
  BeginShape(aStart)
 else
  EndShape(aStart);
end;

procedure TmsDiagramm.BeginShape(const aStart: TPointF);
begin
 assert(CurrentClass <> nil);
 FCurrentAddedShape := CurrentClass.Create(TmsMakeShapeContext.Create(aStart, Self));
 if (FCurrentAddedShape <> nil) then
 begin
  Items.Add(FCurrentAddedShape);
  if not FCurrentAddedShape.IsNeedsSecondClick then
   // - если не надо SecondClick, то наш примитив - завершён
   FCurrentAddedShape := nil;
  Invalidate;
 end; // FCurrentAddedShape <> nil
end;

procedure TmsDiagramm.Clear;
begin
 if (f_Items <> nil) then
  f_Items.Clear;
 Invalidate;
end;

class function TmsDiagramm.Create(anImage: TImage; const aName: String): ImsDiagramm;
begin
 Result := CreatePrim(anImage, aName);
end;

constructor TmsDiagramm.CreatePrim(anImage: TImage; const aName: String);
begin
 inherited Create;
 FCurrentAddedShape := nil;
 FCanvas := nil;
 ResizeTo(anImage);
 FCurrentClass := AllowedShapes.First;
 fName := aName;
end;

function TmsDiagramm.Get_Name: String;
begin
 Result := FName;
end;

procedure TmsDiagramm.ResizeTo(anImage: TImage);
begin
 if (anImage <> nil) then
 begin
  anImage.Bitmap := TBitmap.Create(Round(anImage.Width), Round(anImage.Height));
  CanvasChanged(anImage.Bitmap.Canvas);
 end;//anImage <> nil
end;

procedure TmsDiagramm.CanvasChanged(aCanvas: TCanvas);
begin
 FCanvas := aCanvas;
 Invalidate;
end;

function TmsDiagramm.CurrentAddedShape: ImsShape;
begin
 Result := FCurrentAddedShape;
end;

procedure TmsDiagramm.Assign(const anOther : TmsDiagramm);
begin
 inherited Assign(anOther);
 Self.Name := anOther.Name;
 Self.Invalidate;
end;

procedure TmsDiagramm.DeSerialize;
begin
 Clear;
 try
  TmsDiagrammMarshal.DeSerialize(Self.Name + c_FileName, Self);
 except
  on EFOpenError do
   Exit;
 end;//try..except
end;

procedure TmsDiagramm.DrawTo(const aCanvas: TCanvas);
var
 l_Shape: ImsShape;
begin
 aCanvas.BeginScene;
 try
  Assert(f_Items <> nil);
  for l_Shape in f_Items do
   l_Shape.DrawTo(TmsDrawContext.Create(aCanvas));
 finally
  aCanvas.EndScene;
 end; // try..finally
end;

procedure TmsDiagramm.EndShape(const aFinish: TPointF);
begin
 assert(CurrentAddedShape <> nil);
 CurrentAddedShape.EndTo(TmsEndShapeContext.Create(aFinish, Self));
 FCurrentAddedShape := nil;
 Invalidate;
end;

procedure TmsDiagramm.Invalidate;
begin
 if (FCanvas <> nil) then
 begin
  FCanvas.BeginScene;
  try
   FCanvas.Clear(TAlphaColorRec.Null);
   DrawTo(FCanvas);
  finally
   FCanvas.EndScene;
  end;//try..finally
 end;//FCanvas <> nil
end;

function TmsDiagramm.ShapeIsEnded: Boolean;
begin
 Result := (CurrentAddedShape = nil);
end;

function TmsDiagramm.ShapeByPt(const aPoint: TPointF): ImsShape;
var
 l_Shape: ImsShape;
 l_Index: Integer;
begin
 Result := nil;
 for l_Index := f_Items.Count - 1 downto 0 do
 begin
  l_Shape := f_Items.Items[l_Index];
  if l_Shape.ContainsPt(aPoint) then
  begin
   Result := l_Shape;
   Exit;
  end; // l_Shape.ContainsPt(aPoint)
 end; // for l_Index
end;

procedure TmsDiagramm.RemoveShape(const aShape: ImsShape);
begin
 Assert(f_Items <> nil);
 f_Items.Remove(aShape);
end;

end.

msDiagramms.pas:

unit msDiagramms;

interface

uses
 {$Include msItemsHolder.mixin.pas}
 ,
 msDiagramm,
 System.Types,
 FMX.Objects,
 System.Classes,
 msCoreObjects,
 msWatchedObjectInstance
 ;

type
 TmsItemsHolderParent = TmsWatchedObject;
 TmsItem = ImsDiagramm;
 {$Include msItemsHolder.mixin.pas}
 TmsDiagramms = class(TmsItemsHolder)
 private
  [JSONMarshalled(True)]
  f_CurrentDiagramm : Integer;
  [JSONMarshalled(False)]
  f_Image: TImage;
  function pm_GetCurrentDiagramm: TmsDiagramm;
 public
  constructor Create(anImage: TImage; aList: TStrings);
  procedure ProcessClick(const aStart: TPointF);
  procedure Clear;
  procedure SelectShape(aList: TStrings; anIndex: Integer);
  procedure AllowedShapesToList(aList: TStrings);
  procedure ResizeTo(anImage: TImage);
  procedure AddDiagramm(anImage: TImage; aList: TStrings);
  function CurrentDiagrammIndex: Integer;
  procedure SelectDiagramm(anIndex: Integer);
  function CurrentShapeClassIndex: Integer;
  procedure Serialize;
  procedure DeSerialize;
  property CurrentDiagramm: TmsDiagramm read pm_GetCurrentDiagramm;
  procedure Assign(anOther: TmsDiagramms);
 end;//TmsDiagramms

implementation

uses
 {$Include msItemsHolder.mixin.pas}
 ,
 System.SysUtils,
 msDiagrammsMarshal,
 msRegisteredShapes
 ;

{$Include msItemsHolder.mixin.pas}

// TmsDiagramms

constructor TmsDiagramms.Create(anImage: TImage; aList: TStrings);
begin
 inherited Create;
 f_Image := anImage;
 AddDiagramm(anImage, aList);
end;

function TmsDiagramms.pm_GetCurrentDiagramm: TmsDiagramm;
begin
 Result := Items[f_CurrentDiagramm].toObject As TmsDiagramm;
end;

procedure TmsDiagramms.AddDiagramm(anImage: TImage; aList: TStrings);
var
 l_D : ImsDiagramm;
begin
 l_D := TmsDiagramm.Create(anImage, 'Диаграмма №' + IntToStr(Items.Count + 1));
 Items.Add(l_D);
 f_CurrentDiagramm := Items.IndexOf(l_D);
 if (aList <> nil) then
  aList.Add(l_D.Name);
//  aList.AddObject(l_D.Name, TObject(f_CurrentDiagramm));
end;

function TmsDiagramms.CurrentDiagrammIndex: Integer;
begin
 Result := f_CurrentDiagramm;
end;

procedure TmsDiagramms.SelectDiagramm(anIndex: Integer);
begin
 if (anIndex < 0) OR (anIndex >= Items.Count) then
  Exit;
 f_CurrentDiagramm := anIndex;
 CurrentDiagramm.Invalidate;
end;

const
 c_FileName = 'All.json';

procedure TmsDiagramms.DeSerialize;
begin
 TmsDiagrammsMarshal.DeSerialize(c_FileName, self);
// CurrentDiagramm.DeSerialize;
end;

procedure TmsDiagramms.Assign(anOther: TmsDiagramms);
var
 l_D : ImsDiagramm;
begin
 inherited Assign(anOther);
 for l_D in Items do
 begin
  (l_D.toObject As TmsDiagramm).ResizeTo(f_Image);
  (l_D.toObject As TmsDiagramm).CurrentClass := TmsRegisteredShapes.Instance.First;
 end;//for l_D
 Self.f_CurrentDiagramm := anOther.CurrentDiagrammIndex;
 CurrentDiagramm.Invalidate;
end;

procedure TmsDiagramms.ProcessClick(const aStart: TPointF);
begin
 CurrentDiagramm.ProcessClick(aStart);
end;

procedure TmsDiagramms.Clear;
begin
 CurrentDiagramm.Clear;
end;

procedure TmsDiagramms.SelectShape(aList: TStrings; anIndex: Integer);
begin
 CurrentDiagramm.SelectShape(aList, anIndex);
end;

procedure TmsDiagramms.Serialize;
begin
 TmsDiagrammsMarshal.Serialize(c_FileName, self);
// CurrentDiagramm.Serialize;
end;

procedure TmsDiagramms.AllowedShapesToList(aList: TStrings);
begin
 CurrentDiagramm.AllowedShapesToList(aList);
end;

procedure TmsDiagramms.ResizeTo(anImage: TImage);
begin
 CurrentDiagramm.ResizeTo(anImage);
end;

function TmsDiagramms.CurrentShapeClassIndex: Integer;
begin
 Result := CurrentDiagramm.CurrentShapeClassIndex;
end;

end.

Ну и сериализация:

TmsMarshal.mixin.pas:

{$IfNDef TmsMarshal_uses_intf}

// interface

{$Define TmsMarshal_uses_intf}

// uses

 JSON,
 Data.DBXJSONReflect,
 msMarshalPrim

{$Else TmsMarshal_uses_intf}

{$IfNDef TmsMarshal}
// http://programmingmindstream.blogspot.ru/2014/12/generic-2.html

{$Define TmsMarshal}

 TmsMarshal = class(TmsMarshalPrim)
 // - шаблонизируем, ибо мы скоро будем сериализовать и другие классы.
 public
  class procedure Serialize(const aFileName: string; const aDiagramm: TClassToSerialize);
  class procedure DeSerialize(const aFileName: string; const aDiagramm: TClassToSerialize);
 end;//TmsMarshal

{$Else TmsMarshal}

// implementation

{$IfNDef TmsMarshal_uses_impl}

// uses
 SysUtils,
 msCoreObjects,
 msStringList

{$Define TmsMarshal_uses_impl}

{$Else TmsMarshal_uses_impl}

// TmsMarshal

class procedure TmsMarshal.DeSerialize(const aFileName: string; const aDiagramm: TClassToSerialize);
var
 l_StringList: TmsStringList;
 l_D : TClassToSerialize;
begin
 l_StringList := TmsStringList.Create;
 try
  l_StringList.LoadFromFile(aFileName);
  l_D := UnMarshal.Unmarshal(TJSONObject.ParseJSONValue(l_StringList.Text)) As TClassToSerialize;
  try
   aDiagramm.Assign(l_D);
  finally
   FreeAndNil(l_D);
  end;//try..finally
 finally
  FreeAndNil(l_StringList);
 end;//try..finally
end;

class procedure TmsMarshal.Serialize(const aFileName: string;
                                                 const aDiagramm: TClassToSerialize);
var
 l_Json: TJSONObject;
 l_StringList: TmsStringList;
begin
 l_StringList := TmsStringList.Create;
 try
  l_Json := nil;
  try
   l_Json := Marshal.Marshal(aDiagramm) as TJSONObject;
   l_StringList.Add(l_Json.toString);
  finally
   FreeAndNil(l_Json);
  end;//try..finally
  l_StringList.SaveToFile(aFileName);
 finally
  FreeAndNil(l_StringList);
 end;//try..finally
end;

{$EndIf TmsMarshal_uses_impl}

{$EndIf TmsMarshal}
{$EndIf TmsMarshal_uses_intf}

Ну и тесты:

https://bitbucket.org/ingword/mindstream/src/18a744357c57406fc89a5e5498d01394abe6cb4c/Tests/Module/?at=MS-6_AddTestToMindStream

https://bitbucket.org/ingword/mindstream/src/18a744357c57406fc89a5e5498d01394abe6cb4c/Tests/Module/TestmsSerializeController.pas?at=MS-6_AddTestToMindStream

https://bitbucket.org/ingword/mindstream/src/18a744357c57406fc89a5e5498d01394abe6cb4c/Tests/Module/msParametrizedShapeTestSuite.pas?at=MS-6_AddTestToMindStream

Вряд ли кому-то понравится. Я знаю.