1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRALayerOriginal;
3
4 {$mode objfpc}{$H+}
5 {$i bgrabitmap.inc}
6
7 interface
8
9 uses
10 BGRAClasses, SysUtils, BGRABitmap, BGRABitmapTypes, BGRATransform, BGRAMemDirectory, fgl
11 {$IFDEF BGRABITMAP_USE_LCL},LCLType{$ENDIF};
12
13 type
14 PRectF = BGRABitmapTypes.PRectF;
15 TAffineMatrix = BGRATransform.TAffineMatrix;
16 TBGRALayerCustomOriginal = class;
17 TBGRAOriginalDiff = class;
18 TBGRALayerOriginalAny = class of TBGRALayerCustomOriginal;
19 TOriginalMovePointEvent = procedure(ASender: TObject; APrevCoord, ANewCoord: TPointF; AShift: TShiftState) of object;
20 TOriginalStartMovePointEvent = procedure(ASender: TObject; AIndex: integer; AShift: TShiftState) of object;
21 TOriginalClickPointEvent = procedure(ASender: TObject; AIndex: integer; AShift: TShiftState) of object;
22 TOriginalHoverPointEvent = procedure(ASender: TObject; AIndex: integer) of object;
23 TOriginalChangeEvent = procedure(ASender: TObject; ABounds: PRectF; var ADiff: TBGRAOriginalDiff) of object;
24 TOriginalEditingChangeEvent = procedure(ASender: TObject) of object;
25 TOriginalEditorCursor = (oecDefault, oecMove, oecMoveW, oecMoveE, oecMoveN, oecMoveS,
26 oecMoveNE, oecMoveSW, oecMoveNW, oecMoveSE, oecHandPoint, oecText);
27 TSpecialKey = (skUnknown, skBackspace, skTab, skReturn, skEscape,
28 skPageUp, skPageDown, skHome, skEnd,
29 skLeft, skUp, skRight, skDown,
30 skInsert, skDelete,
31 skNum0, skNum1, skNum2, skNum3, skNum4, skNum5, skNum6, skNum7, skNum8, skNum9,
32 skF1, skF2, skF3, skF4, skF5, skF6, skF7, skF8, skF9, skF10, skF11, skF12,
33 skA, skB, skC, skD, skE, skF, skG, skH, skI, skJ, skK, skL, skM, skN, skO, skP, skQ, skR, skS, skT, skU, skV, skW, skX, skY, skZ,
34 sk0, sk1, sk2, sk3, sk4, sk5, sk6, sk7, sk8, sk9,
35 skShift, skCtrl, skAlt);
36
37 const
38 SpecialKeyStr: array[TSpecialKey] of string =
39 ('Unknown', 'Backspace', 'Tab', 'Return', 'Escape',
40 'PageUp', 'PageDown', 'Home', 'End',
41 'Left', 'Up', 'Right', 'Down',
42 'Insert', 'Delete',
43 'Num0', 'Num1', 'Num2', 'Num3', 'Num4', 'Num5', 'Num6', 'Num7', 'Num8', 'Num9',
44 'F1', 'F2', 'F3', 'F4', 'F5', 'F6', 'F7', 'F8', 'F9', 'F10', 'F11', 'F12',
45 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z',
46 '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
47 'Shift', 'Ctrl', 'Alt');
48
49 {$IFDEF BGRABITMAP_USE_LCL}
50 const
51 SpecialKeyToLCL: array[TSpecialKey] of Word =
52 (VK_UNKNOWN, VK_BACK,VK_TAB,VK_RETURN,VK_ESCAPE,
53 VK_PRIOR,VK_NEXT,VK_HOME,VK_END,
54 VK_LEFT,VK_UP,VK_RIGHT,VK_DOWN,
55 VK_INSERT,VK_DELETE,
56 VK_NUMPAD0,VK_NUMPAD1,VK_NUMPAD2,VK_NUMPAD3,VK_NUMPAD4,VK_NUMPAD5,VK_NUMPAD6,VK_NUMPAD7,VK_NUMPAD8,VK_NUMPAD9,
57 VK_F1,VK_F2,VK_F3,VK_F4,VK_F5,VK_F6,VK_F7,VK_F8,VK_F9,VK_F10,VK_F11,VK_F12,
58 VK_A, VK_B, VK_C, VK_D, VK_E, VK_F, VK_G, VK_H, VK_I, VK_J, VK_K, VK_L, VK_M, VK_N, VK_O, VK_P, VK_Q, VK_R, VK_S, VK_T, VK_U, VK_V, VK_W, VK_X, VK_Y, VK_Z,
59 VK_0, VK_1, VK_2, VK_3, VK_4, VK_5, VK_6, VK_7, VK_8, VK_9,
60 VK_SHIFT, VK_CONTROL, VK_MENU);
61
LCLKeyToSpecialKeynull62 function LCLKeyToSpecialKey(AKey: Word; AShift: TShiftState): TSpecialKey;
63 {$ENDIF}
64
65 type
66 TStartMoveHandlers = specialize TFPGList<TOriginalStartMovePointEvent>;
67 TClickPointHandlers = specialize TFPGList<TOriginalClickPointEvent>;
68 THoverPointHandlers = specialize TFPGList<TOriginalHoverPointEvent>;
69 TBGRAOriginalPolylineStyle = (opsNone, opsSolid, opsDash, opsDashWithShadow);
70
71 { TBGRAOriginalEditor }
72
73 TBGRAOriginalEditor = class
74 private
75 FFocused: boolean;
76 FOnFocusChanged: TNotifyEvent;
GetIsMovingPointnull77 function GetIsMovingPoint: boolean;
GetPointCoordnull78 function GetPointCoord(AIndex: integer): TPointF;
GetPointCountnull79 function GetPointCount: integer;
GetPointHighlightednull80 function GetPointHighlighted(AIndex: integer): boolean;
81 procedure SetFocused(AValue: boolean);
82 procedure SetPointHighlighted(AIndex: integer; AValue: boolean);
83 protected
84 FMatrix,FMatrixInverse: TAffineMatrix; //view matrix from original coord
85 FGridMatrix,FGridMatrixInverse: TAffineMatrix; //grid matrix in original coord
86 FGridActive: boolean;
87 FPoints: array of record
88 Origin, Coord: TPointF;
89 OnMove, OnAlternateMove: TOriginalMovePointEvent;
90 RightButton, Highlighted: boolean;
91 SnapToPoint: integer;
92 HitBox: TAffineBox;
93 end;
94 FPolylines: array of record
95 Coords: array of TPointF;
96 Closed: boolean;
97 Style: TBGRAOriginalPolylineStyle;
98 BackColor: TBGRAPixel;
99 end;
100 FPointSize: single;
101 FPointMoving: integer;
102 FPointWasMoved: boolean;
103 FPointCoordDelta: TPointF;
104 FMovingRightButton: boolean;
105 FPrevMousePos: TPointF;
106 FStartMoveHandlers: TStartMoveHandlers;
107 FCurHoverPoint: integer;
108 FHoverPointHandlers: THoverPointHandlers;
109 FClickPointHandlers: TClickPointHandlers;
RenderPointnull110 function RenderPoint(ADest: TBGRABitmap; ACoord: TPointF; AAlternateColor: boolean; AHighlighted: boolean): TRect; virtual;
GetRenderPointBoundsnull111 function GetRenderPointBounds(ACoord: TPointF; AHighlighted: boolean): TRect; virtual;
RenderArrownull112 function RenderArrow(ADest: TBGRABitmap; AOrigin, AEndCoord: TPointF): TRect; virtual;
GetRenderArrowBoundsnull113 function GetRenderArrowBounds(AOrigin, AEndCoord: TPointF): TRect; virtual;
RenderPolygonnull114 function RenderPolygon(ADest: TBGRABitmap; ACoords: array of TPointF; AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle; ABackColor: TBGRAPixel): TRect; virtual;
GetRenderPolygonBoundsnull115 function GetRenderPolygonBounds(ACoords: array of TPointF): TRect;
116 procedure SetMatrix(AValue: TAffineMatrix);
117 procedure SetGridMatrix(AValue: TAffineMatrix);
118 procedure SetGridActive(AValue: boolean);
GetMoveCursornull119 function GetMoveCursor(APointIndex: integer): TOriginalEditorCursor; virtual;
GetFixedShiftForButtonnull120 function GetFixedShiftForButton(AShift: TShiftState; ARightDown: boolean): TShiftState;
121 public
122 constructor Create;
123 destructor Destroy; override;
124 procedure Clear; virtual;
125 procedure AddStartMoveHandler(AOnStartMove: TOriginalStartMovePointEvent);
126 procedure AddClickPointHandler(AOnClickPoint: TOriginalClickPointEvent);
127 procedure AddHoverPointHandler(AOnHoverPoint: TOriginalHoverPointEvent);
AddPointnull128 function AddPoint(const ACoord: TPointF; AOnMove: TOriginalMovePointEvent; ARightButton: boolean = false; ASnapToPoint: integer = -1): integer;
129 procedure AddPointAlternateMove(AIndex: integer; AOnAlternateMove: TOriginalMovePointEvent);
AddFixedPointnull130 function AddFixedPoint(const ACoord: TPointF; ARightButton: boolean = false): integer;
AddArrownull131 function AddArrow(const AOrigin, AEndCoord: TPointF; AOnMoveEnd: TOriginalMovePointEvent; ARightButton: boolean = false): integer;
AddPolylinenull132 function AddPolyline(const ACoords: array of TPointF; AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle): integer; overload;
AddPolylinenull133 function AddPolyline(const ACoords: array of TPointF; AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle; ABackColor: TBGRAPixel): integer; overload;
134 procedure SetHitBox(AIndex: integer; AHitBox: TAffineBox);
135 procedure MouseMove(Shift: TShiftState; ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean); virtual;
136 procedure MouseDown(RightButton: boolean; Shift: TShiftState; ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean); virtual;
137 procedure MouseUp(RightButton: boolean; {%H-}Shift: TShiftState; {%H-}ViewX, {%H-}ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean); virtual;
138 procedure KeyDown({%H-}Shift: TShiftState; {%H-}Key: TSpecialKey; out AHandled: boolean); virtual;
139 procedure KeyUp({%H-}Shift: TShiftState; {%H-}Key: TSpecialKey; out AHandled: boolean); virtual;
140 procedure KeyPress({%H-}UTF8Key: string; out AHandled: boolean); virtual;
GetPointAtnull141 function GetPointAt(const ACoord: TPointF; ARightButton: boolean): integer;
Rendernull142 function Render(ADest: TBGRABitmap; const {%H-}ALayoutRect: TRect): TRect; virtual;
GetRenderBoundsnull143 function GetRenderBounds(const {%H-}ALayoutRect: TRect): TRect; virtual;
SnapToGridnull144 function SnapToGrid(const ACoord: TPointF; AIsViewCoord: boolean): TPointF;
OriginalCoordToViewnull145 function OriginalCoordToView(const AImageCoord: TPointF): TPointF;
ViewCoordToOriginalnull146 function ViewCoordToOriginal(const AViewCoord: TPointF): TPointF;
147 property Matrix: TAffineMatrix read FMatrix write SetMatrix;
148 property GridMatrix: TAffineMatrix read FGridMatrix write SetGridMatrix;
149 property GridActive: boolean read FGridActive write SetGridActive;
150 property Focused: boolean read FFocused write SetFocused;
151 property PointSize: single read FPointSize write FPointSize;
152 property PointCount: integer read GetPointCount;
153 property PointCoord[AIndex: integer]: TPointF read GetPointCoord;
154 property PointHighlighted[AIndex: integer]: boolean read GetPointHighlighted write SetPointHighlighted;
155 property OnFocusChanged: TNotifyEvent read FOnFocusChanged write FOnFocusChanged;
156 property IsMovingPoint: boolean read GetIsMovingPoint;
157 end;
158
159 TBGRACustomOriginalStorage = class;
160 ArrayOfSingle = array of single;
161
162 TBGRAOriginalDiff = class
163 procedure Apply(AOriginal: TBGRALayerCustomOriginal); virtual; abstract;
164 procedure Unapply(AOriginal: TBGRALayerCustomOriginal); virtual; abstract;
CanAppendnull165 function CanAppend(ADiff: TBGRAOriginalDiff): boolean; virtual; abstract;
166 procedure Append(ADiff: TBGRAOriginalDiff); virtual; abstract;
IsIdentitynull167 function IsIdentity: boolean; virtual; abstract;
168 end;
169
170 { TBGRALayerCustomOriginal }
171
172 TBGRALayerCustomOriginal = class
173 private
174 FOnChange: TOriginalChangeEvent;
175 FOnEditingChange: TOriginalEditingChangeEvent;
176 FRenderStorage: TBGRACustomOriginalStorage;
GetDiffExpectednull177 function GetDiffExpected: boolean;
178 procedure SetOnChange(AValue: TOriginalChangeEvent);
179 procedure SetRenderStorage(AValue: TBGRACustomOriginalStorage);
180 protected
181 FGuid: TGuid;
GetGuidnull182 function GetGuid: TGuid;
183 procedure SetGuid(AValue: TGuid);
184 procedure NotifyChange(ADiff: TBGRAOriginalDiff = nil); overload;
185 procedure NotifyChange(ABounds: TRectF; ADiff: TBGRAOriginalDiff = nil); overload;
186 procedure NotifyEditorChange;
187 property DiffExpected: boolean read GetDiffExpected;
188 public
189 constructor Create; virtual;
190 destructor Destroy; override;
191 //one of the two Render functions must be overriden
192 procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); virtual;
193 procedure Render(ADest: TBGRABitmap; ARenderOffset: TPoint; AMatrix: TAffineMatrix; ADraft: boolean); virtual;
GetRenderBoundsnull194 function GetRenderBounds(ADestRect: TRect; AMatrix: TAffineMatrix): TRect; virtual; abstract;
195 procedure ConfigureEditor({%H-}AEditor: TBGRAOriginalEditor); virtual;
196 procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); virtual; abstract;
197 procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); virtual; abstract;
198 procedure LoadFromFile(AFilenameUTF8: string); virtual;
199 procedure LoadFromStream(AStream: TStream); virtual;
200 procedure LoadFromResource(AFilename: string);
201 procedure SaveToFile(AFilenameUTF8: string); virtual;
202 procedure SaveToStream(AStream: TStream); virtual;
CreateEditornull203 function CreateEditor: TBGRAOriginalEditor; virtual;
StorageClassNamenull204 class function StorageClassName: RawByteString; virtual; abstract;
CanConvertToSVGnull205 class function CanConvertToSVG: boolean; virtual;
IsInfiniteSurfacenull206 function IsInfiniteSurface: boolean; virtual;
ConvertToSVGnull207 function ConvertToSVG(const {%H-}AMatrix: TAffineMatrix; out AOffset: TPoint): TObject; virtual;
Duplicatenull208 function Duplicate: TBGRALayerCustomOriginal; virtual;
209 property Guid: TGuid read GetGuid write SetGuid;
210 property OnChange: TOriginalChangeEvent read FOnChange write SetOnChange;
211 property OnEditingChange: TOriginalEditingChangeEvent read FOnEditingChange write FOnEditingChange;
212 property RenderStorage: TBGRACustomOriginalStorage read FRenderStorage write SetRenderStorage;
213 end;
214
215 TBGRALayerImageOriginal = class;
216
217 { TBGRAImageOriginalDiff }
218
219 TBGRAImageOriginalDiff = class(TBGRAOriginalDiff)
220 protected
221 FContentVersionBefore,FContentVersionAfter: integer;
222 FImageBefore,FImageAfter: TBGRABitmap;
223 FJpegStreamBefore,FJpegStreamAfter: TMemoryStream;
224 public
225 constructor Create(AFromOriginal: TBGRALayerImageOriginal);
226 destructor Destroy; override;
227 procedure ComputeDiff(AToOriginal: TBGRALayerImageOriginal);
228 procedure Apply(AOriginal: TBGRALayerCustomOriginal); override;
229 procedure Unapply(AOriginal: TBGRALayerCustomOriginal); override;
CanAppendnull230 function CanAppend(ADiff: TBGRAOriginalDiff): boolean; override;
231 procedure Append(ADiff: TBGRAOriginalDiff); override;
IsIdentitynull232 function IsIdentity: boolean; override;
233 end;
234
235 { TBGRALayerImageOriginal }
236
237 TBGRALayerImageOriginal = class(TBGRALayerCustomOriginal)
238 private
GetImageHeightnull239 function GetImageHeight: integer;
GetImageWidthnull240 function GetImageWidth: integer;
241 protected
242 FImage: TBGRABitmap;
243 FJpegStream: TMemoryStream;
244 FContentVersion: integer;
245 FDiff: TBGRAImageOriginalDiff;
246 procedure BeginUpdate;
247 procedure EndUpdate;
248 procedure InternalLoadImageFromStream(AStream: TStream; AUpdate: boolean);
249 procedure InternalClear;
250 public
251 constructor Create; override;
252 destructor Destroy; override;
ConvertToSVGnull253 function ConvertToSVG(const AMatrix: TAffineMatrix; out AOffset: TPoint): TObject; override;
254 procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); override;
GetRenderBoundsnull255 function GetRenderBounds({%H-}ADestRect: TRect; AMatrix: TAffineMatrix): TRect; override;
256 procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
257 procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
258 procedure LoadFromStream(AStream: TStream); override;
259 procedure Clear;
260 procedure LoadImageFromStream(AStream: TStream);
261 procedure SaveImageToStream(AStream: TStream);
262 procedure AssignImage(AImage: TBGRACustomBitmap);
GetImageCopynull263 function GetImageCopy: TBGRABitmap;
StorageClassNamenull264 class function StorageClassName: RawByteString; override;
CanConvertToSVGnull265 class function CanConvertToSVG: boolean; override;
266 property Width: integer read GetImageWidth;
267 property Height: integer read GetImageHeight;
268 end;
269
270 { TBGRACustomOriginalStorage }
271
272 TBGRACustomOriginalStorage = class
273 protected
274 FFormats: TFormatSettings;
GetBoolnull275 function GetBool(AName: utf8string): boolean;
GetBoolDefnull276 function GetBoolDef(AName: utf8string; ADefault: boolean): boolean;
GetColorArraynull277 function GetColorArray(AName: UTF8String): ArrayOfTBGRAPixel;
GetIntegernull278 function GetInteger(AName: utf8string): integer;
GetIntegerDefnull279 function GetIntegerDef(AName: utf8string; ADefault: integer): integer;
GetPointFnull280 function GetPointF(AName: utf8string): TPointF;
GetRectFnull281 function GetRectF(AName: utf8string): TRectF;
GetRectnull282 function GetRect(AName: utf8string): TRect;
GetAffineMatrixnull283 function GetAffineMatrix(AName: utf8string): TAffineMatrix;
GetRawStringnull284 function GetRawString(AName: utf8string): RawByteString; virtual; abstract;
GetSinglenull285 function GetSingle(AName: utf8string): single;
GetSingleArraynull286 function GetSingleArray(AName: utf8string): ArrayOfSingle;
GetSingleDefnull287 function GetSingleDef(AName: utf8string; ADefault: single): single;
GetColornull288 function GetColor(AName: UTF8String): TBGRAPixel;
289 procedure SetBool(AName: utf8string; AValue: boolean);
290 procedure SetColorArray(AName: UTF8String; AValue: ArrayOfTBGRAPixel);
291 procedure SetInteger(AName: utf8string; AValue: integer);
292 procedure SetPointF(AName: utf8string; AValue: TPointF);
293 procedure SetRectF(AName: utf8string; AValue: TRectF);
294 procedure SetRect(AName: utf8string; AValue: TRect);
295 procedure SetAffineMatrix(AName: utf8string; const AValue: TAffineMatrix);
296 procedure SetRawString(AName: utf8string; AValue: RawByteString); virtual; abstract;
297 procedure SetSingle(AName: utf8string; AValue: single);
298 procedure SetSingleArray(AName: utf8string; AValue: ArrayOfSingle);
299 procedure SetColor(AName: UTF8String; AValue: TBGRAPixel);
GetDelimiternull300 function GetDelimiter: char;
GetEmptynull301 function GetEmpty: boolean; virtual; abstract;
302 public
303 constructor Create;
Duplicatenull304 function Duplicate: TBGRACustomOriginalStorage; virtual; abstract;
305 procedure RemoveAttribute(AName: utf8string); virtual; abstract;
HasAttributenull306 function HasAttribute(AName: utf8string): boolean; virtual; abstract;
307 procedure RemoveObject(AName: utf8string); virtual; abstract;
CreateObjectnull308 function CreateObject(AName: utf8string): TBGRACustomOriginalStorage; virtual; abstract;
OpenObjectnull309 function OpenObject(AName: utf8string): TBGRACustomOriginalStorage; virtual; abstract;
ObjectExistsnull310 function ObjectExists(AName: utf8string): boolean; virtual; abstract;
311 procedure EnumerateObjects(AList: TStringList); virtual; abstract;
312 procedure EnumerateFiles(AList: TStringList); virtual; abstract;
313 procedure RemoveFile(AName: utf8string); virtual; abstract;
GetFileStreamnull314 function GetFileStream(AName: UTF8String): TStream; virtual; abstract;
ReadFilenull315 function ReadFile(AName: UTF8String; ADest: TStream): boolean; virtual; abstract;
ReadBitmapnull316 function ReadBitmap(AName: UTF8String; ADest: TCustomUniversalBitmap): boolean; virtual; abstract;
317 procedure WriteFile(AName: UTF8String; ASource: TStream; ACompress: boolean; AOwnStream: boolean = false); virtual; abstract;
FileExistsnull318 function FileExists(AName: UTF8String): boolean; virtual; abstract;
FloatEqualsnull319 function FloatEquals(AName: utf8string; AValue: single): boolean;
PointFEqualsnull320 function PointFEquals(AName: utf8string; const AValue: TPointF): boolean;
AffineMatrixEqualsnull321 function AffineMatrixEquals(AName: utf8string; const AValue: TAffineMatrix): boolean;
322 property RawString[AName: utf8string]: RawByteString read GetRawString write SetRawString;
323 property Int[AName: utf8string]: integer read GetInteger write SetInteger;
324 property IntDef[AName: utf8string; ADefault: integer]: integer read GetIntegerDef;
325 property Bool[AName: utf8string]: boolean read GetBool write SetBool;
326 property BoolDef[AName: utf8string; ADefault: boolean]: boolean read GetBoolDef;
327 property Float[AName: utf8string]: single read GetSingle write SetSingle;
328 property FloatArray[AName: utf8string]: ArrayOfSingle read GetSingleArray write SetSingleArray;
329 property FloatDef[AName: utf8string; ADefault: single]: single read GetSingleDef;
330 property PointF[AName: utf8string]: TPointF read GetPointF write SetPointF;
331 property RectangleF[AName: utf8string]: TRectF read GetRectF write SetRectF;
332 property Rectangle[AName: utf8string]: TRect read GetRect write SetRect;
333 property AffineMatrix[AName: utf8string]: TAffineMatrix read GetAffineMatrix write SetAffineMatrix;
334 property Color[AName: UTF8String]: TBGRAPixel read GetColor write SetColor;
335 property ColorArray[AName: UTF8String]: ArrayOfTBGRAPixel read GetColorArray write SetColorArray;
336 property Empty: boolean read GetEmpty;
337 end;
338
339 { TBGRAMemOriginalStorage }
340
341 TBGRAMemOriginalStorage = class(TBGRACustomOriginalStorage)
342 protected
343 FMemDir: TMemDirectory;
344 FMemDirOwned: boolean;
GetRawStringnull345 function GetRawString(AName: utf8string): RawByteString; override;
346 procedure SetRawString(AName: utf8string; AValue: RawByteString); override;
GetEmptynull347 function GetEmpty: boolean; override;
348 public
349 destructor Destroy; override;
350 constructor Create;
351 constructor Create(AMemDir: TMemDirectory; AMemDirOwned: boolean = false);
Equalsnull352 function Equals(Obj: TObject): boolean; override;
Duplicatenull353 function Duplicate: TBGRACustomOriginalStorage; override;
354 procedure RemoveAttribute(AName: utf8string); override;
HasAttributenull355 function HasAttribute(AName: utf8string): boolean; override;
356 procedure RemoveObject(AName: utf8string); override;
CreateObjectnull357 function CreateObject(AName: utf8string): TBGRACustomOriginalStorage; override;
OpenObjectnull358 function OpenObject(AName: utf8string): TBGRACustomOriginalStorage; override;
ObjectExistsnull359 function ObjectExists(AName: utf8string): boolean; override;
360 procedure EnumerateObjects(AList: TStringList); override;
361 procedure EnumerateFiles(AList: TStringList); override;
362 procedure RemoveFile(AName: utf8string); override;
GetFileStreamnull363 function GetFileStream(AName: UTF8String): TStream; override;
ReadBitmapnull364 function ReadBitmap(AName: UTF8String; ADest: TCustomUniversalBitmap): boolean; override;
ReadFilenull365 function ReadFile(AName: UTF8String; ADest: TStream): boolean; override;
366 procedure WriteFile(AName: UTF8String; ASource: TStream; ACompress: boolean; AOwnStream: boolean = false); override;
FileExistsnull367 function FileExists(AName: UTF8String): boolean; override;
368 procedure SaveToStream(AStream: TStream);
369 procedure LoadFromStream(AStream: TStream);
370 procedure LoadFromResource(AFilename: string);
371 procedure CopyTo(AMemDir: TMemDirectory);
372 end;
373
374 procedure RegisterLayerOriginal(AClass: TBGRALayerOriginalAny);
FindLayerOriginalClassnull375 function FindLayerOriginalClass(AStorageClassName: string): TBGRALayerOriginalAny;
376
377 implementation
378
379 uses BGRAPolygon, math, BGRAMultiFileType, BGRAUTF8, BGRAGraphics, BGRASVG, BGRASVGShapes;
380
381 {$IFDEF BGRABITMAP_USE_LCL}
LCLKeyToSpecialKeynull382 function LCLKeyToSpecialKey(AKey: Word; AShift: TShiftState): TSpecialKey;
383 var
384 sk: TSpecialKey;
385 begin
386 if (((AKey >= VK_A) and (AKey <= VK_Z)) or
387 ((AKey >= VK_0) and (AKey <= VK_9))) and (AShift*[ssCtrl,ssAlt]=[]) then exit(skUnknown);
388 for sk := low(TSpecialKey) to high(TSpecialKey) do
389 if AKey = SpecialKeyToLCL[sk] then exit(sk);
390 exit(skUnknown);
391 end;
392 {$ENDIF}
393
394 var
395 LayerOriginalClasses: array of TBGRALayerOriginalAny;
396
397 procedure RegisterLayerOriginal(AClass: TBGRALayerOriginalAny);
398 begin
399 setlength(LayerOriginalClasses, length(LayerOriginalClasses)+1);
400 LayerOriginalClasses[high(LayerOriginalClasses)] := AClass;
401 end;
402
FindLayerOriginalClassnull403 function FindLayerOriginalClass(AStorageClassName: string): TBGRALayerOriginalAny;
404 var
405 i: Integer;
406 begin
407 for i := 0 to high(LayerOriginalClasses) do
408 if LayerOriginalClasses[i].StorageClassName = AStorageClassName then
409 exit(LayerOriginalClasses[i]);
410 exit(nil);
411 end;
412
413 { TBGRAImageOriginalDiff }
414
415 constructor TBGRAImageOriginalDiff.Create(AFromOriginal: TBGRALayerImageOriginal);
416 begin
417 FImageBefore := AFromOriginal.FImage.NewReference;
418 if Assigned(AFromOriginal.FJpegStream) then
419 begin
420 FJpegStreamBefore := TMemoryStream.Create;
421 AFromOriginal.FJpegStream.Position:= 0;
422 FJpegStreamBefore.CopyFrom(AFromOriginal.FJpegStream, AFromOriginal.FJpegStream.Size);
423 end;
424 FContentVersionBefore:= AFromOriginal.FContentVersion;
425 end;
426
427 procedure TBGRAImageOriginalDiff.ComputeDiff(
428 AToOriginal: TBGRALayerImageOriginal);
429 begin
430 if Assigned(FImageAfter) then FImageAfter.FreeReference;
431 FImageAfter := AToOriginal.FImage.NewReference;
432 FreeAndNil(FJpegStreamAfter);
433 if Assigned(AToOriginal.FJpegStream) then
434 begin
435 FJpegStreamAfter := TMemoryStream.Create;
436 AToOriginal.FJpegStream.Position:= 0;
437 FJpegStreamAfter.CopyFrom(AToOriginal.FJpegStream, AToOriginal.FJpegStream.Size);
438 end;
439 FContentVersionAfter:= AToOriginal.FContentVersion;
440 end;
441
442 procedure TBGRAImageOriginalDiff.Apply(AOriginal: TBGRALayerCustomOriginal);
443 var
444 orig: TBGRALayerImageOriginal;
445 begin
446 orig := AOriginal as TBGRALayerImageOriginal;
447 orig.FImage.FreeReference;
448 orig.FImage := FImageAfter.NewReference;
449 FreeAndNil(orig.FJpegStream);
450 if Assigned(FJpegStreamAfter) then
451 begin
452 orig.FJpegStream := TMemoryStream.Create;
453 FJpegStreamAfter.Position := 0;
454 orig.FJpegStream.CopyFrom(FJpegStreamAfter, FJpegStreamAfter.Size);
455 end;
456 orig.FContentVersion := FContentVersionAfter;
457 end;
458
459 procedure TBGRAImageOriginalDiff.Unapply(AOriginal: TBGRALayerCustomOriginal);
460 var
461 orig: TBGRALayerImageOriginal;
462 begin
463 orig := AOriginal as TBGRALayerImageOriginal;
464 orig.FImage.FreeReference;
465 orig.FImage := FImageBefore.NewReference;
466 FreeAndNil(orig.FJpegStream);
467 if Assigned(FJpegStreamBefore) then
468 begin
469 orig.FJpegStream := TMemoryStream.Create;
470 FJpegStreamBefore.Position := 0;
471 orig.FJpegStream.CopyFrom(FJpegStreamBefore, FJpegStreamBefore.Size);
472 end;
473 orig.FContentVersion := FContentVersionBefore;
474 end;
475
TBGRAImageOriginalDiff.CanAppendnull476 function TBGRAImageOriginalDiff.CanAppend(ADiff: TBGRAOriginalDiff): boolean;
477 begin
478 result := (ADiff is TBGRAImageOriginalDiff) and
479 (TBGRAImageOriginalDiff(ADiff).FContentVersionAfter >= FContentVersionAfter);
480 end;
481
482 procedure TBGRAImageOriginalDiff.Append(ADiff: TBGRAOriginalDiff);
483 var
484 next: TBGRAImageOriginalDiff;
485 begin
486 next := ADiff as TBGRAImageOriginalDiff;
487 if next.FContentVersionAfter < FContentVersionAfter then
488 raise exception.Create('Cannot append diff made before this one.');
489 FImageAfter.FreeReference;
490 FImageAfter := next.FImageAfter.NewReference;
491 FreeAndNil(FJpegStreamAfter);
492 if Assigned(next.FJpegStreamAfter) then
493 begin
494 FJpegStreamAfter := TMemoryStream.Create;
495 next.FJpegStreamAfter.Position:= 0;
496 FJpegStreamAfter.CopyFrom(next.FJpegStreamAfter, next.FJpegStreamAfter.Size);
497 end;
498 FContentVersionAfter:= next.FContentVersionAfter;
499 end;
500
TBGRAImageOriginalDiff.IsIdentitynull501 function TBGRAImageOriginalDiff.IsIdentity: boolean;
502 begin
503 result := FImageBefore.Equals(FImageAfter) and
504 ( ((FJpegStreamBefore=nil) and (FJpegStreamAfter=nil)) or
505 (Assigned(FJpegStreamBefore) and Assigned(FJpegStreamAfter) and
506 (FJpegStreamBefore.Size = FJpegStreamAfter.Size) and
507 CompareMem(FJpegStreamBefore.Memory,FJpegStreamBefore.Memory,FJpegStreamBefore.Size)) );
508
509 end;
510
511 destructor TBGRAImageOriginalDiff.Destroy;
512 begin
513 FImageBefore.FreeReference;
514 FImageAfter.FreeReference;
515 FJpegStreamBefore.Free;
516 FJpegStreamAfter.Free;
517 inherited Destroy;
518 end;
519
520 { TBGRAOriginalEditor }
521
522 procedure TBGRAOriginalEditor.SetMatrix(AValue: TAffineMatrix);
523 begin
524 if FMatrix=AValue then Exit;
525 FMatrix:=AValue;
526 FMatrixInverse := AffineMatrixInverse(FMatrix);
527 end;
528
GetMoveCursornull529 function TBGRAOriginalEditor.GetMoveCursor(APointIndex: integer): TOriginalEditorCursor;
530 var
531 d: TPointF;
532 ratio: single;
533 begin
534 if (APointIndex < 0) or (APointIndex >= PointCount) then result := oecDefault else
535 if isEmptyPointF(FPoints[APointIndex].Origin) then
536 begin
537 if Assigned(FPoints[APointIndex].OnMove) then
538 result := oecMove
539 else
540 result := oecHandPoint;
541 end else
542 begin
543 d := AffineMatrixLinear(FMatrix)*(FPoints[APointIndex].Coord - FPoints[APointIndex].Origin);
544 ratio := sin(Pi/8);
545 if (d.x = 0) and (d.y = 0) then result := oecMove else
546 if abs(d.x)*ratio >= abs(d.y) then
547 begin
548 if d.x >= 0 then result := oecMoveE else result := oecMoveW
549 end else
550 if abs(d.y)*ratio >= abs(d.x) then
551 begin
552 if d.y >= 0 then result := oecMoveS else result := oecMoveN
553 end else
554 if (d.x > 0) and (d.y > 0) then result := oecMoveSE else
555 if (d.x < 0) and (d.y < 0) then result := oecMoveNW else
556 if (d.x > 0) and (d.y < 0) then result := oecMoveNE
557 else result := oecMoveSW;
558 end;
559 end;
560
GetFixedShiftForButtonnull561 function TBGRAOriginalEditor.GetFixedShiftForButton(AShift: TShiftState;
562 ARightDown: boolean): TShiftState;
563 begin
564 result := AShift - [ssLeft,ssMiddle,ssRight];
565 if ARightDown then include(result, ssRight)
566 else include(result, ssLeft);
567 end;
568
GetPointCoordnull569 function TBGRAOriginalEditor.GetPointCoord(AIndex: integer): TPointF;
570 begin
571 if (AIndex < 0) or (AIndex >= PointCount) then raise exception.Create('Index out of bounds');
572 result := FPoints[AIndex].Coord;
573 end;
574
GetIsMovingPointnull575 function TBGRAOriginalEditor.GetIsMovingPoint: boolean;
576 begin
577 result := FPointMoving <> -1;
578 end;
579
TBGRAOriginalEditor.GetPointCountnull580 function TBGRAOriginalEditor.GetPointCount: integer;
581 begin
582 result := length(FPoints);
583 end;
584
TBGRAOriginalEditor.GetPointHighlightednull585 function TBGRAOriginalEditor.GetPointHighlighted(AIndex: integer): boolean;
586 begin
587 if (AIndex < 0) or (AIndex >= PointCount) then raise exception.Create('Index out of bounds');
588 result := FPoints[AIndex].Highlighted;
589 end;
590
591 procedure TBGRAOriginalEditor.SetFocused(AValue: boolean);
592 begin
593 if FFocused=AValue then Exit;
594 FFocused:=AValue;
595 if Assigned(FOnFocusChanged) then FOnFocusChanged(self);
596 end;
597
598 procedure TBGRAOriginalEditor.SetPointHighlighted(AIndex: integer;
599 AValue: boolean);
600 begin
601 if (AIndex < 0) or (AIndex >= PointCount) then raise exception.Create('Index out of bounds');
602 FPoints[AIndex].Highlighted := AValue;
603 end;
604
605 procedure TBGRAOriginalEditor.SetGridActive(AValue: boolean);
606 begin
607 if FGridActive=AValue then Exit;
608 FGridActive:=AValue;
609 end;
610
611 procedure TBGRAOriginalEditor.SetGridMatrix(AValue: TAffineMatrix);
612 begin
613 if FGridMatrix=AValue then Exit;
614 FGridMatrix:=AValue;
615 FGridMatrixInverse := AffineMatrixInverse(FGridMatrix);
616 end;
617
TBGRAOriginalEditor.RenderPointnull618 function TBGRAOriginalEditor.RenderPoint(ADest: TBGRABitmap; ACoord: TPointF; AAlternateColor: boolean; AHighlighted: boolean): TRect;
619 const alpha = 192;
620 var filler: TBGRAMultishapeFiller;
621 c: TBGRAPixel;
622 penScale: Single;
623 oldClip: TRect;
624 begin
625 result := GetRenderPointBounds(ACoord, AHighlighted);
626 if not isEmptyPointF(ACoord) then
627 begin
628 oldClip := ADest.ClipRect;
629 ADest.IntersectClip(result);
630 if AAlternateColor then c := BGRA(255,128,128,alpha)
631 else if AHighlighted then c := BGRA(96,170,255,alpha)
632 else c := BGRA(255,255,255,alpha);
633 if AHighlighted then
634 ADest.GradientFill(result.Left, result.Top, result.Right, result.Bottom,
635 c, BGRAPixelTransparent,
636 gtRadial, PointF(ACoord.x,ACoord.y), PointF(result.right,ACoord.y),
637 dmDrawWithTransparency);
638 penScale := FPointSize / 6;
639 if penScale < 1 then penScale := 1;
640 filler := TBGRAMultishapeFiller.Create;
641 filler.AddEllipseBorder(ACoord.x,ACoord.y, FPointSize-2,FPointSize-2, 3.5*penScale, BGRA(0,0,0,alpha));
642 filler.AddEllipseBorder(ACoord.x,ACoord.y, FPointSize-2,FPointSize-2, 1*penScale, c);
643 filler.PolygonOrder:= poLastOnTop;
644 filler.Draw(ADest);
645 filler.Free;
646 ADest.ClipRect := oldClip;
647 end;
648 end;
649
GetRenderPointBoundsnull650 function TBGRAOriginalEditor.GetRenderPointBounds(ACoord: TPointF; AHighlighted: boolean): TRect;
651 var
652 r, penScale: Single;
653 begin
654 if isEmptyPointF(ACoord) then
655 result := EmptyRect
656 else
657 begin
658 penScale := FPointSize / 6;
659 if penScale < 1 then penScale := 1;
660 r := FPointSize + (penScale-1)*4;
661 if AHighlighted then r := max(r, FPointSize*2);
662 result := rect(floor(ACoord.x - r + 0.5), floor(ACoord.y - r + 0.5),
663 ceil(ACoord.x + r + 0.5), ceil(ACoord.y + r + 0.5));
664 end;
665 end;
666
RenderArrownull667 function TBGRAOriginalEditor.RenderArrow(ADest: TBGRABitmap; AOrigin,
668 AEndCoord: TPointF): TRect;
669 const alpha = 192;
670 var
671 pts, ptsContour: ArrayOfTPointF;
672 i: Integer;
673 rF: TRectF;
674 penScale: Single;
675 begin
676 if isEmptyPointF(AOrigin) or isEmptyPointF(AEndCoord) then
677 result := EmptyRect
678 else
679 begin
680 penScale := FPointSize / 6;
681 if penScale < 1 then penScale := 1;
682 ADest.Pen.Arrow.EndAsClassic;
683 ADest.Pen.Arrow.EndSize := PointF(FPointSize/penScale,FPointSize/penScale);
684 pts := ADest.ComputeWidePolyline([AOrigin,AEndCoord],1*penScale);
685 ADest.Pen.Arrow.EndAsNone;
686 ptsContour := ADest.ComputeWidePolygon(pts, 2*penScale);
687 ADest.FillPolyAntialias(ptsContour, BGRA(0,0,0,alpha));
688 ADest.FillPolyAntialias(pts, BGRA(255,255,255,alpha));
689 rF := RectF(AOrigin,AEndCoord);
690 for i := 0 to high(ptsContour) do
691 if not isEmptyPointF(ptsContour[i]) then
692 begin
693 if ptsContour[i].x < rF.Left then rF.Left := ptsContour[i].x;
694 if ptsContour[i].x > rF.Right then rF.Right := ptsContour[i].x;
695 if ptsContour[i].y < rF.Top then rF.Top := ptsContour[i].y;
696 if ptsContour[i].y > rF.Bottom then rF.Bottom := ptsContour[i].y;
697 end;
698 result := rect(floor(rF.Left+0.5),floor(rF.Top+0.5),ceil(rF.Right+0.5),ceil(rF.Bottom+0.5));
699 end;
700 end;
701
TBGRAOriginalEditor.GetRenderArrowBoundsnull702 function TBGRAOriginalEditor.GetRenderArrowBounds(AOrigin, AEndCoord: TPointF): TRect;
703 var
704 penScale, margin: Single;
705 begin
706 if isEmptyPointF(AOrigin) or isEmptyPointF(AEndCoord) then
707 result := EmptyRect
708 else
709 begin
710 penScale := FPointSize / 6;
711 if penScale < 1 then penScale := 1;
712 margin := penScale * 1.5;
713 result := Rect(floor(AOrigin.x+0.5-margin),floor(AOrigin.y+0.5-margin),
714 ceil(AOrigin.x+0.5+margin),ceil(AOrigin.y+0.5+margin));
715 result.Union( rect(floor(AEndCoord.x+0.5-FPointSize-margin), floor(AEndCoord.y+0.5-FPointSize-margin),
716 ceil(AEndCoord.x+0.5+FPointSize+margin), ceil(AEndCoord.y+0.5+FPointSize+margin)) );
717 end;
718 end;
719
TBGRAOriginalEditor.RenderPolygonnull720 function TBGRAOriginalEditor.RenderPolygon(ADest: TBGRABitmap;
721 ACoords: array of TPointF; AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle; ABackColor: TBGRAPixel): TRect;
722 var
723 dashLen: integer;
724 i: integer;
725 ptsF: array of TPointF;
726 pts1,pts2: array of TPoint;
727 begin
728 dashLen := round(PointSize/2);
729 if dashLen < 1 then dashLen := 1;
730
731 setlength(pts1, length(ACoords));
732 for i := 0 to high(ACoords) do
733 pts1[i] := ACoords[i].Round;
734
735 setlength(ptsF, length(pts1));
736 for i := 0 to high(pts1) do
737 ptsF[i] := PointF(pts1[i]);
738
739 if ABackColor.alpha <> 0 then
740 ADest.FillPolyAntialias(ptsF, ABackColor);
741
742 case AStyle of
743 opsDash, opsDashWithShadow:
744 begin
745 if AStyle = opsDashWithShadow then
746 begin
747 //shadow
748 setlength(pts2,length(pts1));
749 for i := 0 to high(pts1) do
750 if not isEmptyPoint(pts1[i]) then
751 pts2[i] := Point(pts1[i].x+1,pts1[i].y+1)
752 else pts2[i] := EmptyPoint;
753 if AClosed then
754 ADest.DrawPolygonAntialias(pts2, BGRA(0,0,0,96))
755 else
756 ADest.DrawPolyLineAntialias(pts2, BGRA(0,0,0,96), true);
757 pts2:= nil;
758 end;
759
760 //dotted line
761 if AClosed then
762 ADest.DrawPolygonAntialias(pts1, CSSIvory,BGRA(70,70,50),dashLen)
763 else
764 ADest.DrawPolyLineAntialias(pts1, CSSIvory,BGRA(70,70,50),dashLen, true);
765 end;
766 opsSolid:
767 begin
768 ADest.JoinStyle:= pjsRound;
769 ADest.LineCap:= pecRound;
770 //black outline
771 if AClosed then
772 ADest.DrawPolygonAntialias(ptsF, BGRA(0,0,0,192), 3)
773 else
774 ADest.DrawPolyLineAntialias(ptsF, BGRA(0,0,0,192), 3);
775
776 if AClosed then
777 ADest.DrawPolygonAntialias(pts1, CSSIvory)
778 else
779 ADest.DrawPolyLineAntialias(pts1, CSSIvory, true);
780 end;
781 end;
782
783 result := GetRenderPolygonBounds(ACoords);
784 end;
785
TBGRAOriginalEditor.GetRenderPolygonBoundsnull786 function TBGRAOriginalEditor.GetRenderPolygonBounds(ACoords: array of TPointF): TRect;
787 var
788 first: Boolean;
789 rF: TRectF;
790 i: Integer;
791 begin
792 first:= true;
793 rF:= EmptyRectF;
794 for i := 0 to high(ACoords) do
795 if not isEmptyPointF(ACoords[i]) then
796 begin
797 if first then
798 begin
799 rF := RectF(Acoords[i],ACoords[i]);
800 first:= false;
801 end else
802 begin
803 if ACoords[i].x < rF.Left then rF.Left := ACoords[i].x;
804 if ACoords[i].x > rF.Right then rF.Right := ACoords[i].x;
805 if ACoords[i].y < rF.Top then rF.Top := ACoords[i].y;
806 if ACoords[i].y > rF.Bottom then rF.Bottom := ACoords[i].y;
807 end;
808 end;
809 if not first then
810 result := rect(floor(rF.Left-0.5),floor(rF.Top-0.5),ceil(rF.Right+1.5),ceil(rF.Bottom+1.5))
811 else
812 result := EmptyRect;
813 end;
814
815 constructor TBGRAOriginalEditor.Create;
816 begin
817 FPointSize:= 6;
818 FMatrix := AffineMatrixIdentity;
819 FMatrixInverse := AffineMatrixIdentity;
820 FGridMatrix := AffineMatrixIdentity;
821 FGridMatrixInverse := AffineMatrixIdentity;
822 FGridActive:= false;
823 FPointMoving:= -1;
824 FStartMoveHandlers := TStartMoveHandlers.Create;
825 FCurHoverPoint:= -1;
826 FHoverPointHandlers := THoverPointHandlers.Create;
827 FClickPointHandlers := TClickPointHandlers.Create;
828 end;
829
830 destructor TBGRAOriginalEditor.Destroy;
831 begin
832 FreeAndNil(FStartMoveHandlers);
833 FreeAndNil(FHoverPointHandlers);
834 FreeAndNil(FClickPointHandlers);
835 inherited Destroy;
836 end;
837
838 procedure TBGRAOriginalEditor.Clear;
839 begin
840 FPoints := nil;
841 FPolylines := nil;
842 FStartMoveHandlers.Clear;
843 FHoverPointHandlers.Clear;
844 FClickPointHandlers.Clear;
845 end;
846
847 procedure TBGRAOriginalEditor.AddStartMoveHandler(
848 AOnStartMove: TOriginalStartMovePointEvent);
849 begin
850 FStartMoveHandlers.Add(AOnStartMove);
851 end;
852
853 procedure TBGRAOriginalEditor.AddClickPointHandler(
854 AOnClickPoint: TOriginalClickPointEvent);
855 begin
856 FClickPointHandlers.Add(AOnClickPoint);
857 end;
858
859 procedure TBGRAOriginalEditor.AddHoverPointHandler(
860 AOnHoverPoint: TOriginalHoverPointEvent);
861 begin
862 FHoverPointHandlers.Add(AOnHoverPoint);
863 end;
864
TBGRAOriginalEditor.AddPointnull865 function TBGRAOriginalEditor.AddPoint(const ACoord: TPointF;
866 AOnMove: TOriginalMovePointEvent; ARightButton: boolean; ASnapToPoint: integer): integer;
867 begin
868 setlength(FPoints, length(FPoints)+1);
869 result := High(FPoints);
870 with FPoints[result] do
871 begin
872 Origin := EmptyPointF;
873 Coord := ACoord;
874 OnMove := AOnMove;
875 OnAlternateMove:= nil;
876 RightButton:= ARightButton;
877 SnapToPoint:= ASnapToPoint;
878 HitBox := TAffineBox.EmptyBox;
879 end;
880 end;
881
882 procedure TBGRAOriginalEditor.AddPointAlternateMove(AIndex: integer;
883 AOnAlternateMove: TOriginalMovePointEvent);
884 begin
885 if (AIndex >= 0) and (AIndex < PointCount) then
886 FPoints[AIndex].OnAlternateMove:= AOnAlternateMove;
887 end;
888
TBGRAOriginalEditor.AddFixedPointnull889 function TBGRAOriginalEditor.AddFixedPoint(const ACoord: TPointF;
890 ARightButton: boolean): integer;
891 begin
892 setlength(FPoints, length(FPoints)+1);
893 result := High(FPoints);
894 with FPoints[result] do
895 begin
896 Origin := EmptyPointF;
897 Coord := ACoord;
898 OnMove := nil;
899 OnAlternateMove:= nil;
900 RightButton:= ARightButton;
901 Highlighted:= false;
902 SnapToPoint:= -1;
903 HitBox := TAffineBox.EmptyBox;
904 end;
905 end;
906
AddArrownull907 function TBGRAOriginalEditor.AddArrow(const AOrigin, AEndCoord: TPointF;
908 AOnMoveEnd: TOriginalMovePointEvent; ARightButton: boolean): integer;
909 begin
910 setlength(FPoints, length(FPoints)+1);
911 result := High(FPoints);
912 with FPoints[result] do
913 begin
914 Origin := AOrigin;
915 Coord := AEndCoord;
916 OnMove := AOnMoveEnd;
917 OnAlternateMove:= nil;
918 RightButton:= ARightButton;
919 Highlighted:= false;
920 SnapToPoint:= -1;
921 HitBox := TAffineBox.EmptyBox;
922 end;
923 end;
924
TBGRAOriginalEditor.AddPolylinenull925 function TBGRAOriginalEditor.AddPolyline(const ACoords: array of TPointF;
926 AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle): integer;
927 begin
928 result := AddPolyline(ACoords, AClosed, AStyle, BGRAPixelTransparent);
929 end;
930
TBGRAOriginalEditor.AddPolylinenull931 function TBGRAOriginalEditor.AddPolyline(const ACoords: array of TPointF;
932 AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle; ABackColor: TBGRAPixel): integer;
933 var
934 i: Integer;
935 begin
936 setlength(FPolylines, length(FPolylines)+1);
937 result := high(FPolylines);
938 setlength(FPolylines[result].Coords, length(ACoords));
939 for i := 0 to high(ACoords) do
940 FPolylines[result].Coords[i] := ACoords[i];
941 FPolylines[result].Closed:= AClosed;
942 FPolylines[result].Style := AStyle;
943 FPolylines[result].BackColor := ABackColor;
944 end;
945
946 procedure TBGRAOriginalEditor.SetHitBox(AIndex: integer; AHitBox: TAffineBox);
947 begin
948 if (AIndex < 0) or (AIndex >= PointCount) then raise exception.Create('Index out of bounds');
949 FPoints[AIndex].HitBox := AHitBox;
950 end;
951
952 procedure TBGRAOriginalEditor.MouseMove(Shift: TShiftState; ViewX, ViewY: single; out
953 ACursor: TOriginalEditorCursor; out AHandled: boolean);
954 var newMousePos, newCoord, snapCoord: TPointF;
955 hoverPoint, i: Integer;
956 subShift: TShiftState;
957 begin
958 AHandled := false;
959 newMousePos := ViewCoordToOriginal(PointF(ViewX,ViewY));
960 if (FPointMoving <> -1) and (FPointMoving < length(FPoints)) then
961 begin
962 newCoord := newMousePos + FPointCoordDelta;
963 if GridActive then newCoord := SnapToGrid(newCoord, false);
964 if FPoints[FPointMoving].SnapToPoint <> -1 then
965 begin
966 snapCoord := FPoints[FPoints[FPointMoving].SnapToPoint].Coord;
967 if VectLen(AffineMatrixLinear(FMatrix)*(snapCoord - newCoord)) < FPointSize then
968 newCoord := snapCoord;
969 end;
970 if newCoord <> FPoints[FPointMoving].Coord then
971 begin
972 FPointWasMoved:= true;
973 subShift := GetFixedShiftForButton(Shift, FMovingRightButton);
974 if (FMovingRightButton xor FPoints[FPointMoving].RightButton) and
975 Assigned(FPoints[FPointMoving].OnAlternateMove) then
976 FPoints[FPointMoving].OnAlternateMove(self, FPoints[FPointMoving].Coord, newCoord, subShift)
977 else
978 FPoints[FPointMoving].OnMove(self, FPoints[FPointMoving].Coord, newCoord, subShift);
979 if (FPointMoving >= 0) and (FPointMoving < length(FPoints)) then
980 FPoints[FPointMoving].Coord := newCoord
981 else
982 FPointMoving := -1;
983 end;
984 ACursor := GetMoveCursor(FPointMoving);
985 AHandled:= true;
986 end else
987 begin
988 hoverPoint := GetPointAt(newMousePos, false);
989 if hoverPoint <> -1 then
990 ACursor := GetMoveCursor(hoverPoint)
991 else
992 ACursor:= oecDefault;
993 if hoverPoint <> FCurHoverPoint then
994 begin
995 FCurHoverPoint:= hoverPoint;
996 for i := 0 to FHoverPointHandlers.Count-1 do
997 FHoverPointHandlers[i](self, FCurHoverPoint);
998 end;
999 end;
1000 FPrevMousePos:= newMousePos;
1001 end;
1002
1003 procedure TBGRAOriginalEditor.MouseDown(RightButton: boolean;
1004 Shift: TShiftState; ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out
1005 AHandled: boolean);
1006 var
1007 i, clickedPoint: Integer;
1008 subShift: TShiftState;
1009 begin
1010 AHandled:= false;
1011 FPrevMousePos:= ViewCoordToOriginal(PointF(ViewX,ViewY));
1012 if FPointMoving = -1 then
1013 begin
1014 clickedPoint := GetPointAt(FPrevMousePos, RightButton);
1015 if clickedPoint <> -1 then
1016 begin
1017 subShift := GetFixedShiftForButton(Shift, RightButton);
1018 if Assigned(FPoints[clickedPoint].OnMove) then
1019 begin
1020 FPointMoving:= clickedPoint;
1021 FPointWasMoved:= false;
1022 FMovingRightButton:= RightButton;
1023 FPointCoordDelta := FPoints[FPointMoving].Coord - FPrevMousePos;
1024 for i := 0 to FStartMoveHandlers.Count-1 do
1025 FStartMoveHandlers[i](self, FPointMoving, subShift);
1026 end else
1027 begin
1028 for i := 0 to FClickPointHandlers.Count-1 do
1029 FClickPointHandlers[i](self, clickedPoint, subShift);
1030 end;
1031 AHandled:= true;
1032 end;
1033 end;
1034 if FPointMoving <> -1 then
1035 begin
1036 ACursor := GetMoveCursor(FPointMoving);
1037 AHandled:= true;
1038 end
1039 else
1040 ACursor := oecDefault;
1041 end;
1042
1043 procedure TBGRAOriginalEditor.MouseUp(RightButton: boolean; Shift: TShiftState;
1044 ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean);
1045 var
1046 i: Integer;
1047 subShift: TShiftState;
1048 begin
1049 AHandled:= false;
1050 if (RightButton = FMovingRightButton) and (FPointMoving <> -1) then
1051 begin
1052 if not FPointWasMoved then
1053 begin
1054 subShift := GetFixedShiftForButton(Shift, RightButton);
1055 for i := 0 to FClickPointHandlers.Count-1 do
1056 FClickPointHandlers[i](self, FPointMoving, subShift);
1057 end;
1058 FPointMoving:= -1;
1059 AHandled:= true;
1060 end;
1061 ACursor := oecDefault;
1062 end;
1063
1064 procedure TBGRAOriginalEditor.KeyDown(Shift: TShiftState; Key: TSpecialKey; out
1065 AHandled: boolean);
1066 begin
1067 AHandled := false;
1068 end;
1069
1070 procedure TBGRAOriginalEditor.KeyUp(Shift: TShiftState; Key: TSpecialKey; out
1071 AHandled: boolean);
1072 begin
1073 AHandled := false;
1074 end;
1075
1076 procedure TBGRAOriginalEditor.KeyPress(UTF8Key: string; out AHandled: boolean);
1077 begin
1078 AHandled := false;
1079 end;
1080
GetPointAtnull1081 function TBGRAOriginalEditor.GetPointAt(const ACoord: TPointF; ARightButton: boolean): integer;
1082 var v: TPointF;
1083 curDist,newDist: single;
1084 i: Integer;
1085 transfCoord: TPointF;
1086 begin
1087 if ARightButton then
1088 curDist := sqr(2.25*FPointSize)
1089 else
1090 curDist := sqr(1.25*FPointSize);
1091 result := -1;
1092 transfCoord:= Matrix*ACoord;
1093
1094 for i := 0 to high(FPoints) do
1095 if FPoints[i].RightButton = ARightButton then
1096 begin
1097 v := Matrix*FPoints[i].Coord - transfCoord;
1098 newDist := v*v;
1099 if newDist <= curDist then
1100 begin
1101 curDist:= newDist;
1102 result := i;
1103 end;
1104 end;
1105 if result <> -1 then exit;
1106
1107 if not ARightButton then
1108 curDist := sqr(2.25*FPointSize)
1109 else
1110 curDist := sqr(1.25*FPointSize);
1111 for i := 0 to high(FPoints) do
1112 if FPoints[i].RightButton <> ARightButton then
1113 begin
1114 v := Matrix*FPoints[i].Coord - transfCoord;
1115 newDist := v*v;
1116 if newDist <= curDist then
1117 begin
1118 curDist:= newDist;
1119 result := i;
1120 end;
1121 end;
1122
1123 for i := 0 to high(FPoints) do
1124 if (FPoints[i].RightButton = ARightButton)
1125 and FPoints[i].HitBox.Contains(ACoord) then exit(i);
1126
1127 for i := 0 to high(FPoints) do
1128 if (FPoints[i].RightButton <> ARightButton)
1129 and FPoints[i].HitBox.Contains(ACoord) then exit(i);
1130 end;
1131
TBGRAOriginalEditor.Rendernull1132 function TBGRAOriginalEditor.Render(ADest: TBGRABitmap; const ALayoutRect: TRect): TRect;
1133 var
1134 i,j: Integer;
1135 elemRect: TRect;
1136 ptsF: array of TPointF;
1137 begin
1138 result := EmptyRect;
1139 for i := 0 to high(FPoints) do
1140 begin
1141 if isEmptyPointF(FPoints[i].Origin) then
1142 elemRect := RenderPoint(ADest, OriginalCoordToView(FPoints[i].Coord), FPoints[i].RightButton, FPoints[i].Highlighted)
1143 else
1144 elemRect := RenderArrow(ADest, OriginalCoordToView(FPoints[i].Origin), OriginalCoordToView(FPoints[i].Coord));
1145 if not elemRect.IsEmpty then
1146 begin
1147 if result.IsEmpty then
1148 result := elemRect
1149 else
1150 result.Union(elemRect);
1151 end;
1152 end;
1153 for i := 0 to high(FPolylines) do
1154 begin
1155 with FPolylines[i] do
1156 begin
1157 setlength(ptsF, length(Coords));
1158 for j := 0 to high(Coords) do
1159 if IsEmptyPointF(Coords[j]) then
1160 ptsF[j] := EmptyPointF
1161 else
1162 ptsF[j] := OriginalCoordToView(Coords[j]);
1163 elemRect := RenderPolygon(ADest, ptsF, Closed, Style, BackColor);
1164 end;
1165 if not elemRect.IsEmpty then
1166 begin
1167 if result.IsEmpty then
1168 result := elemRect
1169 else
1170 result.Union(elemRect);
1171 end;
1172 end;
1173 end;
1174
GetRenderBoundsnull1175 function TBGRAOriginalEditor.GetRenderBounds(const ALayoutRect: TRect): TRect;
1176 var
1177 i,j: Integer;
1178 elemRect: TRect;
1179 ptsF: array of TPointF;
1180 begin
1181 result := EmptyRect;
1182 for i := 0 to high(FPoints) do
1183 begin
1184 if isEmptyPointF(FPoints[i].Origin) then
1185 elemRect := GetRenderPointBounds(OriginalCoordToView(FPoints[i].Coord), FPoints[i].Highlighted)
1186 else
1187 elemRect := GetRenderArrowBounds(OriginalCoordToView(FPoints[i].Origin), OriginalCoordToView(FPoints[i].Coord));
1188 if not elemRect.IsEmpty then
1189 begin
1190 if result.IsEmpty then
1191 result := elemRect
1192 else
1193 result.Union(elemRect);
1194 end;
1195 end;
1196 for i := 0 to high(FPolylines) do
1197 begin
1198 with FPolylines[i] do
1199 begin
1200 setlength(ptsF, length(Coords));
1201 for j := 0 to high(Coords) do
1202 if IsEmptyPointF(Coords[j]) then
1203 ptsF[j] := EmptyPointF
1204 else
1205 ptsF[j] := OriginalCoordToView(Coords[j]);
1206 elemRect := GetRenderPolygonBounds(ptsF);
1207 end;
1208 if not elemRect.IsEmpty then
1209 begin
1210 if result.IsEmpty then
1211 result := elemRect
1212 else
1213 result.Union(elemRect);
1214 end;
1215 end;
1216 end;
1217
SnapToGridnull1218 function TBGRAOriginalEditor.SnapToGrid(const ACoord: TPointF;
1219 AIsViewCoord: boolean): TPointF;
1220 var
1221 gridCoord: TPointF;
1222 begin
1223 if AIsViewCoord then
1224 gridCoord := FGridMatrixInverse*ViewCoordToOriginal(ACoord)
1225 else
1226 gridCoord := FGridMatrixInverse*ACoord;
1227 gridCoord.x := round(gridCoord.x);
1228 gridCoord.y := round(gridCoord.y);
1229 result := FGridMatrix*gridCoord;
1230 if AIsViewCoord then
1231 result := OriginalCoordToView(result);
1232 end;
1233
TBGRAOriginalEditor.OriginalCoordToViewnull1234 function TBGRAOriginalEditor.OriginalCoordToView(const AImageCoord: TPointF): TPointF;
1235 begin
1236 result := FMatrix*AImageCoord;
1237 end;
1238
TBGRAOriginalEditor.ViewCoordToOriginalnull1239 function TBGRAOriginalEditor.ViewCoordToOriginal(const AViewCoord: TPointF): TPointF;
1240 begin
1241 result := FMatrixInverse*AViewCoord;
1242 end;
1243
1244 { TBGRAMemOriginalStorage }
1245
TBGRAMemOriginalStorage.GetRawStringnull1246 function TBGRAMemOriginalStorage.GetRawString(AName: utf8string): RawByteString;
1247 var
1248 idx: Integer;
1249 begin
1250 if pos('.',AName)<>0 then exit('');
1251 idx := FMemDir.IndexOf(AName,'',true);
1252 if idx = -1 then
1253 result := ''
1254 else if FMemDir.IsDirectory[idx] then
1255 raise exception.Create('This name refers to an object and not an attribute')
1256 else
1257 result := FMemDir.RawString[idx];
1258 end;
1259
1260 procedure TBGRAMemOriginalStorage.SetRawString(AName: utf8string;
1261 AValue: RawByteString);
1262 var
1263 idx: Integer;
1264 begin
1265 if pos('.',AName)<>0 then
1266 raise exception.Create('Attribute name cannot contain "."');
1267 idx := FMemDir.IndexOf(AName,'',true);
1268 if idx = -1 then
1269 FMemDir.Add(AName,'',AValue)
1270 else if FMemDir.IsDirectory[idx] then
1271 raise exception.Create('This name refers to an existing object and so cannot be an attribute')
1272 else
1273 FMemDir.RawString[idx] := AValue;
1274 end;
1275
TBGRAMemOriginalStorage.GetEmptynull1276 function TBGRAMemOriginalStorage.GetEmpty: boolean;
1277 begin
1278 result := FMemDir.Count = 0;
1279 end;
1280
1281 destructor TBGRAMemOriginalStorage.Destroy;
1282 begin
1283 if FMemDirOwned then FreeAndNil(FMemDir);
1284 inherited Destroy;
1285 end;
1286
1287 constructor TBGRAMemOriginalStorage.Create;
1288 begin
1289 inherited Create;
1290 FMemDir := TMemDirectory.Create;
1291 FMemDirOwned:= true;
1292 end;
1293
1294 constructor TBGRAMemOriginalStorage.Create(AMemDir: TMemDirectory; AMemDirOwned: boolean = false);
1295 begin
1296 inherited Create;
1297 FMemDir := AMemDir;
1298 FMemDirOwned:= AMemDirOwned;
1299 end;
1300
TBGRAMemOriginalStorage.Equalsnull1301 function TBGRAMemOriginalStorage.Equals(Obj: TObject): boolean;
1302 var
1303 other: TBGRAMemOriginalStorage;
1304 begin
1305 if not (Obj is TBGRAMemOriginalStorage) then exit(false);
1306 other := TBGRAMemOriginalStorage(obj);
1307 result := FMemDir.Equals(other.FMemDir);
1308 end;
1309
Duplicatenull1310 function TBGRAMemOriginalStorage.Duplicate: TBGRACustomOriginalStorage;
1311 begin
1312 result := TBGRAMemOriginalStorage.Create;
1313 CopyTo(TBGRAMemOriginalStorage(result).FMemDir);
1314 end;
1315
1316 procedure TBGRAMemOriginalStorage.RemoveAttribute(AName: utf8string);
1317 var
1318 idx: Integer;
1319 begin
1320 if pos('.',AName)<>0 then exit;
1321 idx := FMemDir.IndexOf(AName,'',true);
1322 if idx = -1 then exit
1323 else if FMemDir.IsDirectory[idx] then
1324 raise exception.Create('This name refers to an object and not an attribute')
1325 else
1326 FMemDir.Delete(idx);
1327 end;
1328
TBGRAMemOriginalStorage.HasAttributenull1329 function TBGRAMemOriginalStorage.HasAttribute(AName: utf8string): boolean;
1330 var
1331 idx: Integer;
1332 begin
1333 if pos('.',AName)<>0 then exit(false);
1334 idx := FMemDir.IndexOf(AName,'',true);
1335 if idx = -1 then exit(false)
1336 else exit(not FMemDir.IsDirectory[idx]);
1337 end;
1338
1339 procedure TBGRAMemOriginalStorage.RemoveObject(AName: utf8string);
1340 var
1341 idx: Integer;
1342 begin
1343 idx := FMemDir.IndexOf(EntryFilename(AName));
1344 if idx = -1 then exit
1345 else if not FMemDir.IsDirectory[idx] then
1346 raise exception.Create('This name refers to an attribute and not an object')
1347 else
1348 FMemDir.Delete(idx);
1349 end;
1350
CreateObjectnull1351 function TBGRAMemOriginalStorage.CreateObject(AName: utf8string): TBGRACustomOriginalStorage;
1352 var
1353 dirIdx: Integer;
1354 begin
1355 if pos('.',AName)<>0 then
1356 raise exception.Create('An object cannot contain "."');
1357 RemoveObject(AName);
1358 dirIdx := FMemDir.AddDirectory(AName,'');
1359 result := TBGRAMemOriginalStorage.Create(FMemDir.Directory[dirIdx]);
1360 end;
1361
TBGRAMemOriginalStorage.OpenObjectnull1362 function TBGRAMemOriginalStorage.OpenObject(AName: utf8string): TBGRACustomOriginalStorage;
1363 var
1364 dir: TMemDirectory;
1365 begin
1366 if pos('.',AName)<>0 then
1367 raise exception.Create('An object cannot contain "."');
1368 dir := FMemDir.FindPath(AName);
1369 if dir = nil then
1370 result := nil
1371 else
1372 result := TBGRAMemOriginalStorage.Create(dir);
1373 end;
1374
ObjectExistsnull1375 function TBGRAMemOriginalStorage.ObjectExists(AName: utf8string): boolean;
1376 var
1377 dir: TMemDirectory;
1378 begin
1379 if pos('.',AName)<>0 then exit(false);
1380 dir := FMemDir.FindPath(AName);
1381 result:= Assigned(dir);
1382 end;
1383
1384 procedure TBGRAMemOriginalStorage.EnumerateObjects(AList: TStringList);
1385 var
1386 i: Integer;
1387 begin
1388 for i := 0 to FMemDir.Count-1 do
1389 if FMemDir.IsDirectory[i] then
1390 AList.Add(FMemDir.Entry[i].Name);
1391 end;
1392
1393 procedure TBGRAMemOriginalStorage.EnumerateFiles(AList: TStringList);
1394 var
1395 i: Integer;
1396 begin
1397 for i := 0 to FMemDir.Count-1 do
1398 if not FMemDir.IsDirectory[i] then
1399 AList.Add(FMemDir.Entry[i].Name);
1400 end;
1401
1402 procedure TBGRAMemOriginalStorage.RemoveFile(AName: utf8string);
1403 var
1404 idx: Integer;
1405 begin
1406 idx := FMemDir.IndexOf(EntryFilename(AName));
1407 if idx = -1 then exit
1408 else if FMemDir.IsDirectory[idx] then
1409 raise exception.Create('This name refers to an object and not a file')
1410 else
1411 FMemDir.Delete(idx);
1412 end;
1413
GetFileStreamnull1414 function TBGRAMemOriginalStorage.GetFileStream(AName: UTF8String): TStream;
1415 var
1416 entryId: Integer;
1417 begin
1418 entryId := FMemDir.IndexOf(EntryFilename(AName));
1419 if (entryId <> -1) and not FMemDir.IsDirectory[entryId] then
1420 begin
1421 with FMemDir.Entry[entryId] do
1422 result := GetStream;
1423 end
1424 else
1425 result := nil;
1426 end;
1427
ReadBitmapnull1428 function TBGRAMemOriginalStorage.ReadBitmap(AName: UTF8String;
1429 ADest: TCustomUniversalBitmap): boolean;
1430 var
1431 entryId: Integer;
1432 stream: TStream;
1433 begin
1434 entryId := FMemDir.IndexOf(EntryFilename(AName));
1435 if (entryId <> -1) and not FMemDir.IsDirectory[entryId] then
1436 begin
1437 if FMemDir.IsEntryCompressed[entryId] then
1438 begin
1439 stream := TMemoryStream.Create;
1440 try
1441 with FMemDir.Entry[entryId] do
1442 begin
1443 if CopyTo(stream) <> FileSize then
1444 result := false
1445 else
1446 begin
1447 stream.Position:= 0;
1448 ADest.LoadFromStream(stream);
1449 result := true;
1450 end;
1451 end;
1452 finally
1453 stream.Free;
1454 end;
1455 end else
1456 with FMemDir.Entry[entryId] do
1457 begin
1458 stream := GetStream;
1459 stream.Position:= 0;
1460 ADest.LoadFromStream(stream);
1461 result := true;
1462 end;
1463 end
1464 else
1465 result := false;
1466 end;
1467
TBGRAMemOriginalStorage.ReadFilenull1468 function TBGRAMemOriginalStorage.ReadFile(AName: UTF8String; ADest: TStream): boolean;
1469 var
1470 entryId: Integer;
1471 begin
1472 entryId := FMemDir.IndexOf(EntryFilename(AName));
1473 if (entryId <> -1) and not FMemDir.IsDirectory[entryId] then
1474 begin
1475 with FMemDir.Entry[entryId] do
1476 result := CopyTo(ADest) = FileSize
1477 end
1478 else
1479 result := false;
1480 end;
1481
1482 procedure TBGRAMemOriginalStorage.WriteFile(AName: UTF8String; ASource: TStream; ACompress: boolean; AOwnStream: boolean);
1483 var
1484 idxEntry: Integer;
1485 begin
1486 idxEntry := FMemDir.Add(EntryFilename(AName), ASource, true, AOwnStream);
1487 if ACompress then FMemDir.IsEntryCompressed[idxEntry] := true;
1488 end;
1489
TBGRAMemOriginalStorage.FileExistsnull1490 function TBGRAMemOriginalStorage.FileExists(AName: UTF8String): boolean;
1491 var
1492 entryId: Integer;
1493 begin
1494 entryId := FMemDir.IndexOf(EntryFilename(AName));
1495 result := (entryId <> -1) and not FMemDir.IsDirectory[entryId];
1496 end;
1497
1498 procedure TBGRAMemOriginalStorage.SaveToStream(AStream: TStream);
1499 begin
1500 FMemDir.SaveToStream(AStream);
1501 end;
1502
1503 procedure TBGRAMemOriginalStorage.LoadFromStream(AStream: TStream);
1504 begin
1505 FMemDir.LoadFromStream(AStream);
1506 end;
1507
1508 procedure TBGRAMemOriginalStorage.LoadFromResource(AFilename: string);
1509 begin
1510 FMemDir.LoadFromResource(AFilename);
1511 end;
1512
1513 procedure TBGRAMemOriginalStorage.CopyTo(AMemDir: TMemDirectory);
1514 begin
1515 FMemDir.CopyTo(AMemDir, true);
1516 end;
1517
1518 { TBGRACustomOriginalStorage }
1519
GetColornull1520 function TBGRACustomOriginalStorage.GetColor(AName: UTF8String): TBGRAPixel;
1521 begin
1522 result := StrToBGRA(RawString[AName], BGRAPixelTransparent);
1523 end;
1524
1525 procedure TBGRACustomOriginalStorage.SetColor(AName: UTF8String;
1526 AValue: TBGRAPixel);
1527 begin
1528 RawString[AName] := LowerCase(BGRAToStr(AValue, CSSColors));
1529 end;
1530
TBGRACustomOriginalStorage.GetDelimiternull1531 function TBGRACustomOriginalStorage.GetDelimiter: char;
1532 begin
1533 if FFormats.DecimalSeparator = ',' then
1534 result := ';' else result := ',';
1535 end;
1536
GetRectFnull1537 function TBGRACustomOriginalStorage.GetRectF(AName: utf8string): TRectF;
1538 var
1539 a: array of Single;
1540 begin
1541 a := FloatArray[AName];
1542 if length(a)<4 then
1543 result := EmptyRectF
1544 else
1545 begin
1546 result.Left := a[0];
1547 result.Top := a[1];
1548 result.Right := a[2];
1549 result.Bottom := a[3];
1550 end;
1551 end;
1552
1553 procedure TBGRACustomOriginalStorage.SetRectF(AName: utf8string; AValue: TRectF);
1554 var
1555 a: array of Single;
1556 begin
1557 setlength(a,4);
1558 a[0] := AValue.Left;
1559 a[1] := AValue.Top;
1560 a[2] := AValue.Right;
1561 a[3] := AValue.Bottom;
1562 FloatArray[AName] := a;
1563 end;
1564
TBGRACustomOriginalStorage.GetAffineMatrixnull1565 function TBGRACustomOriginalStorage.GetAffineMatrix(AName: utf8string): TAffineMatrix;
1566 var
1567 stream: TMemoryStream;
1568 begin
1569 stream:= TMemoryStream.Create;
1570 if ReadFile(AName, stream) and (stream.Size >= sizeof(result)) then
1571 begin
1572 stream.Position:= 0;
1573 {$PUSH}{$HINTS OFF}stream.ReadBuffer({%H-}result, sizeof({%H-}result));{$POP}
1574 LongWord(result[1,1]) := NtoLE(LongWord(result[1,1]));
1575 LongWord(result[2,1]) := NtoLE(LongWord(result[2,1]));
1576 LongWord(result[1,2]) := NtoLE(LongWord(result[1,2]));
1577 LongWord(result[2,2]) := NtoLE(LongWord(result[2,2]));
1578 LongWord(result[1,3]) := NtoLE(LongWord(result[1,3]));
1579 LongWord(result[2,3]) := NtoLE(LongWord(result[2,3]));
1580 end else
1581 result := AffineMatrixIdentity;
1582 stream.Free;
1583 end;
1584
1585 procedure TBGRACustomOriginalStorage.SetAffineMatrix(AName: utf8string;
1586 const AValue: TAffineMatrix);
1587 var
1588 stream: TMemoryStream;
1589 begin
1590 stream:= TMemoryStream.Create;
1591 stream.WriteBuffer(AValue, sizeof(AValue));
1592 WriteFile(AName,stream,false,true);
1593 end;
1594
GetRectnull1595 function TBGRACustomOriginalStorage.GetRect(AName: utf8string): TRect;
1596 var
1597 rF: TRectF;
1598 begin
1599 rF := RectangleF[AName];
1600 result := rect(round(rF.Left),round(rF.Top),round(rF.Right),round(rF.Bottom));
1601 end;
1602
1603 procedure TBGRACustomOriginalStorage.SetRect(AName: utf8string; AValue: TRect);
1604 var
1605 rF: TRectF;
1606 begin
1607 rF := rectF(AValue.Left,AValue.Top,AValue.Right,AValue.Bottom);
1608 RectangleF[AName] := rF;
1609 end;
1610
TBGRACustomOriginalStorage.GetBoolDefnull1611 function TBGRACustomOriginalStorage.GetBoolDef(AName: utf8string;
1612 ADefault: boolean): boolean;
1613 begin
1614 if RawString[AName] = 'true' then result := true
1615 else if RawString[AName] = 'false' then result := false
1616 else result := ADefault;
1617 end;
1618
TBGRACustomOriginalStorage.GetBoolnull1619 function TBGRACustomOriginalStorage.GetBool(AName: utf8string): boolean;
1620 begin
1621 result := GetBoolDef(AName, false);
1622 end;
1623
GetSingleArraynull1624 function TBGRACustomOriginalStorage.GetSingleArray(AName: utf8string): ArrayOfSingle;
1625 var
1626 textVal: String;
1627 values: TStringList;
1628 i: Integer;
1629 begin
1630 textVal := Trim(RawString[AName]);
1631 if textVal = '' then exit(nil);
1632 values := TStringList.Create;
1633 values.StrictDelimiter := true;
1634 values.Delimiter:= GetDelimiter;
1635 values.DelimitedText:= textVal;
1636 setlength(result, values.Count);
1637 for i := 0 to high(result) do
1638 if CompareText(values[i],'none')=0 then
1639 result[i] := EmptySingle
1640 else
1641 result[i] := StrToFloatDef(values[i], 0, FFormats);
1642 values.Free;
1643 end;
1644
TBGRACustomOriginalStorage.GetColorArraynull1645 function TBGRACustomOriginalStorage.GetColorArray(AName: UTF8String
1646 ): ArrayOfTBGRAPixel;
1647 var colorNames: TStringList;
1648 i: Integer;
1649 begin
1650 colorNames := TStringList.Create;
1651 colorNames.StrictDelimiter := true;
1652 colorNames.Delimiter:= GetDelimiter;
1653 colorNames.DelimitedText:= RawString[AName];
1654 setlength(result, colorNames.Count);
1655 for i := 0 to high(result) do
1656 result[i] := StrToBGRA(colorNames[i],BGRAPixelTransparent);
1657 colorNames.Free;
1658 end;
1659
GetIntegerDefnull1660 function TBGRACustomOriginalStorage.GetIntegerDef(AName: utf8string;
1661 ADefault: integer): integer;
1662 begin
1663 result := StrToIntDef(RawString[AName],ADefault);
1664 end;
1665
TBGRACustomOriginalStorage.GetSingleDefnull1666 function TBGRACustomOriginalStorage.GetSingleDef(AName: utf8string;
1667 ADefault: single): single;
1668 begin
1669 result := StrToFloatDef(RawString[AName], ADefault, FFormats);
1670 end;
1671
1672 procedure TBGRACustomOriginalStorage.SetBool(AName: utf8string; AValue: boolean);
1673 begin
1674 RawString[AName] := BoolToStr(AValue,'true','false');
1675 end;
1676
1677 procedure TBGRACustomOriginalStorage.SetSingleArray(AName: utf8string;
1678 AValue: ArrayOfSingle);
1679 var
1680 values: TStringList;
1681 i: Integer;
1682 begin
1683 values:= TStringList.Create;
1684 values.StrictDelimiter:= true;
1685 values.Delimiter:= GetDelimiter;
1686 for i := 0 to high(AValue) do
1687 if AValue[i] = EmptySingle then
1688 values.Add('none')
1689 else
1690 values.Add(FloatToStr(AValue[i], FFormats));
1691 RawString[AName] := values.DelimitedText;
1692 values.Free;
1693 end;
1694
1695 procedure TBGRACustomOriginalStorage.SetColorArray(AName: UTF8String;
1696 AValue: ArrayOfTBGRAPixel);
1697 var colorNames: TStringList;
1698 i: Integer;
1699 begin
1700 colorNames := TStringList.Create;
1701 colorNames.StrictDelimiter := true;
1702 colorNames.Delimiter:= GetDelimiter;
1703 for i := 0 to high(AValue) do
1704 colorNames.Add(LowerCase(BGRAToStr(AValue[i], CSSColors)));
1705 RawString[AName] := colorNames.DelimitedText;
1706 colorNames.Free;
1707 end;
1708
TBGRACustomOriginalStorage.GetIntegernull1709 function TBGRACustomOriginalStorage.GetInteger(AName: utf8string): integer;
1710 begin
1711 result := GetIntegerDef(AName,0);
1712 end;
1713
TBGRACustomOriginalStorage.GetPointFnull1714 function TBGRACustomOriginalStorage.GetPointF(AName: utf8string): TPointF;
1715 var
1716 s: String;
1717 posComma: integer;
1718 begin
1719 s := RawString[AName];
1720 posComma := pos(GetDelimiter,s);
1721 if posComma = 0 then
1722 exit(EmptyPointF);
1723
1724 result.x := StrToFloat(copy(s,1,posComma-1), FFormats);
1725 result.y := StrToFloat(copy(s,posComma+1,length(s)-posComma), FFormats);
1726 end;
1727
TBGRACustomOriginalStorage.GetSinglenull1728 function TBGRACustomOriginalStorage.GetSingle(AName: utf8string): single;
1729 begin
1730 result := GetSingleDef(AName, EmptySingle);
1731 end;
1732
1733 procedure TBGRACustomOriginalStorage.SetInteger(AName: utf8string;
1734 AValue: integer);
1735 begin
1736 RawString[AName] := IntToStr(AValue);
1737 end;
1738
1739 procedure TBGRACustomOriginalStorage.SetPointF(AName: utf8string;
1740 AValue: TPointF);
1741 begin
1742 if isEmptyPointF(AValue) then RemoveAttribute(AName)
1743 else RawString[AName] := FloatToStrF(AValue.x, ffGeneral,7,3, FFormats)+GetDelimiter+FloatToStrF(AValue.y, ffGeneral,7,3, FFormats);
1744 end;
1745
1746 procedure TBGRACustomOriginalStorage.SetSingle(AName: utf8string; AValue: single);
1747 begin
1748 if AValue = EmptySingle then RemoveAttribute(AName)
1749 else RawString[AName] := FloatToStrF(AValue, ffGeneral,7,3, FFormats);
1750 end;
1751
1752 constructor TBGRACustomOriginalStorage.Create;
1753 begin
1754 FFormats := DefaultFormatSettings;
1755 FFormats.DecimalSeparator := '.';
1756 end;
1757
FloatEqualsnull1758 function TBGRACustomOriginalStorage.FloatEquals(AName: utf8string;
1759 AValue: single): boolean;
1760 var
1761 curValue: Single;
1762 begin
1763 curValue := Float[AName];
1764 if curValue = EmptySingle then
1765 result := (AValue = EmptySingle) else
1766 if AValue = EmptySingle then
1767 result := false else
1768 result := (FloatToStrF(AValue, ffGeneral,7,3, FFormats) =
1769 FloatToStrF(curValue, ffGeneral,7,3, FFormats));
1770 end;
1771
TBGRACustomOriginalStorage.PointFEqualsnull1772 function TBGRACustomOriginalStorage.PointFEquals(AName: utf8string;
1773 const AValue: TPointF): boolean;
1774 var
1775 curValue: TPointF;
1776 begin
1777 curValue := PointF[AName];
1778 if isEmptyPointF(curValue) then
1779 result := isEmptyPointF(AValue) else
1780 if isEmptyPointF(AValue) then
1781 result := False else
1782 result := (FloatToStrF(AValue.x, ffGeneral,7,3, FFormats) =
1783 FloatToStrF(curValue.x, ffGeneral,7,3, FFormats)) and
1784 (FloatToStrF(AValue.y, ffGeneral,7,3, FFormats) =
1785 FloatToStrF(curValue.y, ffGeneral,7,3, FFormats));
1786 end;
1787
AffineMatrixEqualsnull1788 function TBGRACustomOriginalStorage.AffineMatrixEquals(AName: utf8string;
1789 const AValue: TAffineMatrix): boolean;
1790 begin
1791 result := (AffineMatrix[AName] = AValue);
1792 end;
1793
1794 { TBGRALayerCustomOriginal }
1795
1796 procedure TBGRALayerCustomOriginal.SetOnChange(AValue: TOriginalChangeEvent);
1797 begin
1798 if FOnChange=AValue then Exit;
1799 FOnChange:=AValue;
1800 end;
1801
TBGRALayerCustomOriginal.GetDiffExpectednull1802 function TBGRALayerCustomOriginal.GetDiffExpected: boolean;
1803 begin
1804 result := Assigned(FOnChange);
1805 end;
1806
1807 procedure TBGRALayerCustomOriginal.SetRenderStorage(AValue: TBGRACustomOriginalStorage);
1808 begin
1809 if FRenderStorage=AValue then Exit;
1810 FRenderStorage:=AValue;
1811 end;
1812
GetGuidnull1813 function TBGRALayerCustomOriginal.GetGuid: TGuid;
1814 begin
1815 result := FGuid;
1816 end;
1817
1818 procedure TBGRALayerCustomOriginal.SetGuid(AValue: TGuid);
1819 begin
1820 FGuid := AValue;
1821 end;
1822
1823 procedure TBGRALayerCustomOriginal.NotifyChange(ADiff: TBGRAOriginalDiff);
1824 begin
1825 if Assigned(FOnChange) then
1826 FOnChange(self, nil, ADiff);
1827 ADiff.Free;
1828 end;
1829
1830 procedure TBGRALayerCustomOriginal.NotifyChange(ABounds: TRectF; ADiff: TBGRAOriginalDiff);
1831 begin
1832 if Assigned(FOnChange) then
1833 FOnChange(self, @ABounds, ADiff);
1834 ADiff.Free;
1835 end;
1836
1837 procedure TBGRALayerCustomOriginal.NotifyEditorChange;
1838 begin
1839 if Assigned(FOnEditingChange) then
1840 FOnEditingChange(self);
1841 end;
1842
1843 constructor TBGRALayerCustomOriginal.Create;
1844 begin
1845 FGuid := GUID_NULL;
1846 FRenderStorage := nil;
1847 end;
1848
1849 destructor TBGRALayerCustomOriginal.Destroy;
1850 begin
1851 inherited Destroy;
1852 end;
1853
1854 procedure TBGRALayerCustomOriginal.Render(ADest: TBGRABitmap;
1855 AMatrix: TAffineMatrix; ADraft: boolean);
1856 begin
1857 Render(ADest, Point(0,0), AMatrix, ADraft);
1858 end;
1859
1860 procedure TBGRALayerCustomOriginal.Render(ADest: TBGRABitmap;
1861 ARenderOffset: TPoint; AMatrix: TAffineMatrix; ADraft: boolean);
1862 begin
1863 Render(ADest, AffineMatrixTranslation(ARenderOffset.X, ARenderOffset.Y)*AMatrix, ADraft);
1864 end;
1865
1866 procedure TBGRALayerCustomOriginal.ConfigureEditor(AEditor: TBGRAOriginalEditor);
1867 begin
1868 //nothing
1869 end;
1870
1871 procedure TBGRALayerCustomOriginal.LoadFromFile(AFilenameUTF8: string);
1872 var
1873 s: TFileStreamUTF8;
1874 begin
1875 s := TFileStreamUTF8.Create(AFilenameUTF8, fmOpenRead, fmShareDenyWrite);
1876 try
1877 LoadFromStream(s);
1878 finally
1879 s.Free;
1880 end;
1881 end;
1882
1883 procedure TBGRALayerCustomOriginal.LoadFromStream(AStream: TStream);
1884 var storage: TBGRAMemOriginalStorage;
1885 memDir: TMemDirectory;
1886 begin
1887 memDir := TMemDirectory.Create;
1888 storage := nil;
1889 try
1890 memDir.LoadFromStream(AStream);
1891 storage := TBGRAMemOriginalStorage.Create(memDir);
1892 if storage.RawString['class'] <> StorageClassName then
1893 raise exception.Create('Invalid class');
1894 LoadFromStorage(storage);
1895 FreeAndNil(storage);
1896 finally
1897 storage.Free;
1898 memDir.Free;
1899 end;
1900 end;
1901
1902 procedure TBGRALayerCustomOriginal.LoadFromResource(AFilename: string);
1903 var
1904 stream: TStream;
1905 begin
1906 stream := BGRAResource.GetResourceStream(AFilename);
1907 try
1908 LoadFromStream(stream);
1909 finally
1910 stream.Free;
1911 end;
1912 end;
1913
1914 procedure TBGRALayerCustomOriginal.SaveToFile(AFilenameUTF8: string);
1915 var
1916 s: TFileStreamUTF8;
1917 begin
1918 s := TFileStreamUTF8.Create(AFilenameUTF8, fmCreate);
1919 try
1920 SaveToStream(s);
1921 finally
1922 s.Free;
1923 end;
1924 end;
1925
1926 procedure TBGRALayerCustomOriginal.SaveToStream(AStream: TStream);
1927 var storage: TBGRAMemOriginalStorage;
1928 memDir: TMemDirectory;
1929 begin
1930 memDir := TMemDirectory.Create;
1931 storage := nil;
1932 try
1933 storage := TBGRAMemOriginalStorage.Create(memDir);
1934 storage.RawString['class'] := StorageClassName;
1935 SaveToStorage(storage);
1936 FreeAndNil(storage);
1937 memDir.SaveToStream(AStream);
1938 finally
1939 storage.Free;
1940 memDir.Free;
1941 end;
1942 end;
1943
TBGRALayerCustomOriginal.CreateEditornull1944 function TBGRALayerCustomOriginal.CreateEditor: TBGRAOriginalEditor;
1945 begin
1946 result := TBGRAOriginalEditor.Create;
1947 end;
1948
TBGRALayerCustomOriginal.CanConvertToSVGnull1949 class function TBGRALayerCustomOriginal.CanConvertToSVG: boolean;
1950 begin
1951 result := false;
1952 end;
1953
TBGRALayerCustomOriginal.IsInfiniteSurfacenull1954 function TBGRALayerCustomOriginal.IsInfiniteSurface: boolean;
1955 begin
1956 result := false;
1957 end;
1958
ConvertToSVGnull1959 function TBGRALayerCustomOriginal.ConvertToSVG(const AMatrix: TAffineMatrix; out AOffset: TPoint): TObject;
1960 begin
1961 AOffset := Point(0,0);
1962 raise exception.Create('Not implemented');
1963 end;
1964
Duplicatenull1965 function TBGRALayerCustomOriginal.Duplicate: TBGRALayerCustomOriginal;
1966 var
1967 storage: TBGRAMemOriginalStorage;
1968 c: TBGRALayerOriginalAny;
1969 begin
1970 c := FindLayerOriginalClass(StorageClassName);
1971 if c = nil then raise exception.Create('Original class is not registered');
1972 storage := TBGRAMemOriginalStorage.Create;
1973 try
1974 SaveToStorage(storage);
1975 result := c.Create;
1976 result.LoadFromStorage(storage);
1977 finally
1978 storage.Free;
1979 end;
1980 end;
1981
1982 { TBGRALayerImageOriginal }
1983
GetImageHeightnull1984 function TBGRALayerImageOriginal.GetImageHeight: integer;
1985 begin
1986 if Assigned(FImage) then
1987 result := FImage.Height
1988 else
1989 result := 0;
1990 end;
1991
TBGRALayerImageOriginal.GetImageWidthnull1992 function TBGRALayerImageOriginal.GetImageWidth: integer;
1993 begin
1994 if Assigned(FImage) then
1995 result := FImage.Width
1996 else
1997 result := 0;
1998 end;
1999
2000 procedure TBGRALayerImageOriginal.BeginUpdate;
2001 begin
2002 if DiffExpected and (FDiff=nil) then
2003 FDiff := TBGRAImageOriginalDiff.Create(self);
2004 end;
2005
2006 procedure TBGRALayerImageOriginal.EndUpdate;
2007 begin
2008 if Assigned(FDiff) then FDiff.ComputeDiff(self);
2009 NotifyChange(FDiff);
2010 FDiff := nil;
2011 end;
2012
2013 procedure TBGRALayerImageOriginal.InternalLoadImageFromStream(AStream: TStream; AUpdate: boolean);
2014 var
2015 newJpegStream: TMemoryStream;
2016 newImage: TBGRABitmap;
2017 begin
2018 if DetectFileFormat(AStream) = ifJpeg then
2019 begin
2020 newJpegStream := TMemoryStream.Create;
2021 try
2022 newJpegStream.CopyFrom(AStream, AStream.Size);
2023 newJpegStream.Position := 0;
2024 newImage := TBGRABitmap.Create(newJpegStream);
2025 if AUpdate then BeginUpdate;
2026 InternalClear;
2027 FImage := newImage;
2028 FJpegStream := newJpegStream;
2029 newImage := nil;
2030 newJpegStream := nil;
2031 if AUpdate then
2032 begin
2033 Inc(FContentVersion);
2034 EndUpdate;
2035 end;
2036 finally
2037 newJpegStream.Free;
2038 newImage.Free;
2039 end;
2040 end else
2041 begin
2042 newImage := TBGRABitmap.Create(AStream);
2043 if AUpdate then BeginUpdate;
2044 InternalClear;
2045 FImage := newImage;
2046 if AUpdate then
2047 begin
2048 Inc(FContentVersion);
2049 EndUpdate;
2050 end;
2051 end;
2052 end;
2053
2054 procedure TBGRALayerImageOriginal.InternalClear;
2055 begin
2056 if Assigned(FImage) then
2057 begin
2058 FImage.FreeReference;
2059 FImage := nil
2060 end;
2061 FreeAndNil(FJpegStream);
2062 end;
2063
2064 constructor TBGRALayerImageOriginal.Create;
2065 begin
2066 inherited Create;
2067 FImage := nil;
2068 FContentVersion := 0;
2069 FJpegStream := nil;
2070 end;
2071
2072 destructor TBGRALayerImageOriginal.Destroy;
2073 begin
2074 FImage.FreeReference;
2075 FJpegStream.Free;
2076 FDiff.Free;
2077 inherited Destroy;
2078 end;
2079
ConvertToSVGnull2080 function TBGRALayerImageOriginal.ConvertToSVG(const AMatrix: TAffineMatrix; out AOffset: TPoint): TObject;
2081 var
2082 svg: TBGRASVG;
2083 img: TSVGImage;
2084 begin
2085 svg := TBGRASVG.Create(Width, Height, cuPixel);
2086 Result:= svg;
2087 AOffset := Point(0,0);
2088 if Assigned(FJpegStream) then
2089 img := svg.Content.AppendImage(0,0,Width,Height,FJpegStream,'image/jpeg') else
2090 if Assigned(FImage) then
2091 img := svg.Content.AppendImage(0,0,Width,Height,FImage,false);
2092 img.matrix[cuCustom] := AMatrix;
2093 end;
2094
2095 procedure TBGRALayerImageOriginal.Render(ADest: TBGRABitmap;
2096 AMatrix: TAffineMatrix; ADraft: boolean);
2097 var resampleFilter: TResampleFilter;
2098 begin
2099 if ADraft then resampleFilter := rfBox else resampleFilter:= rfCosine;
2100 if Assigned(FImage) then
2101 ADest.PutImageAffine(AMatrix, FImage, resampleFilter, dmSet);
2102 end;
2103
GetRenderBoundsnull2104 function TBGRALayerImageOriginal.GetRenderBounds(ADestRect: TRect;
2105 AMatrix: TAffineMatrix): TRect;
2106 var
2107 aff: TAffineBox;
2108 begin
2109 if Assigned(FImage) then
2110 begin
2111 aff := AMatrix*TAffineBox.AffineBox(PointF(0,0),PointF(FImage.Width,0),PointF(0,FImage.Height));
2112 result := aff.RectBounds;
2113 end else
2114 result := EmptyRect;
2115 end;
2116
2117 procedure TBGRALayerImageOriginal.LoadFromStorage(
2118 AStorage: TBGRACustomOriginalStorage);
2119 var imgStream: TMemoryStream;
2120 newImage: TBGRABitmap;
2121 begin
2122 imgStream := TMemoryStream.Create;
2123 try
2124 if AStorage.ReadFile('content.png', imgStream) then
2125 begin
2126 imgStream.Position:= 0;
2127 newImage := TBGRABitmap.Create(imgStream);
2128 InternalClear;
2129 FImage := newImage;
2130 end else
2131 if AStorage.ReadFile('content.jpg', imgStream) then
2132 begin
2133 imgStream.Position:= 0;
2134 newImage := TBGRABitmap.Create(imgStream);
2135 InternalClear;
2136 FImage := newImage;
2137 FJpegStream := imgStream;
2138 imgStream:= nil;
2139 end else
2140 InternalClear;
2141 FContentVersion := AStorage.Int['content-version'];
2142 finally
2143 imgStream.Free;
2144 end;
2145 end;
2146
2147 procedure TBGRALayerImageOriginal.SaveToStorage(
2148 AStorage: TBGRACustomOriginalStorage);
2149 var imgStream: TMemoryStream;
2150 begin
2151 if Assigned(FImage) then
2152 begin
2153 if FContentVersion > AStorage.Int['content-version'] then
2154 begin
2155 if Assigned(FJpegStream) then
2156 begin
2157 AStorage.WriteFile('content.jpg', FJpegStream, false);
2158 AStorage.RemoveFile('content.png');
2159 AStorage.Int['content-version'] := FContentVersion;
2160 end else
2161 begin
2162 imgStream := TMemoryStream.Create;
2163 try
2164 FImage.SaveToStreamAsPng(imgStream);
2165 AStorage.RemoveFile('content.jpg');
2166 AStorage.WriteFile('content.png', imgStream, false);
2167 AStorage.Int['content-version'] := FContentVersion;
2168 finally
2169 imgStream.Free;
2170 end;
2171 end;
2172 end;
2173 end else
2174 begin
2175 AStorage.RemoveFile('content.jpg');
2176 AStorage.RemoveFile('content.png');
2177 AStorage.Int['content-version'] := FContentVersion;
2178 end;
2179 end;
2180
2181 procedure TBGRALayerImageOriginal.LoadFromStream(AStream: TStream);
2182 begin
2183 if TMemDirectory.CheckHeader(AStream) then
2184 inherited LoadFromStream(AStream)
2185 else
2186 begin
2187 InternalLoadImageFromStream(AStream, False);
2188 inc(FContentVersion);
2189 end;
2190 end;
2191
2192 procedure TBGRALayerImageOriginal.Clear;
2193 begin
2194 BeginUpdate;
2195 InternalClear;
2196 Inc(FContentVersion);
2197 EndUpdate;
2198 end;
2199
2200 procedure TBGRALayerImageOriginal.LoadImageFromStream(AStream: TStream);
2201 begin
2202 InternalLoadImageFromStream(AStream, True);
2203 end;
2204
2205 procedure TBGRALayerImageOriginal.SaveImageToStream(AStream: TStream);
2206 begin
2207 if Assigned(FJpegStream) then
2208 begin
2209 FJpegStream.Position := 0;
2210 if AStream.CopyFrom(FJpegStream, FJpegStream.Size)<>FJpegStream.Size then
2211 raise exception.Create('Error while saving');
2212 end else
2213 if Assigned(FImage) then
2214 FImage.SaveToStreamAsPng(AStream)
2215 else raise exception.Create('No image to be saved');
2216 end;
2217
2218 procedure TBGRALayerImageOriginal.AssignImage(AImage: TBGRACustomBitmap);
2219 var
2220 newImage: TBGRABitmap;
2221 begin
2222 newImage := TBGRABitmap.Create;
2223 newImage.Assign(AImage);
2224 BeginUpdate;
2225 InternalClear;
2226 FImage := newImage;
2227 Inc(FContentVersion);
2228 EndUpdate;
2229 end;
2230
GetImageCopynull2231 function TBGRALayerImageOriginal.GetImageCopy: TBGRABitmap;
2232 begin
2233 if FImage = nil then result := nil
2234 else result := FImage.Duplicate;
2235 end;
2236
TBGRALayerImageOriginal.StorageClassNamenull2237 class function TBGRALayerImageOriginal.StorageClassName: RawByteString;
2238 begin
2239 result := 'image';
2240 end;
2241
TBGRALayerImageOriginal.CanConvertToSVGnull2242 class function TBGRALayerImageOriginal.CanConvertToSVG: boolean;
2243 begin
2244 Result:= true;
2245 end;
2246
2247 initialization
2248
2249 RegisterLayerOriginal(TBGRALayerImageOriginal);
2250
2251 end.
2252
2253