"Поток сознания" о тестировании и программировании: декабря 2014

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

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

Ссылка. Как скрэшить любое приложение на айфоне, и как этого не допустить

http://habrahabr.ru/company/surfingbird/blog/246757/

среда, 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.

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

Ссылка. How do I pretty-print JSON in Delphi?

http://stackoverflow.com/questions/18511333/how-do-i-pretty-print-json-in-delphi

Я лично - вряд ли буду этим пользоваться. Скорости - не добавляет.

Хотя в нашем "макете" - это сейчас используется. Чисто - "поиграться".

Равно как и "стандартную сериализацию в JSON". Тоже - чисто "поиграться".

Далее будем использовать либо сериализацию через TPersistent либо вообще в EVD.

Ссылка. Насколько медленны iostreams?

http://habrahabr.ru/post/246257/

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

MindStream preAlpha2

Порой ошибки наталкивают на новые решения. Ну и баги видны...

суббота, 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.

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

MindStream, Windows version. Pre-Alpha

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

Ссылка. DelphiArmy

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

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

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

http://habrahabr.ru/post/245889/

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

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

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

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

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

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

Ссылка. Логи как лучшее средство от дебага

http://dou.ua/lenta/articles/logs-beat-debug/?from=nl&utm_source=20141216&utm_medium=email&utm_campaign=CM

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

Ссылка. Автоматическая оптимизация алгоритмов с помощью быстрого возведения матриц в степень

http://habrahabr.ru/post/236689/

После этого поста чувствую себя криворуким ремесленником.

суббота, 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 г.

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

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

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

http://www.fmxexpress.com/treeview-with-images-demo-source-code-for-delphi-xe7-firemonkey-on-android-and-ios/

Сравним:

Использование TTreeView в Firemonkey приложениях

Ещё про примеси. Выделяем класс-примесь 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

Наш новый пост о разработке MindStream

понедельник, 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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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