1 // SPDX-License-Identifier: GPL-3.0-only
2 unit LCVectorialFill;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 Classes, SysUtils, BGRATransform, BGRAGradientOriginal, BGRABitmap, BGRABitmapTypes,
10 BGRALayerOriginal;
11
12 type
13 TTextureRepetition = (trNone, trRepeatX, trRepeatY, trRepeatBoth);
14 TTransparentMode = (tmEnforeAllChannelsZero, tmAlphaZeroOnly, tmNoFill);
15 TVectorialFillType = (vftNone, vftSolid, vftGradient, vftTexture);
16 TVectorialFillTypes = set of TVectorialFillType;
17 TVectorialFill = class;
18
19 TCustomVectorialFillDiff = class
20 procedure Apply(AFill: TVectorialFill); virtual; abstract;
21 procedure Unapply(AFill: TVectorialFill); virtual; abstract;
IsIdentitynull22 function IsIdentity: boolean; virtual; abstract;
CanAppendnull23 function CanAppend(ADiff: TCustomVectorialFillDiff): boolean; virtual; abstract;
24 procedure Append(ADiff: TCustomVectorialFillDiff); virtual; abstract;
25 end;
26
27 TVectorialFillChangeEvent = procedure(ASender: TObject; var ADiff: TCustomVectorialFillDiff) of object;
28
29 { TVectorialFillGradientDiff }
30
31 TVectorialFillGradientDiff = class(TCustomVectorialFillDiff)
32 protected
33 FGradientDiff: TBGRAGradientOriginalDiff;
34 public
35 constructor Create(AGradientDiff: TBGRAGradientOriginalDiff);
36 destructor Destroy; override;
37 procedure Apply(AFill: TVectorialFill); override;
38 procedure Unapply(AFill: TVectorialFill); override;
IsIdentitynull39 function IsIdentity: boolean; override;
CanAppendnull40 function CanAppend(ADiff: TCustomVectorialFillDiff): boolean; override;
41 procedure Append(ADiff: TCustomVectorialFillDiff); override;
42 end;
43
44 { TVectorialFillDiff }
45
46 TVectorialFillDiff = class(TCustomVectorialFillDiff)
47 protected
48 FStart,FEnd: TVectorialFill;
49 FTransparentMode: TTransparentMode;
50 public
51 constructor Create(AFrom: TVectorialFill);
52 procedure ComputeDiff(ATo: TVectorialFill);
53 destructor Destroy; override;
54 procedure Apply(AFill: TVectorialFill); override;
55 procedure Unapply(AFill: TVectorialFill); override;
IsIdentitynull56 function IsIdentity: boolean; override;
CanAppendnull57 function CanAppend(ADiff: TCustomVectorialFillDiff): boolean; override;
58 procedure Append(ADiff: TCustomVectorialFillDiff); override;
59 end;
60
61 { TVectorialFill }
62
63 TVectorialFill = class
64 protected
65 FColor: TBGRAPixel;
66 FIsSolid: boolean;
67 FTexture: TBGRABitmap;
68 FTextureMatrix: TAffineMatrix;
69 FTextureMatrixBackup: TAffineMatrix;
70 FTextureOpacity: byte;
71 FTextureRepetition: TTextureRepetition;
72 FTextureAverageColor: TBGRAPixel;
73 FTextureAverageColorComputed: boolean;
74 FTransparentMode: TTransparentMode;
75 FGradient: TBGRALayerGradientOriginal;
76 FOnChange: TVectorialFillChangeEvent;
77 FOnBeforeChange: TNotifyEvent;
78 FDiff: TVectorialFillDiff;
79 procedure GradientChange({%H-}ASender: TObject; {%H-}ABounds: PRectF; var ADiff: TBGRAOriginalDiff);
80 procedure Init; virtual;
GetFillTypenull81 function GetFillType: TVectorialFillType;
GetIsEditablenull82 function GetIsEditable: boolean;
GetAverageColornull83 function GetAverageColor: TBGRAPixel;
84 procedure SetOnChange(AValue: TVectorialFillChangeEvent);
85 procedure SetTextureMatrix(AValue: TAffineMatrix);
86 procedure SetTextureOpacity(AValue: byte);
87 procedure SetTextureRepetition(AValue: TTextureRepetition);
88 procedure SetTransparentMode(AValue: TTransparentMode);
89 procedure InternalClear;
90 procedure BeginUpdate;
91 procedure EndUpdate;
92 procedure NotifyChangeWithoutDiff;
93 procedure ConfigureTextureEditor(AEditor: TBGRAOriginalEditor);
94 procedure TextureMoveOrigin({%H-}ASender: TObject; {%H-}APrevCoord,
95 ANewCoord: TPointF; {%H-}AShift: TShiftState);
96 procedure TextureMoveXAxis({%H-}ASender: TObject; {%H-}APrevCoord,
97 ANewCoord: TPointF; AShift: TShiftState);
98 procedure TextureMoveYAxis({%H-}ASender: TObject; {%H-}APrevCoord,
99 ANewCoord: TPointF; AShift: TShiftState);
100 procedure TextureStartMove({%H-}ASender: TObject; {%H-}AIndex: integer;
101 {%H-}AShift: TShiftState);
102 public
103 constructor Create;
104 procedure Clear;
105 constructor CreateAsSolid(AColor: TBGRAPixel);
106 constructor CreateAsTexture(ATexture: TBGRABitmap; AMatrix: TAffineMatrix; AOpacity: byte = 255;
107 ATextureRepetition: TTextureRepetition = trRepeatBoth);
108 constructor CreateAsGradient(AGradient: TBGRALayerGradientOriginal; AOwned: boolean);
109 procedure SetSolid(AColor: TBGRAPixel);
110 procedure SetTexture(ATexture: TBGRABitmap; AMatrix: TAffineMatrix; AOpacity: byte = 255;
111 ATextureRepetition: TTextureRepetition = trRepeatBoth);
112 procedure SetGradient(AGradient: TBGRALayerGradientOriginal; AOwned: boolean);
113 procedure ConfigureEditor(AEditor: TBGRAOriginalEditor);
CreateScannernull114 function CreateScanner(AMatrix: TAffineMatrix; ADraft: boolean): TBGRACustomScanner;
IsSlownull115 function IsSlow(AMatrix: TAffineMatrix): boolean;
IsFullyTransparentnull116 function IsFullyTransparent: boolean;
117 procedure Transform(AMatrix: TAffineMatrix);
Duplicatenull118 function Duplicate: TVectorialFill; virtual;
119 destructor Destroy; override;
Equalsnull120 function Equals(Obj: TObject): boolean; override;
Equalnull121 class function Equal(AFill1, AFill2: TVectorialFill): boolean;
122 procedure Assign(Obj: TObject);
123 procedure AssignExceptGeometry(Obj: TObject);
124 procedure FitGeometry(const ABox: TAffineBox);
125 procedure ApplyOpacity(AOpacity: Byte);
126 property FillType: TVectorialFillType read GetFillType;
127 property IsEditable: boolean read GetIsEditable;
128 property Gradient: TBGRALayerGradientOriginal read FGradient;
129 property SolidColor: TBGRAPixel read FColor write SetSolid;
130 property AverageColor: TBGRAPixel read GetAverageColor;
131 property Texture: TBGRABitmap read FTexture;
132 property TextureMatrix: TAffineMatrix read FTextureMatrix write SetTextureMatrix;
133 property TextureOpacity: byte read FTextureOpacity write SetTextureOpacity;
134 property TextureRepetition: TTextureRepetition read FTextureRepetition write SetTextureRepetition;
135 property OnChange: TVectorialFillChangeEvent read FOnChange write SetOnChange;
136 property OnBeforeChange: TNotifyEvent read FOnBeforeChange write FOnBeforeChange;
137 property TransparentMode: TTransparentMode read FTransparentMode write SetTransparentMode;
138 end;
139
140 implementation
141
142 uses BGRAGradientScanner, BGRABlend, LCResourceString;
143
144 { TVectorialFillDiff }
145
146 constructor TVectorialFillDiff.Create(AFrom: TVectorialFill);
147 begin
148 FStart := TVectorialFill.Create;
149 FStart.TransparentMode:= AFrom.TransparentMode;
150 FStart.Assign(AFrom);
151 end;
152
153 procedure TVectorialFillDiff.ComputeDiff(ATo: TVectorialFill);
154 begin
155 FEnd := TVectorialFill.Create;
156 FEnd.TransparentMode := ATo.TransparentMode;
157 FEnd.Assign(ATo);
158 end;
159
160 destructor TVectorialFillDiff.Destroy;
161 begin
162 FStart.Free;
163 FEnd.Free;
164 inherited Destroy;
165 end;
166
167 procedure TVectorialFillDiff.Apply(AFill: TVectorialFill);
168 var
169 oldChange: TVectorialFillChangeEvent;
170 begin
171 oldChange := AFill.OnChange;
172 AFill.OnChange := nil;
173 AFill.Assign(FEnd);
174 AFill.OnChange := oldChange;
175 AFill.NotifyChangeWithoutDiff;
176 end;
177
178 procedure TVectorialFillDiff.Unapply(AFill: TVectorialFill);
179 var
180 oldChange: TVectorialFillChangeEvent;
181 begin
182 oldChange := AFill.OnChange;
183 AFill.OnChange := nil;
184 AFill.Assign(FStart);
185 AFill.OnChange := oldChange;
186 AFill.NotifyChangeWithoutDiff;
187 end;
188
TVectorialFillDiff.IsIdentitynull189 function TVectorialFillDiff.IsIdentity: boolean;
190 begin
191 result := TVectorialFill.Equal(FStart,FEnd);
192 end;
193
CanAppendnull194 function TVectorialFillDiff.CanAppend(ADiff: TCustomVectorialFillDiff
195 ): boolean;
196 begin
197 result := ADiff is TVectorialFillDiff;
198 end;
199
200 procedure TVectorialFillDiff.Append(ADiff: TCustomVectorialFillDiff);
201 begin
202 FEnd.Assign((ADiff as TVectorialFillDiff).FEnd);
203 end;
204
205 { TVectorialFillGradientDiff }
206
207 constructor TVectorialFillGradientDiff.Create(
208 AGradientDiff: TBGRAGradientOriginalDiff);
209 begin
210 FGradientDiff := AGradientDiff;
211 end;
212
213 destructor TVectorialFillGradientDiff.Destroy;
214 begin
215 FGradientDiff.Free;
216 inherited Destroy;
217 end;
218
219 procedure TVectorialFillGradientDiff.Apply(AFill: TVectorialFill);
220 begin
221 if AFill.FillType = vftGradient then
222 FGradientDiff.Apply(AFill.Gradient);
223 end;
224
225 procedure TVectorialFillGradientDiff.Unapply(AFill: TVectorialFill);
226 begin
227 if AFill.FillType = vftGradient then
228 FGradientDiff.Unapply(AFill.Gradient);
229 end;
230
TVectorialFillGradientDiff.IsIdentitynull231 function TVectorialFillGradientDiff.IsIdentity: boolean;
232 begin
233 result := false;
234 end;
235
CanAppendnull236 function TVectorialFillGradientDiff.CanAppend(ADiff: TCustomVectorialFillDiff): boolean;
237 begin
238 result := (ADiff is TVectorialFillGradientDiff) and
239 FGradientDiff.CanAppend(TVectorialFillGradientDiff(ADiff).FGradientDiff);
240 end;
241
242 procedure TVectorialFillGradientDiff.Append(ADiff: TCustomVectorialFillDiff);
243 var
244 nextDiff: TVectorialFillGradientDiff;
245 begin
246 nextDiff := ADiff as TVectorialFillGradientDiff;
247 FGradientDiff.Append(nextDiff.FGradientDiff);
248 end;
249
250 { TVectorialFill }
251
252 procedure TVectorialFill.SetOnChange(AValue: TVectorialFillChangeEvent);
253 begin
254 if FOnChange=AValue then Exit;
255 FOnChange:=AValue;
256 end;
257
258 procedure TVectorialFill.SetTextureMatrix(AValue: TAffineMatrix);
259 begin
260 if FillType <> vftTexture then raise exception.Create(rsNotTextureFill);
261 if FTextureMatrix=AValue then Exit;
262 BeginUpdate;
263 FTextureMatrix:=AValue;
264 EndUpdate;
265 end;
266
267 procedure TVectorialFill.SetTextureOpacity(AValue: byte);
268 begin
269 if FillType <> vftTexture then raise exception.Create(rsNotTextureFill);
270 if FTextureOpacity=AValue then Exit;
271 BeginUpdate;
272 FTextureOpacity:=AValue;
273 EndUpdate;
274 end;
275
276 procedure TVectorialFill.InternalClear;
277 begin
278 if Assigned(FTexture) then
279 begin
280 FTexture.FreeReference;
281 FTexture := nil;
282 end;
283 if Assigned(FGradient) then
284 begin
285 FGradient.OnChange := nil;
286 FreeAndNil(FGradient);
287 end;
288 FIsSolid := false;
289 FColor := BGRAPixelTransparent;
290 FTextureMatrix := AffineMatrixIdentity;
291 FTextureRepetition:= trRepeatBoth;
292 FTextureAverageColorComputed:= false;
293 end;
294
295 procedure TVectorialFill.BeginUpdate;
296 begin
297 if Assigned(OnBeforeChange) then
298 OnBeforeChange(self);
299 if Assigned(OnChange) and (FDiff = nil) then
300 FDiff := TVectorialFillDiff.Create(self);
301 end;
302
303 procedure TVectorialFill.EndUpdate;
304 begin
305 if Assigned(OnChange) then
306 begin
307 if Assigned(FDiff) then
308 begin
309 FDiff.ComputeDiff(self);
310 if not FDiff.IsIdentity then OnChange(self, FDiff);
311 end
312 else
313 OnChange(self, FDiff);
314 end;
315 FreeAndNil(FDiff);
316 end;
317
318 procedure TVectorialFill.NotifyChangeWithoutDiff;
319 var diff: TCustomVectorialFillDiff;
320 begin
321 if Assigned(FOnChange) then
322 begin
323 diff := nil;
324 FOnChange(self, diff);
325 end;
326 end;
327
328 procedure TVectorialFill.ConfigureTextureEditor(AEditor: TBGRAOriginalEditor);
329 var
330 origin, xAxisRel, yAxisRel: TPointF;
331 begin
332 if Assigned(FTexture) then
333 begin
334 origin := PointF(FTextureMatrix[1,3],FTextureMatrix[2,3]);
335 xAxisRel := PointF(FTextureMatrix[1,1],FTextureMatrix[2,1]);
336 yAxisRel := PointF(FTextureMatrix[1,2],FTextureMatrix[2,2]);
337 AEditor.AddPoint(origin, @TextureMoveOrigin, true);
338 if FTexture.Width > 0 then
339 AEditor.AddArrow(origin, origin+xAxisRel*FTexture.Width, @TextureMoveXAxis);
340 if FTexture.Height > 0 then
341 AEditor.AddArrow(origin, origin+yAxisRel*FTexture.Height, @TextureMoveYAxis);
342 AEditor.AddStartMoveHandler(@TextureStartMove);
343 end;
344 end;
345
346 procedure TVectorialFill.TextureMoveOrigin(ASender: TObject; APrevCoord,
347 ANewCoord: TPointF; AShift: TShiftState);
348 begin
349 BeginUpdate;
350 FTextureMatrix[1,3] := ANewCoord.x;
351 FTextureMatrix[2,3] := ANewCoord.y;
352 EndUpdate;
353 end;
354
355 procedure TVectorialFill.TextureMoveXAxis(ASender: TObject; APrevCoord,
356 ANewCoord: TPointF; AShift: TShiftState);
357 var
358 origin, xAxisRel: TPointF;
359 begin
360 BeginUpdate;
361 FTextureMatrix := FTextureMatrixBackup;
362 origin := PointF(FTextureMatrix[1,3],FTextureMatrix[2,3]);
363 xAxisRel := (ANewCoord - origin)*(1/FTexture.Width);
364 if ssAlt in AShift then
365 begin
366 FTextureMatrix[1,1] := xAxisRel.x;
367 FTextureMatrix[2,1] := xAxisRel.y;
368 end
369 else
370 FTextureMatrix := AffineMatrixTranslation(origin.x,origin.y)*
371 AffineMatrixScaledRotation(PointF(FTextureMatrix[1,1],FTextureMatrix[2,1]), xAxisRel)*
372 AffineMatrixLinear(FTextureMatrix);
373 EndUpdate;
374 end;
375
376 procedure TVectorialFill.TextureMoveYAxis(ASender: TObject; APrevCoord,
377 ANewCoord: TPointF; AShift: TShiftState);
378 var
379 origin, yAxisRel: TPointF;
380 begin
381 BeginUpdate;
382 FTextureMatrix := FTextureMatrixBackup;
383 origin := PointF(FTextureMatrix[1,3],FTextureMatrix[2,3]);
384 yAxisRel := (ANewCoord - origin)*(1/FTexture.Height);
385 if ssAlt in AShift then
386 begin
387 FTextureMatrix[1,2] := yAxisRel.x;
388 FTextureMatrix[2,2] := yAxisRel.y;
389 end
390 else
391 FTextureMatrix := AffineMatrixTranslation(origin.x,origin.y)*
392 AffineMatrixScaledRotation(PointF(FTextureMatrix[1,2],FTextureMatrix[2,2]), yAxisRel)*
393 AffineMatrixLinear(FTextureMatrix);
394 EndUpdate;
395 end;
396
397 procedure TVectorialFill.TextureStartMove(ASender: TObject; AIndex: integer;
398 AShift: TShiftState);
399 begin
400 FTextureMatrixBackup := FTextureMatrix;
401 end;
402
403 procedure TVectorialFill.Init;
404 begin
405 FColor := BGRAPixelTransparent;
406 FTexture := nil;
407 FTextureMatrix := AffineMatrixIdentity;
408 FTextureOpacity:= 255;
409 FTextureAverageColorComputed:= false;
410 FGradient := nil;
411 FIsSolid := false;
412 FTransparentMode := tmEnforeAllChannelsZero;
413 end;
414
TVectorialFill.GetIsEditablenull415 function TVectorialFill.GetIsEditable: boolean;
416 begin
417 result:= FillType in [vftGradient, vftTexture];
418 end;
419
420 procedure TVectorialFill.SetTextureRepetition(AValue: TTextureRepetition);
421 begin
422 if FillType <> vftTexture then raise exception.Create(rsNotTextureFill);
423 if FTextureRepetition=AValue then Exit;
424 BeginUpdate;
425 FTextureRepetition:=AValue;
426 EndUpdate;
427 end;
428
TVectorialFill.GetFillTypenull429 function TVectorialFill.GetFillType: TVectorialFillType;
430 begin
431 if FIsSolid then result:= vftSolid
432 else if Assigned(FGradient) then result := vftGradient
433 else if Assigned(FTexture) then result := vftTexture
434 else result := vftNone;
435 end;
436
TVectorialFill.GetAverageColornull437 function TVectorialFill.GetAverageColor: TBGRAPixel;
438 begin
439 case FillType of
440 vftNone: result := BGRAPixelTransparent;
441 vftGradient: result := Gradient.AverageColor;
442 vftTexture: begin
443 if not FTextureAverageColorComputed then
444 begin
445 if Assigned(FTexture) then
446 FTextureAverageColor := FTexture.AverageColor
447 else
448 FTextureAverageColor := BGRAPixelTransparent;
449 FTextureAverageColorComputed := true;
450 end;
451 result := FTextureAverageColor;
452 result.alpha := BGRABlend.ApplyOpacity(result.alpha, TextureOpacity);
453 end
454 else {vftSolid} result := SolidColor;
455 end;
456 end;
457
458 procedure TVectorialFill.SetTransparentMode(AValue: TTransparentMode);
459 begin
460 if FTransparentMode=AValue then Exit;
461 if (FillType = vftSolid) and (SolidColor.alpha = 0) then
462 begin
463 case FTransparentMode of
464 tmNoFill: Clear;
465 tmEnforeAllChannelsZero: SolidColor := BGRAPixelTransparent;
466 end;
467 end;
468 FTransparentMode:=AValue;
469 end;
470
471 procedure TVectorialFill.GradientChange(ASender: TObject; ABounds: PRectF; var ADiff: TBGRAOriginalDiff);
472 var
473 fillDiff: TVectorialFillGradientDiff;
474 begin
475 if Assigned(FDiff) then
476 begin
477 FreeAndNil(ADiff);
478 exit;
479 end;
480 if Assigned(OnChange) then
481 begin
482 if Assigned(ADiff) then
483 begin
484 fillDiff := TVectorialFillGradientDiff.Create(ADiff as TBGRAGradientOriginalDiff);
485 ADiff := nil;
486 end else
487 fillDiff := nil;
488 FOnChange(self, fillDiff);
489 fillDiff.Free;
490 end;
491 end;
492
493 constructor TVectorialFill.Create;
494 begin
495 Init;
496 end;
497
498 procedure TVectorialFill.Clear;
499 begin
500 if FillType <> vftNone then
501 begin
502 BeginUpdate;
503 InternalClear;
504 EndUpdate;
505 end else
506 InternalClear;
507 end;
508
509 constructor TVectorialFill.CreateAsSolid(AColor: TBGRAPixel);
510 begin
511 Init;
512 SetSolid(AColor);
513 end;
514
515 constructor TVectorialFill.CreateAsTexture(ATexture: TBGRABitmap;
516 AMatrix: TAffineMatrix; AOpacity: byte; ATextureRepetition: TTextureRepetition);
517 begin
518 Init;
519 SetTexture(ATexture,AMatrix,AOpacity,ATextureRepetition);
520 end;
521
522 constructor TVectorialFill.CreateAsGradient(
523 AGradient: TBGRALayerGradientOriginal; AOwned: boolean);
524 begin
525 Init;
526 SetGradient(AGradient,AOwned);
527 end;
528
529 procedure TVectorialFill.SetSolid(AColor: TBGRAPixel);
530 begin
531 if AColor.alpha = 0 then
532 case TransparentMode of
533 tmNoFill: begin Clear; exit; end;
534 tmEnforeAllChannelsZero: AColor := BGRAPixelTransparent;
535 end;
536 if (FillType = vftSolid) and SolidColor.EqualsExactly(AColor) then exit;
537 BeginUpdate;
538 InternalClear;
539 FColor := AColor;
540 FIsSolid:= true;
541 EndUpdate;
542 end;
543
544 procedure TVectorialFill.SetTexture(ATexture: TBGRABitmap;
545 AMatrix: TAffineMatrix; AOpacity: byte; ATextureRepetition: TTextureRepetition);
546 begin
547 BeginUpdate;
548 InternalClear;
549 FTexture := ATexture.NewReference as TBGRABitmap;
550 FTextureMatrix := AMatrix;
551 FTextureOpacity:= AOpacity;
552 FTextureRepetition:= ATextureRepetition;
553 FTextureAverageColorComputed:= false;
554 EndUpdate;
555 end;
556
557 procedure TVectorialFill.SetGradient(AGradient: TBGRALayerGradientOriginal;
558 AOwned: boolean);
559 begin
560 BeginUpdate;
561 InternalClear;
562 if AOwned then FGradient := AGradient
563 else FGradient := AGradient.Duplicate as TBGRALayerGradientOriginal;
564 FGradient.OnChange:= @GradientChange;
565 EndUpdate;
566 end;
567
568 procedure TVectorialFill.ConfigureEditor(AEditor: TBGRAOriginalEditor);
569 begin
570 case FillType of
571 vftGradient: Gradient.ConfigureEditor(AEditor);
572 vftTexture: ConfigureTextureEditor(AEditor);
573 end;
574 end;
575
TVectorialFill.CreateScannernull576 function TVectorialFill.CreateScanner(AMatrix: TAffineMatrix; ADraft: boolean
577 ): TBGRACustomScanner;
578 var
579 bmpTransf: TBGRAAffineBitmapTransform;
580 filter: TResampleFilter;
581 m: TAffineMatrix;
582 begin
583 if Assigned(FTexture) then
584 begin
585 m := AMatrix*FTextureMatrix;
586 if ADraft or TBGRABitmap.IsAffineRoughlyTranslation(m, rect(0,0,FTexture.Width,FTexture.Height)) then filter := rfBox
587 else filter := rfHalfCosine;
588 bmpTransf := TBGRAAffineBitmapTransform.Create(FTexture,
589 FTextureRepetition in[trRepeatX,trRepeatBoth],
590 FTextureRepetition in[trRepeatY,trRepeatBoth], filter);
591 bmpTransf.ViewMatrix := m;
592 if FTextureOpacity <> 255 then
593 result:= TBGRAOpacityScanner.Create(bmpTransf, FTextureOpacity, true)
594 else
595 result := bmpTransf;
596 end else
597 if Assigned(FGradient) then
598 result := FGradient.CreateScanner(AMatrix, ADraft)
599 else if FIsSolid then
600 result := TBGRAConstantScanner.Create(FColor)
601 else
602 result := nil;
603 end;
604
IsSlownull605 function TVectorialFill.IsSlow(AMatrix: TAffineMatrix): boolean;
606 var
607 m: TAffineMatrix;
608 begin
609 if Assigned(FTexture) then
610 begin
611 m := AMatrix*FTextureMatrix;
612 result := not TBGRABitmap.IsAffineRoughlyTranslation(m, rect(0,0,FTexture.Width,FTexture.Height));
613 end else
614 result := (FillType = vftGradient);
615 end;
616
TVectorialFill.IsFullyTransparentnull617 function TVectorialFill.IsFullyTransparent: boolean;
618 begin
619 case FillType of
620 vftNone: result := true;
621 vftSolid: result:= SolidColor.alpha = 0;
622 else result:= false;
623 end;
624 end;
625
626 procedure TVectorialFill.Transform(AMatrix: TAffineMatrix);
627 begin
628 case FillType of
629 vftGradient: Gradient.Transform(AMatrix);
630 vftTexture:
631 begin
632 BeginUpdate;
633 FTextureMatrix := AMatrix*FTextureMatrix;
634 EndUpdate;
635 end;
636 end;
637 end;
638
TVectorialFill.Duplicatenull639 function TVectorialFill.Duplicate: TVectorialFill;
640 begin
641 result := TVectorialFill.Create;
642 result.Assign(self);
643 end;
644
645 destructor TVectorialFill.Destroy;
646 begin
647 InternalClear;
648 inherited Destroy;
649 end;
650
Equalsnull651 function TVectorialFill.Equals(Obj: TObject): boolean;
652 var
653 other: TVectorialFill;
654 begin
655 if inherited Equals(Obj) then
656 result := true
657 else
658 if Obj = nil then
659 result := (FillType = vftNone)
660 else
661 if Obj is TVectorialFill then
662 begin
663 other := TVectorialFill(Obj);
664 if Self = nil then
665 result := (other.FillType = vftNone)
666 else
667 begin
668 case other.FillType of
669 vftSolid: result := (FillType = vftSolid) and other.SolidColor.EqualsExactly(SolidColor);
670 vftGradient: result := (FillType = vftGradient) and (other.Gradient.Equals(Gradient));
671 vftTexture: result := (FillType = vftTexture) and (other.Texture = Texture) and
672 (other.TextureMatrix = TextureMatrix) and (other.TextureOpacity = TextureOpacity)
673 and (other.TextureRepetition = TextureRepetition);
674 else
675 result := FillType = vftNone;
676 end;
677 end;
678 end else
679 result:= false;
680 end;
681
TVectorialFill.Equalnull682 class function TVectorialFill.Equal(AFill1, AFill2: TVectorialFill): boolean;
683 begin
684 if AFill1 = nil then
685 begin
686 if AFill2 = nil then result := true
687 else result := (AFill2.FillType = vftNone);
688 end else
689 result := AFill1.Equals(AFill2);
690 end;
691
692 procedure TVectorialFill.Assign(Obj: TObject);
693 var
694 other: TVectorialFill;
695 begin
696 if Obj = nil then Clear else
697 if Obj is TVectorialFill then
698 begin
699 other := TVectorialFill(Obj);
700 case other.FillType of
701 vftSolid: SetSolid(other.SolidColor);
702 vftGradient: SetGradient(other.Gradient, false);
703 vftTexture: SetTexture(other.Texture, other.TextureMatrix, other.TextureOpacity, other.TextureRepetition);
704 else Clear;
705 end;
706 end else
707 raise exception.Create(rsIncompatibleType);
708 end;
709
710 procedure TVectorialFill.AssignExceptGeometry(Obj: TObject);
711 var
712 other: TVectorialFill;
713 tempGrad: TBGRALayerGradientOriginal;
714 begin
715 if Obj = nil then Clear else
716 if Obj is TVectorialFill then
717 begin
718 other := TVectorialFill(Obj);
719 case other.FillType of
720 vftSolid: SetSolid(other.SolidColor);
721 vftGradient: begin
722 if self.FillType = vftGradient then
723 tempGrad := self.Gradient.Duplicate as TBGRALayerGradientOriginal
724 else
725 tempGrad := TBGRALayerGradientOriginal.Create;
726 tempGrad.AssignExceptGeometry(other.Gradient);
727 SetGradient(tempGrad, true);
728 end;
729 vftTexture: if self.FillType = vftTexture then
730 SetTexture(other.Texture, self.TextureMatrix, other.TextureOpacity, other.TextureRepetition)
731 else SetTexture(other.Texture, AffineMatrixIdentity, other.TextureOpacity, other.TextureRepetition);
732 else Clear;
733 end;
734 end else
735 raise exception.Create(rsIncompatibleType);
736 end;
737
738 procedure TVectorialFill.FitGeometry(const ABox: TAffineBox);
739 var
740 sx,sy: single;
741 u, v: TPointF;
742 begin
743 case FillType of
744 vftTexture:
745 if Assigned(Texture) then
746 begin
747 if not (TextureRepetition in [trRepeatX,trRepeatBoth]) and (Texture.Width > 0) then
748 sx:= 1/Texture.Width else if ABox.Width > 0 then sx:= 1/ABox.Width else sx := 1;
749 if not (TextureRepetition in [trRepeatY,trRepeatBoth]) and (Texture.Height > 0) then
750 sy:= 1/Texture.Height else if ABox.Height > 0 then sy:= 1/ABox.Height else sy := 1;
751
752 u := (ABox.TopRight-ABox.TopLeft)*sx;
753 v := (ABox.BottomLeft-ABox.TopLeft)*sy;
754 TextureMatrix := AffineMatrix(u, v, ABox.TopLeft);
755 end;
756 vftGradient:
757 Gradient.FitGeometry(ABox);
758 end;
759 end;
760
761 procedure TVectorialFill.ApplyOpacity(AOpacity: Byte);
762 var
763 c: TBGRAPixel;
764 begin
765 case FillType of
766 vftSolid: begin
767 c := SolidColor;
768 c.alpha := BGRABlend.ApplyOpacity(c.alpha, AOpacity);
769 SolidColor := c;
770 end;
771 vftGradient: Gradient.ApplyOpacity(AOpacity);
772 vftTexture: TextureOpacity := BGRABlend.ApplyOpacity(TextureOpacity, AOpacity);
773 end;
774 end;
775
776 end.
777
778