source: trunk/Packages/bgrabitmap/bgralayeroriginal.pas

Last change on this file was 2, checked in by chronos, 6 years ago
File size: 47.3 KB
Line 
1unit BGRALayerOriginal;
2
3{$mode objfpc}{$H+}
4{$i bgrabitmap.inc}
5
6interface
7
8uses
9 Classes, SysUtils, BGRABitmap, BGRABitmapTypes, BGRATransform, BGRAMemDirectory, fgl
10 {$IFDEF BGRABITMAP_USE_LCL},LCLType{$ENDIF};
11
12type
13 PRectF = BGRABitmapTypes.PRectF;
14 TAffineMatrix = BGRATransform.TAffineMatrix;
15 TBGRALayerCustomOriginal = class;
16 TBGRALayerOriginalAny = class of TBGRALayerCustomOriginal;
17 TOriginalMovePointEvent = procedure(ASender: TObject; APrevCoord, ANewCoord: TPointF; AShift: TShiftState) of object;
18 TOriginalStartMovePointEvent = procedure(ASender: TObject; AIndex: integer; AShift: TShiftState) of object;
19 TOriginalClickPointEvent = procedure(ASender: TObject; AIndex: integer; AShift: TShiftState) of object;
20 TOriginalHoverPointEvent = procedure(ASender: TObject; AIndex: integer) of object;
21 TOriginalChangeEvent = procedure(ASender: TObject; ABounds: PRectF = nil) of object;
22 TOriginalEditingChangeEvent = procedure(ASender: TObject) of object;
23 TOriginalEditorCursor = (oecDefault, oecMove, oecMoveW, oecMoveE, oecMoveN, oecMoveS,
24 oecMoveNE, oecMoveSW, oecMoveNW, oecMoveSE, oecHandPoint);
25 TSpecialKey = (skUnknown, skBackspace, skTab, skReturn, skEscape,
26 skPageUp, skPageDown, skHome, skEnd,
27 skLeft, skUp, skRight, skDown,
28 skInsert, skDelete,
29 skNum0, skNum1, skNum2, skNum3, skNum4, skNum5, skNum6, skNum7, skNum8, skNum9,
30 skF1, skF2, skF3, skF4, skF5, skF6, skF7, skF8, skF9, skF10, skF11, skF12);
31
32{$IFDEF BGRABITMAP_USE_LCL}
33const
34 SpecialKeyToLCL: array[TSpecialKey] of Word =
35 (VK_UNKNOWN, VK_BACK,VK_TAB,VK_RETURN,VK_ESCAPE,
36 VK_PRIOR,VK_NEXT,VK_HOME,VK_END,
37 VK_LEFT,VK_UP,VK_RIGHT,VK_DOWN,
38 VK_INSERT,VK_DELETE,
39 VK_NUMPAD0,VK_NUMPAD1,VK_NUMPAD2,VK_NUMPAD3,VK_NUMPAD4,VK_NUMPAD5,VK_NUMPAD6,VK_NUMPAD7,VK_NUMPAD8,VK_NUMPAD9,
40 VK_F1,VK_F2,VK_F3,VK_F4,VK_F5,VK_F6,VK_F7,VK_F8,VK_F9,VK_F10,VK_F11,VK_F12);
41{$ENDIF}
42
43type
44 TStartMoveHandlers = specialize TFPGList<TOriginalStartMovePointEvent>;
45 TClickPointHandlers = specialize TFPGList<TOriginalClickPointEvent>;
46 THoverPointHandlers = specialize TFPGList<TOriginalHoverPointEvent>;
47 TBGRAOriginalPolylineStyle = (opsNone, opsSolid, opsDash, opsDashWithShadow);
48
49 { TBGRAOriginalEditor }
50
51 TBGRAOriginalEditor = class
52 private
53 function GetPointCoord(AIndex: integer): TPointF;
54 function GetPointCount: integer;
55 protected
56 FMatrix,FMatrixInverse: TAffineMatrix; //view matrix from original coord
57 FGridMatrix,FGridMatrixInverse: TAffineMatrix; //grid matrix in original coord
58 FGridActive: boolean;
59 FPoints: array of record
60 Origin, Coord: TPointF;
61 OnMove: TOriginalMovePointEvent;
62 RightButton: boolean;
63 SnapToPoint: integer;
64 end;
65 FPolylines: array of record
66 Coords: array of TPointF;
67 Closed: boolean;
68 Style: TBGRAOriginalPolylineStyle;
69 BackColor: TBGRAPixel;
70 end;
71 FPointSize: single;
72 FPointMoving: integer;
73 FPointCoordDelta: TPointF;
74 FMovingRightButton: boolean;
75 FPrevMousePos: TPointF;
76 FStartMoveHandlers: TStartMoveHandlers;
77 FCurHoverPoint: integer;
78 FHoverPointHandlers: THoverPointHandlers;
79 FClickPointHandlers: TClickPointHandlers;
80 function RenderPoint(ADest: TBGRABitmap; ACoord: TPointF; AAlternateColor: boolean): TRect; virtual;
81 function GetRenderPointBounds(ACoord: TPointF): TRect; virtual;
82 function RenderArrow(ADest: TBGRABitmap; AOrigin, AEndCoord: TPointF): TRect; virtual;
83 function GetRenderArrowBounds(AOrigin, AEndCoord: TPointF): TRect; virtual;
84 function RenderPolygon(ADest: TBGRABitmap; ACoords: array of TPointF; AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle; ABackColor: TBGRAPixel): TRect; virtual;
85 function GetRenderPolygonBounds(ACoords: array of TPointF): TRect;
86 procedure SetMatrix(AValue: TAffineMatrix);
87 procedure SetGridMatrix(AValue: TAffineMatrix);
88 procedure SetGridActive(AValue: boolean);
89 function GetMoveCursor(APointIndex: integer): TOriginalEditorCursor; virtual;
90 public
91 constructor Create;
92 destructor Destroy; override;
93 procedure Clear; virtual;
94 procedure AddStartMoveHandler(AOnStartMove: TOriginalStartMovePointEvent);
95 procedure AddClickPointHandler(AOnClickPoint: TOriginalClickPointEvent);
96 procedure AddHoverPointHandler(AOnHoverPoint: TOriginalHoverPointEvent);
97 function AddPoint(const ACoord: TPointF; AOnMove: TOriginalMovePointEvent; ARightButton: boolean = false; ASnapToPoint: integer = -1): integer;
98 function AddFixedPoint(const ACoord: TPointF; ARightButton: boolean = false): integer;
99 function AddArrow(const AOrigin, AEndCoord: TPointF; AOnMoveEnd: TOriginalMovePointEvent; ARightButton: boolean = false): integer;
100 function AddPolyline(const ACoords: array of TPointF; AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle): integer; overload;
101 function AddPolyline(const ACoords: array of TPointF; AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle; ABackColor: TBGRAPixel): integer; overload;
102 procedure MouseMove(Shift: TShiftState; ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean); virtual;
103 procedure MouseDown(RightButton: boolean; Shift: TShiftState; ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean); virtual;
104 procedure MouseUp(RightButton: boolean; {%H-}Shift: TShiftState; {%H-}ViewX, {%H-}ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean); virtual;
105 procedure KeyDown({%H-}Shift: TShiftState; {%H-}Key: TSpecialKey; out AHandled: boolean); virtual;
106 procedure KeyUp({%H-}Shift: TShiftState; {%H-}Key: TSpecialKey; out AHandled: boolean); virtual;
107 procedure KeyPress({%H-}UTF8Key: string; out AHandled: boolean); virtual;
108 function GetPointAt(ACoord: TPointF; ARightButton: boolean): integer;
109 function Render(ADest: TBGRABitmap; const {%H-}ALayoutRect: TRect): TRect; virtual;
110 function GetRenderBounds(const {%H-}ALayoutRect: TRect): TRect; virtual;
111 function SnapToGrid(const ACoord: TPointF; AIsViewCoord: boolean): TPointF;
112 function OriginalCoordToView(const AImageCoord: TPointF): TPointF;
113 function ViewCoordToOriginal(const AViewCoord: TPointF): TPointF;
114 property Matrix: TAffineMatrix read FMatrix write SetMatrix;
115 property GridMatrix: TAffineMatrix read FGridMatrix write SetGridMatrix;
116 property GridActive: boolean read FGridActive write SetGridActive;
117 property PointSize: single read FPointSize write FPointSize;
118 property PointCount: integer read GetPointCount;
119 property PointCoord[AIndex: integer]: TPointF read GetPointCoord;
120 end;
121
122 TBGRACustomOriginalStorage = class;
123 ArrayOfSingle = array of single;
124
125 { TBGRALayerCustomOriginal }
126
127 TBGRALayerCustomOriginal = class
128 private
129 FOnChange: TOriginalChangeEvent;
130 FOnEditingChange: TOriginalEditingChangeEvent;
131 procedure SetOnChange(AValue: TOriginalChangeEvent);
132 protected
133 FGuid: TGuid;
134 function GetGuid: TGuid;
135 procedure SetGuid(AValue: TGuid);
136 procedure NotifyChange; overload;
137 procedure NotifyChange(ABounds: TRectF); overload;
138 procedure NotifyEditorChange;
139 public
140 constructor Create; virtual;
141 destructor Destroy; override;
142 procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); virtual; abstract;
143 function GetRenderBounds(ADestRect: TRect; AMatrix: TAffineMatrix): TRect; virtual; abstract;
144 procedure ConfigureEditor({%H-}AEditor: TBGRAOriginalEditor); virtual;
145 procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); virtual; abstract;
146 procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); virtual; abstract;
147 procedure LoadFromFile(AFilenameUTF8: string); virtual;
148 procedure LoadFromStream(AStream: TStream); virtual;
149 procedure LoadFromResource(AFilename: string);
150 procedure SaveToFile(AFilenameUTF8: string); virtual;
151 procedure SaveToStream(AStream: TStream); virtual;
152 function CreateEditor: TBGRAOriginalEditor; virtual;
153 class function StorageClassName: RawByteString; virtual; abstract;
154 function Duplicate: TBGRALayerCustomOriginal; virtual;
155 property Guid: TGuid read GetGuid write SetGuid;
156 property OnChange: TOriginalChangeEvent read FOnChange write SetOnChange;
157 property OnEditingChange: TOriginalEditingChangeEvent read FOnEditingChange write FOnEditingChange;
158 end;
159
160 { TBGRALayerImageOriginal }
161
162 TBGRALayerImageOriginal = class(TBGRALayerCustomOriginal)
163 private
164 function GetImageHeight: integer;
165 function GetImageWidth: integer;
166 protected
167 FImage: TBGRABitmap;
168 FJpegStream: TMemoryStream;
169 FContentVersion: integer;
170 procedure ContentChanged;
171 public
172 constructor Create; override;
173 destructor Destroy; override;
174 procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); override;
175 function GetRenderBounds({%H-}ADestRect: TRect; AMatrix: TAffineMatrix): TRect; override;
176 procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
177 procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
178 procedure LoadFromStream(AStream: TStream); override;
179 procedure LoadImageFromStream(AStream: TStream);
180 procedure SaveImageToStream(AStream: TStream);
181 class function StorageClassName: RawByteString; override;
182 property Width: integer read GetImageWidth;
183 property Height: integer read GetImageHeight;
184 end;
185
186 { TBGRACustomOriginalStorage }
187
188 TBGRACustomOriginalStorage = class
189 protected
190 FFormats: TFormatSettings;
191 function GetBool(AName: utf8string): boolean;
192 function GetColorArray(AName: UTF8String): ArrayOfTBGRAPixel;
193 function GetInteger(AName: utf8string): integer;
194 function GetIntegerDef(AName: utf8string; ADefault: integer): integer;
195 function GetPointF(AName: utf8string): TPointF;
196 function GetRawString(AName: utf8string): RawByteString; virtual; abstract;
197 function GetSingle(AName: utf8string): single;
198 function GetSingleArray(AName: utf8string): ArrayOfSingle;
199 function GetSingleDef(AName: utf8string; ADefault: single): single;
200 function GetColor(AName: UTF8String): TBGRAPixel;
201 procedure SetBool(AName: utf8string; AValue: boolean);
202 procedure SetColorArray(AName: UTF8String; AValue: ArrayOfTBGRAPixel);
203 procedure SetInteger(AName: utf8string; AValue: integer);
204 procedure SetPointF(AName: utf8string; AValue: TPointF);
205 procedure SetRawString(AName: utf8string; AValue: RawByteString); virtual; abstract;
206 procedure SetSingle(AName: utf8string; AValue: single);
207 procedure SetSingleArray(AName: utf8string; AValue: ArrayOfSingle);
208 procedure SetColor(AName: UTF8String; AValue: TBGRAPixel);
209 function GetDelimiter: char;
210 public
211 constructor Create;
212 procedure RemoveAttribute(AName: utf8string); virtual; abstract;
213 procedure RemoveObject(AName: utf8string); virtual; abstract;
214 function CreateObject(AName: utf8string): TBGRACustomOriginalStorage; virtual; abstract;
215 function OpenObject(AName: utf8string): TBGRACustomOriginalStorage; virtual; abstract;
216 function ObjectExists(AName: utf8string): boolean; virtual; abstract;
217 procedure RemoveFile(AName: utf8string); virtual; abstract;
218 function ReadFile(AName: UTF8String; ADest: TStream): boolean; virtual; abstract;
219 procedure WriteFile(AName: UTF8String; ASource: TStream; ACompress: boolean); virtual; abstract;
220 property RawString[AName: utf8string]: RawByteString read GetRawString write SetRawString;
221 property Int[AName: utf8string]: integer read GetInteger write SetInteger;
222 property IntDef[AName: utf8string; ADefault: integer]: integer read GetIntegerDef;
223 property Bool[AName: utf8string]: boolean read GetBool write SetBool;
224 property Float[AName: utf8string]: single read GetSingle write SetSingle;
225 property FloatArray[AName: utf8string]: ArrayOfSingle read GetSingleArray write SetSingleArray;
226 property FloatDef[AName: utf8string; ADefault: single]: single read GetSingleDef;
227 property PointF[AName: utf8string]: TPointF read GetPointF write SetPointF;
228 property Color[AName: UTF8String]: TBGRAPixel read GetColor write SetColor;
229 property ColorArray[AName: UTF8String]: ArrayOfTBGRAPixel read GetColorArray write SetColorArray;
230 end;
231
232 { TBGRAMemOriginalStorage }
233
234 TBGRAMemOriginalStorage = class(TBGRACustomOriginalStorage)
235 protected
236 FMemDir: TMemDirectory;
237 FMemDirOwned: boolean;
238 function GetRawString(AName: utf8string): RawByteString; override;
239 procedure SetRawString(AName: utf8string; AValue: RawByteString); override;
240 public
241 destructor Destroy; override;
242 constructor Create;
243 constructor Create(AMemDir: TMemDirectory; AMemDirOwned: boolean = false);
244 procedure RemoveAttribute(AName: utf8string); override;
245 procedure RemoveObject(AName: utf8string); override;
246 function CreateObject(AName: utf8string): TBGRACustomOriginalStorage; override;
247 function OpenObject(AName: utf8string): TBGRACustomOriginalStorage; override;
248 function ObjectExists(AName: utf8string): boolean; override;
249 procedure RemoveFile(AName: utf8string); override;
250 function ReadFile(AName: UTF8String; ADest: TStream): boolean; override;
251 procedure WriteFile(AName: UTF8String; ASource: TStream; ACompress: boolean); override;
252 procedure SaveToStream(AStream: TStream);
253 procedure LoadFromStream(AStream: TStream);
254 procedure LoadFromResource(AFilename: string);
255 procedure CopyTo(AMemDir: TMemDirectory);
256 end;
257
258procedure RegisterLayerOriginal(AClass: TBGRALayerOriginalAny);
259function FindLayerOriginalClass(AStorageClassName: string): TBGRALayerOriginalAny;
260
261implementation
262
263uses BGRAPolygon, math, BGRAMultiFileType, BGRAUTF8, Types, BGRAGraphics;
264
265var
266 LayerOriginalClasses: array of TBGRALayerOriginalAny;
267
268procedure RegisterLayerOriginal(AClass: TBGRALayerOriginalAny);
269begin
270 setlength(LayerOriginalClasses, length(LayerOriginalClasses)+1);
271 LayerOriginalClasses[high(LayerOriginalClasses)] := AClass;
272end;
273
274function FindLayerOriginalClass(AStorageClassName: string): TBGRALayerOriginalAny;
275var
276 i: Integer;
277begin
278 for i := 0 to high(LayerOriginalClasses) do
279 if LayerOriginalClasses[i].StorageClassName = AStorageClassName then
280 exit(LayerOriginalClasses[i]);
281 exit(nil);
282end;
283
284{ TBGRAOriginalEditor }
285
286procedure TBGRAOriginalEditor.SetMatrix(AValue: TAffineMatrix);
287begin
288 if FMatrix=AValue then Exit;
289 FMatrix:=AValue;
290 FMatrixInverse := AffineMatrixInverse(FMatrix);
291end;
292
293function TBGRAOriginalEditor.GetMoveCursor(APointIndex: integer): TOriginalEditorCursor;
294var
295 d: TPointF;
296 ratio: single;
297begin
298 if (APointIndex < 0) or (APointIndex >= PointCount) then result := oecDefault else
299 if isEmptyPointF(FPoints[APointIndex].Origin) then
300 begin
301 if Assigned(FPoints[APointIndex].OnMove) then
302 result := oecMove
303 else
304 result := oecHandPoint;
305 end else
306 begin
307 d := AffineMatrixLinear(FMatrix)*(FPoints[APointIndex].Coord - FPoints[APointIndex].Origin);
308 ratio := sin(Pi/8);
309 if (d.x = 0) and (d.y = 0) then result := oecMove else
310 if abs(d.x)*ratio >= abs(d.y) then
311 begin
312 if d.x >= 0 then result := oecMoveE else result := oecMoveW
313 end else
314 if abs(d.y)*ratio >= abs(d.x) then
315 begin
316 if d.y >= 0 then result := oecMoveS else result := oecMoveN
317 end else
318 if (d.x > 0) and (d.y > 0) then result := oecMoveSE else
319 if (d.x < 0) and (d.y < 0) then result := oecMoveNW else
320 if (d.x > 0) and (d.y < 0) then result := oecMoveNE
321 else result := oecMoveSW;
322 end;
323end;
324
325function TBGRAOriginalEditor.GetPointCoord(AIndex: integer): TPointF;
326begin
327 if (AIndex < 0) or (AIndex >= PointCount) then raise exception.Create('Index out of bounds');
328 result := FPoints[AIndex].Coord;
329end;
330
331function TBGRAOriginalEditor.GetPointCount: integer;
332begin
333 result := length(FPoints);
334end;
335
336procedure TBGRAOriginalEditor.SetGridActive(AValue: boolean);
337begin
338 if FGridActive=AValue then Exit;
339 FGridActive:=AValue;
340end;
341
342procedure TBGRAOriginalEditor.SetGridMatrix(AValue: TAffineMatrix);
343begin
344 if FGridMatrix=AValue then Exit;
345 FGridMatrix:=AValue;
346 FGridMatrixInverse := AffineMatrixInverse(FGridMatrix);
347end;
348
349function TBGRAOriginalEditor.RenderPoint(ADest: TBGRABitmap; ACoord: TPointF; AAlternateColor: boolean): TRect;
350const alpha = 192;
351var filler: TBGRAMultishapeFiller;
352 c: TBGRAPixel;
353begin
354 result := GetRenderPointBounds(ACoord);
355 if not isEmptyPointF(ACoord) then
356 begin
357 filler := TBGRAMultishapeFiller.Create;
358 filler.AddEllipseBorder(ACoord.x,ACoord.y, FPointSize-2,FPointSize-2, 4, BGRA(0,0,0,alpha));
359 if AAlternateColor then c := BGRA(255,128,128,alpha)
360 else c := BGRA(255,255,255,alpha);
361 filler.AddEllipseBorder(ACoord.x,ACoord.y, FPointSize-2,FPointSize-2, 1, c);
362 filler.PolygonOrder:= poLastOnTop;
363 filler.Draw(ADest);
364 filler.Free;
365 end;
366end;
367
368function TBGRAOriginalEditor.GetRenderPointBounds(ACoord: TPointF): TRect;
369begin
370 if isEmptyPointF(ACoord) then
371 result := EmptyRect
372 else
373 result := rect(floor(ACoord.x - FPointSize + 0.5), floor(ACoord.y - FPointSize + 0.5), ceil(ACoord.x + FPointSize + 0.5), ceil(ACoord.y + FPointSize + 0.5));
374end;
375
376function TBGRAOriginalEditor.RenderArrow(ADest: TBGRABitmap; AOrigin,
377 AEndCoord: TPointF): TRect;
378const alpha = 192;
379var
380 pts, ptsContour: ArrayOfTPointF;
381 i: Integer;
382 rF: TRectF;
383begin
384 if isEmptyPointF(AOrigin) or isEmptyPointF(AEndCoord) then
385 result := EmptyRect
386 else
387 begin
388 ADest.Pen.Arrow.EndAsClassic;
389 ADest.Pen.Arrow.EndSize := PointF(FPointSize,FPointSize);
390 pts := ADest.ComputeWidePolyline([AOrigin,AEndCoord],1);
391 ADest.Pen.Arrow.EndAsNone;
392 ptsContour := ADest.ComputeWidePolygon(pts, 2);
393 ADest.FillPolyAntialias(ptsContour, BGRA(0,0,0,alpha));
394 ADest.FillPolyAntialias(pts, BGRA(255,255,255,alpha));
395 rF := RectF(AOrigin,AEndCoord);
396 for i := 0 to high(ptsContour) do
397 if not isEmptyPointF(ptsContour[i]) then
398 begin
399 if ptsContour[i].x < rF.Left then rF.Left := ptsContour[i].x;
400 if ptsContour[i].x > rF.Right then rF.Right := ptsContour[i].x;
401 if ptsContour[i].y < rF.Top then rF.Top := ptsContour[i].y;
402 if ptsContour[i].y > rF.Bottom then rF.Bottom := ptsContour[i].y;
403 end;
404 result := rect(floor(rF.Left+0.5),floor(rF.Top+0.5),ceil(rF.Right+0.5),ceil(rF.Bottom+0.5));
405 end;
406end;
407
408function TBGRAOriginalEditor.GetRenderArrowBounds(AOrigin, AEndCoord: TPointF): TRect;
409begin
410 if isEmptyPointF(AOrigin) or isEmptyPointF(AEndCoord) then
411 result := EmptyRect
412 else
413 begin
414 result := Rect(floor(AOrigin.x+0.5-1.5),floor(AOrigin.y+0.5-1.5),ceil(AOrigin.x+0.5+1.5),ceil(AOrigin.y+0.5+1.5));
415 UnionRect(result, result, rect(floor(AEndCoord.x+0.5-FPointSize-1.5), floor(AEndCoord.y+0.5-FPointSize-1.5),
416 ceil(AEndCoord.x+0.5+FPointSize+1.5), ceil(AEndCoord.y+0.5+FPointSize+1.5)) );
417 end;
418end;
419
420function TBGRAOriginalEditor.RenderPolygon(ADest: TBGRABitmap;
421 ACoords: array of TPointF; AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle; ABackColor: TBGRAPixel): TRect;
422var
423 dashLen: integer;
424 i: integer;
425 ptsF: array of TPointF;
426 pts1,pts2: array of TPoint;
427begin
428 dashLen := round(PointSize/2);
429 if dashLen < 1 then dashLen := 1;
430
431 setlength(pts1, length(ACoords));
432 for i := 0 to high(ACoords) do
433 pts1[i] := ACoords[i].Round;
434
435 setlength(ptsF, length(pts1));
436 for i := 0 to high(pts1) do
437 ptsF[i] := PointF(pts1[i]);
438
439 if ABackColor.alpha <> 0 then
440 ADest.FillPolyAntialias(ptsF, ABackColor);
441
442 case AStyle of
443 opsDash, opsDashWithShadow:
444 begin
445 if AStyle = opsDashWithShadow then
446 begin
447 //shadow
448 setlength(pts2,length(pts1));
449 for i := 0 to high(pts1) do
450 if not isEmptyPoint(pts1[i]) then
451 pts2[i] := Point(pts1[i].x+1,pts1[i].y+1)
452 else pts2[i] := EmptyPoint;
453 if AClosed then
454 ADest.DrawPolygonAntialias(pts2, BGRA(0,0,0,96))
455 else
456 ADest.DrawPolyLineAntialias(pts2, BGRA(0,0,0,96), true);
457 pts2:= nil;
458 end;
459
460 //dotted line
461 if AClosed then
462 ADest.DrawPolygonAntialias(pts1, CSSIvory,BGRA(70,70,50),dashLen)
463 else
464 ADest.DrawPolyLineAntialias(pts1, CSSIvory,BGRA(70,70,50),dashLen, true);
465 end;
466 opsSolid:
467 begin
468 ADest.JoinStyle:= pjsRound;
469 ADest.LineCap:= pecRound;
470 //black outline
471 if AClosed then
472 ADest.DrawPolygonAntialias(ptsF, BGRA(0,0,0,192), 3)
473 else
474 ADest.DrawPolyLineAntialias(ptsF, BGRA(0,0,0,192), 3);
475
476 if AClosed then
477 ADest.DrawPolygonAntialias(pts1, CSSIvory)
478 else
479 ADest.DrawPolyLineAntialias(pts1, CSSIvory, true);
480 end;
481 end;
482
483 result := GetRenderPolygonBounds(ACoords);
484end;
485
486function TBGRAOriginalEditor.GetRenderPolygonBounds(ACoords: array of TPointF): TRect;
487var
488 first: Boolean;
489 rF: TRectF;
490 i: Integer;
491begin
492 first:= true;
493 rF:= EmptyRectF;
494 for i := 0 to high(ACoords) do
495 if not isEmptyPointF(ACoords[i]) then
496 begin
497 if first then
498 begin
499 rF := RectF(Acoords[i],ACoords[i]);
500 first:= false;
501 end else
502 begin
503 if ACoords[i].x < rF.Left then rF.Left := ACoords[i].x;
504 if ACoords[i].x > rF.Right then rF.Right := ACoords[i].x;
505 if ACoords[i].y < rF.Top then rF.Top := ACoords[i].y;
506 if ACoords[i].y > rF.Bottom then rF.Bottom := ACoords[i].y;
507 end;
508 end;
509 if not first then
510 result := rect(floor(rF.Left-0.5),floor(rF.Top-0.5),ceil(rF.Right+1.5),ceil(rF.Bottom+1.5))
511 else
512 result := EmptyRect;
513end;
514
515constructor TBGRAOriginalEditor.Create;
516begin
517 FPointSize:= 6;
518 FMatrix := AffineMatrixIdentity;
519 FMatrixInverse := AffineMatrixIdentity;
520 FGridMatrix := AffineMatrixIdentity;
521 FGridMatrixInverse := AffineMatrixIdentity;
522 FGridActive:= false;
523 FPointMoving:= -1;
524 FStartMoveHandlers := TStartMoveHandlers.Create;
525 FCurHoverPoint:= -1;
526 FHoverPointHandlers := THoverPointHandlers.Create;
527 FClickPointHandlers := TClickPointHandlers.Create;
528end;
529
530destructor TBGRAOriginalEditor.Destroy;
531begin
532 FreeAndNil(FStartMoveHandlers);
533 FreeAndNil(FHoverPointHandlers);
534 FreeAndNil(FClickPointHandlers);
535 inherited Destroy;
536end;
537
538procedure TBGRAOriginalEditor.Clear;
539begin
540 FPoints := nil;
541 FPolylines := nil;
542 FStartMoveHandlers.Clear;
543 FHoverPointHandlers.Clear;
544 FClickPointHandlers.Clear;
545end;
546
547procedure TBGRAOriginalEditor.AddStartMoveHandler(
548 AOnStartMove: TOriginalStartMovePointEvent);
549begin
550 FStartMoveHandlers.Add(AOnStartMove);
551end;
552
553procedure TBGRAOriginalEditor.AddClickPointHandler(
554 AOnClickPoint: TOriginalClickPointEvent);
555begin
556 FClickPointHandlers.Add(AOnClickPoint);
557end;
558
559procedure TBGRAOriginalEditor.AddHoverPointHandler(
560 AOnHoverPoint: TOriginalHoverPointEvent);
561begin
562 FHoverPointHandlers.Add(AOnHoverPoint);
563end;
564
565function TBGRAOriginalEditor.AddPoint(const ACoord: TPointF;
566 AOnMove: TOriginalMovePointEvent; ARightButton: boolean; ASnapToPoint: integer): integer;
567begin
568 setlength(FPoints, length(FPoints)+1);
569 result := High(FPoints);
570 with FPoints[result] do
571 begin
572 Origin := EmptyPointF;
573 Coord := ACoord;
574 OnMove := AOnMove;
575 RightButton:= ARightButton;
576 SnapToPoint:= ASnapToPoint;
577 end;
578end;
579
580function TBGRAOriginalEditor.AddFixedPoint(const ACoord: TPointF;
581 ARightButton: boolean): integer;
582begin
583 setlength(FPoints, length(FPoints)+1);
584 result := High(FPoints);
585 with FPoints[result] do
586 begin
587 Origin := EmptyPointF;
588 Coord := ACoord;
589 OnMove := nil;
590 RightButton:= ARightButton;
591 SnapToPoint:= -1;
592 end;
593end;
594
595function TBGRAOriginalEditor.AddArrow(const AOrigin, AEndCoord: TPointF;
596 AOnMoveEnd: TOriginalMovePointEvent; ARightButton: boolean): integer;
597begin
598 setlength(FPoints, length(FPoints)+1);
599 result := High(FPoints);
600 with FPoints[result] do
601 begin
602 Origin := AOrigin;
603 Coord := AEndCoord;
604 OnMove := AOnMoveEnd;
605 RightButton:= ARightButton;
606 SnapToPoint:= -1;
607 end;
608end;
609
610function TBGRAOriginalEditor.AddPolyline(const ACoords: array of TPointF;
611 AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle): integer;
612begin
613 result := AddPolyline(ACoords, AClosed, AStyle, BGRAPixelTransparent);
614end;
615
616function TBGRAOriginalEditor.AddPolyline(const ACoords: array of TPointF;
617 AClosed: boolean; AStyle: TBGRAOriginalPolylineStyle; ABackColor: TBGRAPixel): integer;
618var
619 i: Integer;
620begin
621 setlength(FPolylines, length(FPolylines)+1);
622 result := high(FPolylines);
623 setlength(FPolylines[result].Coords, length(ACoords));
624 for i := 0 to high(ACoords) do
625 FPolylines[result].Coords[i] := ACoords[i];
626 FPolylines[result].Closed:= AClosed;
627 FPolylines[result].Style := AStyle;
628 FPolylines[result].BackColor := ABackColor;
629end;
630
631procedure TBGRAOriginalEditor.MouseMove(Shift: TShiftState; ViewX, ViewY: single; out
632 ACursor: TOriginalEditorCursor; out AHandled: boolean);
633var newMousePos, newCoord, snapCoord: TPointF;
634 hoverPoint, i: Integer;
635begin
636 AHandled := false;
637 newMousePos := ViewCoordToOriginal(PointF(ViewX,ViewY));
638 if (FPointMoving <> -1) and (FPointMoving < length(FPoints)) then
639 begin
640 newCoord := newMousePos + FPointCoordDelta;
641 if GridActive then newCoord := SnapToGrid(newCoord, false);
642 if FPoints[FPointMoving].SnapToPoint <> -1 then
643 begin
644 snapCoord := FPoints[FPoints[FPointMoving].SnapToPoint].Coord;
645 if VectLen(AffineMatrixLinear(FMatrix)*(snapCoord - newCoord)) < FPointSize then
646 newCoord := snapCoord;
647 end;
648 if newCoord <> FPoints[FPointMoving].Coord then
649 begin
650 FPoints[FPointMoving].OnMove(self, FPoints[FPointMoving].Coord, newCoord, Shift);
651 FPoints[FPointMoving].Coord := newCoord;
652 end;
653 ACursor := GetMoveCursor(FPointMoving);
654 AHandled:= true;
655 end else
656 begin
657 hoverPoint := GetPointAt(newMousePos, false);
658 if hoverPoint <> -1 then
659 ACursor := GetMoveCursor(hoverPoint)
660 else
661 ACursor:= oecDefault;
662 if hoverPoint <> FCurHoverPoint then
663 begin
664 FCurHoverPoint:= hoverPoint;
665 for i := 0 to FHoverPointHandlers.Count-1 do
666 FHoverPointHandlers[i](self, FCurHoverPoint);
667 end;
668 end;
669 FPrevMousePos:= newMousePos;
670end;
671
672procedure TBGRAOriginalEditor.MouseDown(RightButton: boolean;
673 Shift: TShiftState; ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out
674 AHandled: boolean);
675var
676 i, clickedPoint: Integer;
677begin
678 AHandled:= false;
679 FPrevMousePos:= ViewCoordToOriginal(PointF(ViewX,ViewY));
680 if FPointMoving = -1 then
681 begin
682 clickedPoint := GetPointAt(FPrevMousePos, RightButton);;
683 if clickedPoint <> -1 then
684 begin
685 if Assigned(FPoints[clickedPoint].OnMove) then
686 begin
687 FPointMoving:= clickedPoint;
688 FMovingRightButton:= RightButton;
689 FPointCoordDelta := FPoints[FPointMoving].Coord - FPrevMousePos;
690 for i := 0 to FStartMoveHandlers.Count-1 do
691 FStartMoveHandlers[i](self, FPointMoving, Shift);
692 end else
693 begin
694 for i := 0 to FClickPointHandlers.Count-1 do
695 FClickPointHandlers[i](self, clickedPoint, Shift);
696 end;
697 AHandled:= true;
698 end;
699 end;
700 if FPointMoving <> -1 then
701 begin
702 ACursor := GetMoveCursor(FPointMoving);
703 AHandled:= true;
704 end
705 else
706 ACursor := oecDefault;
707end;
708
709procedure TBGRAOriginalEditor.MouseUp(RightButton: boolean; Shift: TShiftState;
710 ViewX, ViewY: single; out ACursor: TOriginalEditorCursor; out AHandled: boolean);
711begin
712 AHandled:= false;
713 if (RightButton = FMovingRightButton) and (FPointMoving <> -1) then
714 begin
715 FPointMoving:= -1;
716 AHandled:= true;
717 end;
718 ACursor := oecDefault;
719end;
720
721procedure TBGRAOriginalEditor.KeyDown(Shift: TShiftState; Key: TSpecialKey; out
722 AHandled: boolean);
723begin
724 AHandled := false;
725end;
726
727procedure TBGRAOriginalEditor.KeyUp(Shift: TShiftState; Key: TSpecialKey; out
728 AHandled: boolean);
729begin
730 AHandled := false;
731end;
732
733procedure TBGRAOriginalEditor.KeyPress(UTF8Key: string; out AHandled: boolean);
734begin
735 AHandled := false;
736end;
737
738function TBGRAOriginalEditor.GetPointAt(ACoord: TPointF; ARightButton: boolean): integer;
739var v: TPointF;
740 curDist,newDist: single;
741 i: Integer;
742begin
743 if ARightButton then
744 curDist := sqr(2.5*FPointSize)
745 else
746 curDist := sqr(1.5*FPointSize);
747 result := -1;
748 ACoord:= Matrix*ACoord;
749
750 for i := 0 to high(FPoints) do
751 if FPoints[i].RightButton = ARightButton then
752 begin
753 v := Matrix*FPoints[i].Coord - ACoord;
754 newDist := v*v;
755 if newDist <= curDist then
756 begin
757 curDist:= newDist;
758 result := i;
759 end;
760 end;
761 if result <> -1 then exit;
762
763 if not ARightButton then
764 curDist := sqr(2.5*FPointSize)
765 else
766 curDist := sqr(1.5*FPointSize);
767 for i := 0 to high(FPoints) do
768 if FPoints[i].RightButton <> ARightButton then
769 begin
770 v := Matrix*FPoints[i].Coord - ACoord;
771 newDist := v*v;
772 if newDist <= curDist then
773 begin
774 curDist:= newDist;
775 result := i;
776 end;
777 end;
778end;
779
780function TBGRAOriginalEditor.Render(ADest: TBGRABitmap; const ALayoutRect: TRect): TRect;
781var
782 i,j: Integer;
783 elemRect: TRect;
784 ptsF: array of TPointF;
785begin
786 result := EmptyRect;
787 for i := 0 to high(FPoints) do
788 begin
789 if isEmptyPointF(FPoints[i].Origin) then
790 elemRect := RenderPoint(ADest, OriginalCoordToView(FPoints[i].Coord), FPoints[i].RightButton)
791 else
792 elemRect := RenderArrow(ADest, OriginalCoordToView(FPoints[i].Origin), OriginalCoordToView(FPoints[i].Coord));
793 if not IsRectEmpty(elemRect) then
794 begin
795 if IsRectEmpty(result) then
796 result := elemRect
797 else
798 UnionRect(result, result, elemRect);
799 end;
800 end;
801 for i := 0 to high(FPolylines) do
802 begin
803 with FPolylines[i] do
804 begin
805 setlength(ptsF, length(Coords));
806 for j := 0 to high(Coords) do
807 if IsEmptyPointF(Coords[j]) then
808 ptsF[j] := EmptyPointF
809 else
810 ptsF[j] := OriginalCoordToView(Coords[j]);
811 elemRect := RenderPolygon(ADest, ptsF, Closed, Style, BackColor);
812 end;
813 if not IsRectEmpty(elemRect) then
814 begin
815 if IsRectEmpty(result) then
816 result := elemRect
817 else
818 UnionRect(result, result, elemRect);
819 end;
820 end;
821end;
822
823function TBGRAOriginalEditor.GetRenderBounds(const ALayoutRect: TRect): TRect;
824var
825 i,j: Integer;
826 elemRect: TRect;
827 ptsF: array of TPointF;
828begin
829 result := EmptyRect;
830 for i := 0 to high(FPoints) do
831 begin
832 if isEmptyPointF(FPoints[i].Origin) then
833 elemRect := GetRenderPointBounds(OriginalCoordToView(FPoints[i].Coord))
834 else
835 elemRect := GetRenderArrowBounds(OriginalCoordToView(FPoints[i].Origin), OriginalCoordToView(FPoints[i].Coord));
836 if not IsRectEmpty(elemRect) then
837 begin
838 if IsRectEmpty(result) then
839 result := elemRect
840 else
841 UnionRect(result, result, elemRect);
842 end;
843 end;
844 for i := 0 to high(FPolylines) do
845 begin
846 with FPolylines[i] do
847 begin
848 setlength(ptsF, length(Coords));
849 for j := 0 to high(Coords) do
850 if IsEmptyPointF(Coords[j]) then
851 ptsF[j] := EmptyPointF
852 else
853 ptsF[j] := OriginalCoordToView(Coords[j]);
854 elemRect := GetRenderPolygonBounds(ptsF);
855 end;
856 if not IsRectEmpty(elemRect) then
857 begin
858 if IsRectEmpty(result) then
859 result := elemRect
860 else
861 UnionRect(result, result, elemRect);
862 end;
863 end;
864end;
865
866function TBGRAOriginalEditor.SnapToGrid(const ACoord: TPointF;
867 AIsViewCoord: boolean): TPointF;
868var
869 gridCoord: TPointF;
870begin
871 if AIsViewCoord then
872 gridCoord := FGridMatrixInverse*ViewCoordToOriginal(ACoord)
873 else
874 gridCoord := FGridMatrixInverse*ACoord;
875 gridCoord.x := round(gridCoord.x);
876 gridCoord.y := round(gridCoord.y);
877 result := FGridMatrix*gridCoord;
878 if AIsViewCoord then
879 result := OriginalCoordToView(result);
880end;
881
882function TBGRAOriginalEditor.OriginalCoordToView(const AImageCoord: TPointF): TPointF;
883begin
884 result := FMatrix*AImageCoord;
885end;
886
887function TBGRAOriginalEditor.ViewCoordToOriginal(const AViewCoord: TPointF): TPointF;
888begin
889 result := FMatrixInverse*AViewCoord;
890end;
891
892{ TBGRAMemOriginalStorage }
893
894function TBGRAMemOriginalStorage.GetRawString(AName: utf8string): RawByteString;
895var
896 idx: Integer;
897begin
898 if pos('.',AName)<>0 then exit('');
899 idx := FMemDir.IndexOf(AName,'',true);
900 if idx = -1 then
901 result := ''
902 else if FMemDir.IsDirectory[idx] then
903 raise exception.Create('This name refers to an object and not an attribute')
904 else
905 result := FMemDir.RawString[idx];
906end;
907
908procedure TBGRAMemOriginalStorage.SetRawString(AName: utf8string;
909 AValue: RawByteString);
910var
911 idx: Integer;
912begin
913 if pos('.',AName)<>0 then
914 raise exception.Create('Attribute name cannot contain "."');
915 idx := FMemDir.IndexOf(AName,'',true);
916 if idx = -1 then
917 FMemDir.Add(AName,'',AValue)
918 else if FMemDir.IsDirectory[idx] then
919 raise exception.Create('This name refers to an existing object and so cannot be an attribute')
920 else
921 FMemDir.RawString[idx] := AValue;
922end;
923
924destructor TBGRAMemOriginalStorage.Destroy;
925begin
926 if FMemDirOwned then FreeAndNil(FMemDir);
927 inherited Destroy;
928end;
929
930constructor TBGRAMemOriginalStorage.Create;
931begin
932 inherited Create;
933 FMemDir := TMemDirectory.Create;
934 FMemDirOwned:= true;
935end;
936
937constructor TBGRAMemOriginalStorage.Create(AMemDir: TMemDirectory; AMemDirOwned: boolean = false);
938begin
939 inherited Create;
940 FMemDir := AMemDir;
941 FMemDirOwned:= AMemDirOwned;
942end;
943
944procedure TBGRAMemOriginalStorage.RemoveAttribute(AName: utf8string);
945var
946 idx: Integer;
947begin
948 if pos('.',AName)<>0 then exit;
949 idx := FMemDir.IndexOf(AName,'',true);
950 if idx = -1 then exit
951 else if FMemDir.IsDirectory[idx] then
952 raise exception.Create('This name refers to an object and not an attribute')
953 else
954 FMemDir.Delete(idx);
955end;
956
957procedure TBGRAMemOriginalStorage.RemoveObject(AName: utf8string);
958var
959 idx: Integer;
960begin
961 idx := FMemDir.IndexOf(EntryFilename(AName));
962 if idx = -1 then exit
963 else if not FMemDir.IsDirectory[idx] then
964 raise exception.Create('This name refers to an attribute and not an object')
965 else
966 FMemDir.Delete(idx);
967end;
968
969function TBGRAMemOriginalStorage.CreateObject(AName: utf8string): TBGRACustomOriginalStorage;
970var
971 dirIdx: Integer;
972begin
973 if pos('.',AName)<>0 then
974 raise exception.Create('An object cannot contain "."');
975 RemoveObject(AName);
976 dirIdx := FMemDir.AddDirectory(AName,'');
977 result := TBGRAMemOriginalStorage.Create(FMemDir.Directory[dirIdx]);
978end;
979
980function TBGRAMemOriginalStorage.OpenObject(AName: utf8string): TBGRACustomOriginalStorage;
981var
982 dir: TMemDirectory;
983begin
984 if pos('.',AName)<>0 then
985 raise exception.Create('An object cannot contain "."');
986 dir := FMemDir.FindPath(AName);
987 if dir = nil then
988 result := nil
989 else
990 result := TBGRAMemOriginalStorage.Create(dir);
991end;
992
993function TBGRAMemOriginalStorage.ObjectExists(AName: utf8string): boolean;
994var
995 dir: TMemDirectory;
996begin
997 if pos('.',AName)<>0 then exit(false);
998 dir := FMemDir.FindPath(AName);
999 result:= Assigned(dir);
1000end;
1001
1002procedure TBGRAMemOriginalStorage.RemoveFile(AName: utf8string);
1003var
1004 idx: Integer;
1005begin
1006 idx := FMemDir.IndexOf(EntryFilename(AName));
1007 if idx = -1 then exit
1008 else if FMemDir.IsDirectory[idx] then
1009 raise exception.Create('This name refers to an object and not a file')
1010 else
1011 FMemDir.Delete(idx);
1012end;
1013
1014function TBGRAMemOriginalStorage.ReadFile(AName: UTF8String; ADest: TStream): boolean;
1015var
1016 entryId: Integer;
1017begin
1018 entryId := FMemDir.IndexOf(EntryFilename(AName));
1019 if entryId <> -1 then
1020 begin
1021 with FMemDir.Entry[entryId] do
1022 result := CopyTo(ADest) = FileSize
1023 end
1024 else
1025 result := false;
1026end;
1027
1028procedure TBGRAMemOriginalStorage.WriteFile(AName: UTF8String; ASource: TStream; ACompress: boolean);
1029var
1030 idxEntry: Integer;
1031begin
1032 idxEntry := FMemDir.Add(EntryFilename(AName), ASource, true, false);
1033 if ACompress then FMemDir.IsEntryCompressed[idxEntry] := true;
1034end;
1035
1036procedure TBGRAMemOriginalStorage.SaveToStream(AStream: TStream);
1037begin
1038 FMemDir.SaveToStream(AStream);
1039end;
1040
1041procedure TBGRAMemOriginalStorage.LoadFromStream(AStream: TStream);
1042begin
1043 FMemDir.LoadFromStream(AStream);
1044end;
1045
1046procedure TBGRAMemOriginalStorage.LoadFromResource(AFilename: string);
1047begin
1048 FMemDir.LoadFromResource(AFilename);
1049end;
1050
1051procedure TBGRAMemOriginalStorage.CopyTo(AMemDir: TMemDirectory);
1052begin
1053 FMemDir.CopyTo(AMemDir, true);
1054end;
1055
1056{ TBGRACustomOriginalStorage }
1057
1058function TBGRACustomOriginalStorage.GetColor(AName: UTF8String): TBGRAPixel;
1059begin
1060 result := StrToBGRA(RawString[AName], BGRAPixelTransparent);
1061end;
1062
1063procedure TBGRACustomOriginalStorage.SetColor(AName: UTF8String;
1064 AValue: TBGRAPixel);
1065begin
1066 RawString[AName] := LowerCase(BGRAToStr(AValue, CSSColors));
1067end;
1068
1069function TBGRACustomOriginalStorage.GetDelimiter: char;
1070begin
1071 if FFormats.DecimalSeparator = ',' then
1072 result := ';' else result := ',';
1073end;
1074
1075function TBGRACustomOriginalStorage.GetBool(AName: utf8string): boolean;
1076begin
1077 result := StrToBool(RawString[AName]);
1078end;
1079
1080function TBGRACustomOriginalStorage.GetSingleArray(AName: utf8string): ArrayOfSingle;
1081var
1082 textVal: String;
1083 values: TStringList;
1084 i: Integer;
1085begin
1086 textVal := Trim(RawString[AName]);
1087 if textVal = '' then exit(nil);
1088 values := TStringList.Create;
1089 values.StrictDelimiter := true;
1090 values.Delimiter:= GetDelimiter;
1091 values.DelimitedText:= textVal;
1092 setlength(result, values.Count);
1093 for i := 0 to high(result) do
1094 if CompareText(values[i],'none')=0 then
1095 result[i] := EmptySingle
1096 else
1097 result[i] := StrToFloatDef(values[i], 0, FFormats);
1098 values.Free;
1099end;
1100
1101function TBGRACustomOriginalStorage.GetColorArray(AName: UTF8String
1102 ): ArrayOfTBGRAPixel;
1103var colorNames: TStringList;
1104 i: Integer;
1105begin
1106 colorNames := TStringList.Create;
1107 colorNames.StrictDelimiter := true;
1108 colorNames.Delimiter:= GetDelimiter;
1109 colorNames.DelimitedText:= RawString[AName];
1110 setlength(result, colorNames.Count);
1111 for i := 0 to high(result) do
1112 result[i] := StrToBGRA(colorNames[i],BGRAPixelTransparent);
1113 colorNames.Free;
1114end;
1115
1116function TBGRACustomOriginalStorage.GetIntegerDef(AName: utf8string;
1117 ADefault: integer): integer;
1118begin
1119 result := StrToIntDef(RawString[AName],ADefault);
1120end;
1121
1122function TBGRACustomOriginalStorage.GetSingleDef(AName: utf8string;
1123 ADefault: single): single;
1124begin
1125 result := StrToFloatDef(RawString[AName], ADefault, FFormats);
1126end;
1127
1128procedure TBGRACustomOriginalStorage.SetBool(AName: utf8string; AValue: boolean);
1129begin
1130 RawString[AName] := BoolToStr(AValue,'true','false');
1131end;
1132
1133procedure TBGRACustomOriginalStorage.SetSingleArray(AName: utf8string;
1134 AValue: ArrayOfSingle);
1135var
1136 values: TStringList;
1137 i: Integer;
1138begin
1139 values:= TStringList.Create;
1140 values.StrictDelimiter:= true;
1141 values.Delimiter:= GetDelimiter;
1142 for i := 0 to high(AValue) do
1143 if AValue[i] = EmptySingle then
1144 values.Add('none')
1145 else
1146 values.Add(FloatToStr(AValue[i], FFormats));
1147 RawString[AName] := values.DelimitedText;
1148 values.Free;
1149end;
1150
1151procedure TBGRACustomOriginalStorage.SetColorArray(AName: UTF8String;
1152 AValue: ArrayOfTBGRAPixel);
1153var colorNames: TStringList;
1154 i: Integer;
1155begin
1156 colorNames := TStringList.Create;
1157 colorNames.StrictDelimiter := true;
1158 colorNames.Delimiter:= GetDelimiter;
1159 for i := 0 to high(AValue) do
1160 colorNames.Add(LowerCase(BGRAToStr(AValue[i], CSSColors)));
1161 RawString[AName] := colorNames.DelimitedText;
1162 colorNames.Free;
1163end;
1164
1165function TBGRACustomOriginalStorage.GetInteger(AName: utf8string): integer;
1166begin
1167 result := GetIntegerDef(AName,0);
1168end;
1169
1170function TBGRACustomOriginalStorage.GetPointF(AName: utf8string): TPointF;
1171var
1172 s: String;
1173 posComma: integer;
1174begin
1175 s := RawString[AName];
1176 posComma := pos(GetDelimiter,s);
1177 if posComma = 0 then
1178 exit(EmptyPointF);
1179
1180 result.x := StrToFloat(copy(s,1,posComma-1), FFormats);
1181 result.y := StrToFloat(copy(s,posComma+1,length(s)-posComma), FFormats);
1182end;
1183
1184function TBGRACustomOriginalStorage.GetSingle(AName: utf8string): single;
1185begin
1186 result := GetSingleDef(AName, EmptySingle);
1187end;
1188
1189procedure TBGRACustomOriginalStorage.SetInteger(AName: utf8string;
1190 AValue: integer);
1191begin
1192 RawString[AName] := IntToStr(AValue);
1193end;
1194
1195procedure TBGRACustomOriginalStorage.SetPointF(AName: utf8string;
1196 AValue: TPointF);
1197begin
1198 if isEmptyPointF(AValue) then RemoveAttribute(AName)
1199 else RawString[AName] := FloatToStrF(AValue.x, ffGeneral,7,3, FFormats)+GetDelimiter+FloatToStrF(AValue.y, ffGeneral,7,3, FFormats);
1200end;
1201
1202procedure TBGRACustomOriginalStorage.SetSingle(AName: utf8string; AValue: single);
1203begin
1204 if AValue = EmptySingle then RemoveAttribute(AName)
1205 else RawString[AName] := FloatToStrF(AValue, ffGeneral,7,3, FFormats);
1206end;
1207
1208constructor TBGRACustomOriginalStorage.Create;
1209begin
1210 FFormats := DefaultFormatSettings;
1211 FFormats.DecimalSeparator := '.';
1212end;
1213
1214{ TBGRALayerCustomOriginal }
1215
1216procedure TBGRALayerCustomOriginal.SetOnChange(AValue: TOriginalChangeEvent);
1217begin
1218 if FOnChange=AValue then Exit;
1219 FOnChange:=AValue;
1220end;
1221
1222function TBGRALayerCustomOriginal.GetGuid: TGuid;
1223begin
1224 result := FGuid;
1225end;
1226
1227procedure TBGRALayerCustomOriginal.SetGuid(AValue: TGuid);
1228begin
1229 FGuid := AValue;
1230end;
1231
1232procedure TBGRALayerCustomOriginal.NotifyChange;
1233begin
1234 if Assigned(FOnChange) then
1235 FOnChange(self);
1236end;
1237
1238procedure TBGRALayerCustomOriginal.NotifyChange(ABounds: TRectF);
1239begin
1240 if Assigned(FOnChange) then
1241 FOnChange(self, @ABounds);
1242end;
1243
1244procedure TBGRALayerCustomOriginal.NotifyEditorChange;
1245begin
1246 if Assigned(FOnEditingChange) then
1247 FOnEditingChange(self);
1248end;
1249
1250constructor TBGRALayerCustomOriginal.Create;
1251begin
1252 FGuid := GUID_NULL;
1253end;
1254
1255destructor TBGRALayerCustomOriginal.Destroy;
1256begin
1257 inherited Destroy;
1258end;
1259
1260procedure TBGRALayerCustomOriginal.ConfigureEditor(AEditor: TBGRAOriginalEditor);
1261begin
1262 //nothing
1263end;
1264
1265procedure TBGRALayerCustomOriginal.LoadFromFile(AFilenameUTF8: string);
1266var
1267 s: TFileStreamUTF8;
1268begin
1269 s := TFileStreamUTF8.Create(AFilenameUTF8, fmOpenRead, fmShareDenyWrite);
1270 try
1271 LoadFromStream(s);
1272 finally
1273 s.Free;
1274 end;
1275end;
1276
1277procedure TBGRALayerCustomOriginal.LoadFromStream(AStream: TStream);
1278var storage: TBGRAMemOriginalStorage;
1279 memDir: TMemDirectory;
1280begin
1281 memDir := TMemDirectory.Create;
1282 storage := nil;
1283 try
1284 memDir.LoadFromStream(AStream);
1285 storage := TBGRAMemOriginalStorage.Create(memDir);
1286 if storage.RawString['class'] <> StorageClassName then
1287 raise exception.Create('Invalid class');
1288 LoadFromStorage(storage);
1289 FreeAndNil(storage);
1290 finally
1291 storage.Free;
1292 memDir.Free;
1293 end;
1294end;
1295
1296procedure TBGRALayerCustomOriginal.LoadFromResource(AFilename: string);
1297var
1298 stream: TStream;
1299begin
1300 stream := BGRAResource.GetResourceStream(AFilename);
1301 try
1302 LoadFromStream(stream);
1303 finally
1304 stream.Free;
1305 end;
1306end;
1307
1308procedure TBGRALayerCustomOriginal.SaveToFile(AFilenameUTF8: string);
1309var
1310 s: TFileStreamUTF8;
1311begin
1312 s := TFileStreamUTF8.Create(AFilenameUTF8, fmCreate);
1313 try
1314 SaveToStream(s);
1315 finally
1316 s.Free;
1317 end;
1318end;
1319
1320procedure TBGRALayerCustomOriginal.SaveToStream(AStream: TStream);
1321var storage: TBGRAMemOriginalStorage;
1322 memDir: TMemDirectory;
1323begin
1324 memDir := TMemDirectory.Create;
1325 storage := nil;
1326 try
1327 storage := TBGRAMemOriginalStorage.Create(memDir);
1328 storage.RawString['class'] := StorageClassName;
1329 SaveToStorage(storage);
1330 FreeAndNil(storage);
1331 memDir.SaveToStream(AStream);
1332 finally
1333 storage.Free;
1334 memDir.Free;
1335 end;
1336end;
1337
1338function TBGRALayerCustomOriginal.CreateEditor: TBGRAOriginalEditor;
1339begin
1340 result := TBGRAOriginalEditor.Create;
1341end;
1342
1343function TBGRALayerCustomOriginal.Duplicate: TBGRALayerCustomOriginal;
1344var
1345 storage: TBGRAMemOriginalStorage;
1346 c: TBGRALayerOriginalAny;
1347begin
1348 c := FindLayerOriginalClass(StorageClassName);
1349 if c = nil then raise exception.Create('Original class is not registered');
1350 storage := TBGRAMemOriginalStorage.Create;
1351 try
1352 SaveToStorage(storage);
1353 result := c.Create;
1354 result.LoadFromStorage(storage);
1355 finally
1356 storage.Free;
1357 end;
1358end;
1359
1360{ TBGRALayerImageOriginal }
1361
1362function TBGRALayerImageOriginal.GetImageHeight: integer;
1363begin
1364 result := FImage.Height;
1365end;
1366
1367function TBGRALayerImageOriginal.GetImageWidth: integer;
1368begin
1369 result := FImage.Width;
1370end;
1371
1372procedure TBGRALayerImageOriginal.ContentChanged;
1373begin
1374 FContentVersion += 1;
1375 NotifyChange;
1376end;
1377
1378constructor TBGRALayerImageOriginal.Create;
1379begin
1380 inherited Create;
1381 FImage := TBGRABitmap.Create;
1382 FContentVersion := 0;
1383 FJpegStream := nil;
1384end;
1385
1386destructor TBGRALayerImageOriginal.Destroy;
1387begin
1388 FImage.Free;
1389 FJpegStream.Free;
1390 inherited Destroy;
1391end;
1392
1393procedure TBGRALayerImageOriginal.Render(ADest: TBGRABitmap;
1394 AMatrix: TAffineMatrix; ADraft: boolean);
1395var resampleFilter: TResampleFilter;
1396begin
1397 if ADraft then resampleFilter := rfBox else resampleFilter:= rfCosine;
1398 if Assigned(FImage) then
1399 ADest.PutImageAffine(AMatrix, FImage, resampleFilter, dmSet);
1400end;
1401
1402function TBGRALayerImageOriginal.GetRenderBounds(ADestRect: TRect;
1403 AMatrix: TAffineMatrix): TRect;
1404var
1405 aff: TAffineBox;
1406begin
1407 if Assigned(FImage) then
1408 begin
1409 aff := AMatrix*TAffineBox.AffineBox(PointF(0,0),PointF(FImage.Width,0),PointF(0,FImage.Height));
1410 result := aff.RectBounds;
1411 end else
1412 result := EmptyRect;
1413end;
1414
1415procedure TBGRALayerImageOriginal.LoadFromStorage(
1416 AStorage: TBGRACustomOriginalStorage);
1417var imgStream: TMemoryStream;
1418begin
1419 if not Assigned(FImage) then FImage := TBGRABitmap.Create;
1420 imgStream := TMemoryStream.Create;
1421 try
1422 if AStorage.ReadFile('content.png', imgStream) then
1423 begin
1424 imgStream.Position:= 0;
1425 FImage.LoadFromStream(imgStream);
1426 FreeAndNil(FJpegStream);
1427 end else
1428 if AStorage.ReadFile('content.jpg', imgStream) then
1429 begin
1430 FreeAndNil(FJpegStream);
1431 FJpegStream := imgStream;
1432 imgStream:= nil;
1433
1434 FJpegStream.Position:= 0;
1435 FImage.LoadFromStream(FJpegStream);
1436 end else
1437 begin
1438 FImage.SetSize(0,0);
1439 FreeAndNil(FJpegStream);
1440 end;
1441 FContentVersion := AStorage.Int['content-version'];
1442 finally
1443 imgStream.Free;
1444 end;
1445end;
1446
1447procedure TBGRALayerImageOriginal.SaveToStorage(
1448 AStorage: TBGRACustomOriginalStorage);
1449var imgStream: TMemoryStream;
1450begin
1451 if Assigned(FImage) then
1452 begin
1453 if FContentVersion > AStorage.Int['content-version'] then
1454 begin
1455 if Assigned(FJpegStream) then
1456 begin
1457 AStorage.WriteFile('content.jpg', FJpegStream, false);
1458 AStorage.RemoveFile('content.png');
1459 AStorage.Int['content-version'] := FContentVersion;
1460 end else
1461 begin
1462 imgStream := TMemoryStream.Create;
1463 try
1464 FImage.SaveToStreamAsPng(imgStream);
1465 AStorage.RemoveFile('content.jpg');
1466 AStorage.WriteFile('content.png', imgStream, false);
1467 AStorage.Int['content-version'] := FContentVersion;
1468 finally
1469 imgStream.Free;
1470 end;
1471 end;
1472 end;
1473 end;
1474end;
1475
1476procedure TBGRALayerImageOriginal.LoadFromStream(AStream: TStream);
1477begin
1478 if TMemDirectory.CheckHeader(AStream) then
1479 inherited LoadFromStream(AStream)
1480 else
1481 LoadImageFromStream(AStream);
1482end;
1483
1484procedure TBGRALayerImageOriginal.LoadImageFromStream(AStream: TStream);
1485var
1486 newJpegStream: TMemoryStream;
1487begin
1488 if DetectFileFormat(AStream) = ifJpeg then
1489 begin
1490 newJpegStream := TMemoryStream.Create;
1491 try
1492 newJpegStream.CopyFrom(AStream, AStream.Size);
1493 newJpegStream.Position := 0;
1494 FImage.LoadFromStream(newJpegStream);
1495 FJpegStream.Free;
1496 FJpegStream := newJpegStream;
1497 newJpegStream := nil;
1498 finally
1499 newJpegStream.Free;
1500 end;
1501 end else
1502 begin
1503 FreeAndNil(FJpegStream);
1504 FImage.LoadFromStream(AStream);
1505 end;
1506 ContentChanged;
1507end;
1508
1509procedure TBGRALayerImageOriginal.SaveImageToStream(AStream: TStream);
1510begin
1511 if Assigned(FJpegStream) then
1512 begin
1513 FJpegStream.Position := 0;
1514 if AStream.CopyFrom(FJpegStream, FJpegStream.Size)<>FJpegStream.Size then
1515 raise exception.Create('Error while saving');
1516 end else
1517 FImage.SaveToStreamAsPng(AStream);
1518end;
1519
1520class function TBGRALayerImageOriginal.StorageClassName: RawByteString;
1521begin
1522 result := 'image';
1523end;
1524
1525initialization
1526
1527 RegisterLayerOriginal(TBGRALayerImageOriginal);
1528
1529end.
1530
Note: See TracBrowser for help on using the repository browser.