1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRAGradientOriginal;
3 
4 {$mode objfpc}{$H+}
5 
6 interface
7 
8 uses
9   BGRAClasses, SysUtils, BGRALayerOriginal, BGRABitmap, BGRABitmapTypes, BGRAGradientScanner,
10   BGRASVG, BGRASVGShapes, BGRASVGType;
11 
12 type
13   TBGRAColorInterpolation = BGRAGradientScanner.TBGRAColorInterpolation;
14   TBGRAGradientRepetition = BGRAGradientScanner.TBGRAGradientRepetition;
15   TBGRALayerGradientOriginal = class;
16 
17   { TBGRAGradientOriginalDiff }
18 
19   TBGRAGradientOriginalDiff = class(TBGRAOriginalDiff)
20   protected
21     FStorageBefore, FStorageAfter: TBGRAMemOriginalStorage;
22   public
23     constructor Create(AOriginal: TBGRALayerGradientOriginal);
24     procedure ComputeDifference(AOriginal: TBGRALayerGradientOriginal);
25     destructor Destroy; override;
26     procedure Apply(AOriginal: TBGRALayerCustomOriginal); override;
27     procedure Unapply(AOriginal: TBGRALayerCustomOriginal); override;
CanAppendnull28     function CanAppend(ADiff: TBGRAOriginalDiff): boolean; override;
29     procedure Append(ADiff: TBGRAOriginalDiff); override;
IsIdentitynull30     function IsIdentity: boolean; override;
31   end;
32 
33   { TBGRALayerGradientOriginal }
34 
35   TBGRALayerGradientOriginal = class(TBGRALayerCustomOriginal)
36   private
GetIsOpaquenull37     function GetIsOpaque: boolean;
38     procedure SetColorInterpolation(AValue: TBGRAColorInterpolation);
39     procedure SetEndColor(AValue: TBGRAPixel);
40     procedure SetFocalPoint(AValue: TPointF);
41     procedure SetFocalRadius(AValue: Single);
42     procedure SetGradientType(AValue: TGradientType);
43     procedure SetOrigin(AValue: TPointF);
44     procedure SetRadius(AValue: Single);
45     procedure SetRepetition(AValue: TBGRAGradientRepetition);
46     procedure SetStartColor(AValue: TBGRAPixel);
47     procedure SetXAxis(AValue: TPointF);
48     procedure SetYAxis(AValue: TPointF);
49   protected
50     FStartColor,FEndColor: TBGRAPixel;
51     FGradientType: TGradientType;
52     FOrigin,FXAxis,FYAxis,FFocalPoint: TPointF;
53     FOriginBackup,FXAxisBackup, FYAxisBackup: TPointF;
54     FRadius,FFocalRadius: single;
55     FColorInterpolation: TBGRAColorInterpolation;
56     FRepetition: TBGRAGradientRepetition;
57     FUpdateCount: integer;
58     FUpdateDiff: TBGRAGradientOriginalDiff;
GetAverageColornull59     function GetAverageColor: TBGRAPixel;
GetComputedRadiusnull60     function GetComputedRadius: single;
GetComputedYAxisnull61     function GetComputedYAxis: TPointF;
GetComputedFocalPointnull62     function GetComputedFocalPoint: TPointF;
GetComputedFocalRadiusnull63     function GetComputedFocalRadius: single;
64     procedure OnMoveOrigin({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
65     procedure OnMoveXAxis({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
66     procedure OnMoveXAxisNeg({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
67     procedure OnMoveYAxis({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
68     procedure OnMoveFocalPoint({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
69     procedure OnMoveFocalRadius({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
70     procedure OnStartMove({%H-}ASender: TObject; {%H-}AIndex: integer; {%H-}AShift: TShiftState);
71     procedure BeginUpdate;
72     procedure EndUpdate;
73     procedure NotifyChangeWithoutDiff;
74   public
75     constructor Create; override;
76     destructor Destroy; override;
ConvertToSVGnull77     function ConvertToSVG(const AMatrix: TAffineMatrix; out AOffset: TPoint): TObject; override;
AddToSVGDefsnull78     function AddToSVGDefs(const AMatrix: TAffineMatrix; ADefs: TSVGDefine): TObject;
IsInfiniteSurfacenull79     function IsInfiniteSurface: boolean; override;
80     procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); overload; override;
81     procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean; ADrawMode: TDrawMode); overload;
CreateScannernull82     function CreateScanner(AMatrix: TAffineMatrix; ADraft: boolean = false): TBGRACustomScanner;
83     procedure ConfigureEditor(AEditor: TBGRAOriginalEditor); override;
GetRenderBoundsnull84     function GetRenderBounds(ADestRect: TRect; {%H-}AMatrix: TAffineMatrix): TRect; override;
85     procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
86     procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
StorageClassNamenull87     class function StorageClassName: RawByteString; override;
CanConvertToSVGnull88     class function CanConvertToSVG: boolean; override;
89     property ComputedYAxis: TPointF read GetComputedYAxis;
90     property ComputedRadius: single read GetComputedRadius;
91     property ComputedFocalPoint: TPointF read GetComputedFocalPoint;
92     property ComputedFocalRadius: single read GetComputedFocalRadius;
93     procedure Transform(AMatrix: TAffineMatrix);
94     procedure AssignExceptGeometry(AOther: TBGRALayerGradientOriginal);
95     procedure FitGeometry(const ABox: TAffineBox);
96     procedure SetColors(AStartColor, AEndColor: TBGRAPixel);
97     procedure ApplyOpacity(AOpacity: byte);
Equalsnull98     function Equals(Obj: TObject): boolean; override;
99 
100     property StartColor: TBGRAPixel read FStartColor write SetStartColor;
101     property EndColor: TBGRAPixel read FEndColor write SetEndColor;
102     property AverageColor: TBGRAPixel read GetAverageColor;
103     property GradientType: TGradientType read FGradientType write SetGradientType;   //default gtLinear
104     property Origin: TPointF read FOrigin write SetOrigin;
105     property XAxis: TPointF read FXAxis write SetXAxis;
106     property YAxis: TPointF read FYAxis write SetYAxis;
107     property FocalPoint: TPointF read FFocalPoint write SetFocalPoint;     //default Origin
108     property Radius: Single read FRadius write SetRadius;                  //default 1
109     property FocalRadius: Single read FFocalRadius write SetFocalRadius;   //default 0
110     property ColorInterpolation: TBGRAColorInterpolation read FColorInterpolation write SetColorInterpolation;
111     property Repetition: TBGRAGradientRepetition read FRepetition write SetRepetition;
112     property IsOpaque: boolean read GetIsOpaque;
113 
114   end;
115 
116 implementation
117 
118 uses BGRATransform, BGRABlend, math;
119 
120 { TBGRAGradientOriginalDiff }
121 
122 constructor TBGRAGradientOriginalDiff.Create(AOriginal: TBGRALayerGradientOriginal);
123 begin
124   FStorageBefore := TBGRAMemOriginalStorage.Create;
125   AOriginal.SaveToStorage(FStorageBefore);
126 end;
127 
128 procedure TBGRAGradientOriginalDiff.ComputeDifference(
129   AOriginal: TBGRALayerGradientOriginal);
130 begin
131   if Assigned(FStorageAfter) then FreeAndNil(FStorageAfter);
132   FStorageAfter := TBGRAMemOriginalStorage.Create;
133   AOriginal.SaveToStorage(FStorageAfter);
134 end;
135 
136 destructor TBGRAGradientOriginalDiff.Destroy;
137 begin
138   FStorageBefore.Free;
139   FStorageAfter.Free;
140   inherited Destroy;
141 end;
142 
143 procedure TBGRAGradientOriginalDiff.Apply(AOriginal: TBGRALayerCustomOriginal);
144 begin
145   if not Assigned(FStorageAfter) then raise exception.Create('Undefined state after diff');
146   AOriginal.LoadFromStorage(FStorageAfter);
147   (AOriginal as TBGRALayerGradientOriginal).NotifyChangeWithoutDiff;
148 end;
149 
150 procedure TBGRAGradientOriginalDiff.Unapply(AOriginal: TBGRALayerCustomOriginal);
151 begin
152   if not Assigned(FStorageBefore) then raise exception.Create('Undefined state before diff');
153   AOriginal.LoadFromStorage(FStorageBefore);
154   (AOriginal as TBGRALayerGradientOriginal).NotifyChangeWithoutDiff;
155 end;
156 
TBGRAGradientOriginalDiff.CanAppendnull157 function TBGRAGradientOriginalDiff.CanAppend(ADiff: TBGRAOriginalDiff): boolean;
158 begin
159   result := ADiff is TBGRAGradientOriginalDiff;
160 end;
161 
162 procedure TBGRAGradientOriginalDiff.Append(ADiff: TBGRAOriginalDiff);
163 var
164   next: TBGRAGradientOriginalDiff;
165 begin
166   next := ADiff as TBGRAGradientOriginalDiff;
167   FreeAndNil(FStorageAfter);
168   FStorageAfter := next.FStorageAfter.Duplicate as TBGRAMemOriginalStorage;
169 end;
170 
IsIdentitynull171 function TBGRAGradientOriginalDiff.IsIdentity: boolean;
172 begin
173   result := FStorageBefore.Equals(FStorageAfter);
174 end;
175 
176 { TBGRALayerGradientOriginal }
177 
GetComputedRadiusnull178 function TBGRALayerGradientOriginal.GetComputedRadius: single;
179 begin
180   if FRadius = EmptySingle then result := 1 else result := FRadius;
181 end;
182 
TBGRALayerGradientOriginal.GetAverageColornull183 function TBGRALayerGradientOriginal.GetAverageColor: TBGRAPixel;
184 begin
185   result := MergeBGRAWithGammaCorrection(StartColor, 1, EndColor, 1);
186 end;
187 
GetIsOpaquenull188 function TBGRALayerGradientOriginal.GetIsOpaque: boolean;
189 var
190   xLen, yLen, focalLen: Single;
191   focalCoord, u, v: TPointF;
192 begin
193   result := (StartColor.alpha = 255) and (EndColor.alpha = 255);
194   if result and (GradientType = gtRadial) and not FocalPoint.IsEmpty and
195     not Origin.IsEmpty and not XAxis.IsEmpty then
196   begin
197     u := XAxis - Origin;
198     v := ComputedYAxis - Origin;
199     xLen := VectLen(u);
200     yLen := VectLen(v);
201     if (xLen = 0) or (yLen = 0) then
202       result := false
203     else
204     begin
205       focalCoord := PointF((FocalPoint - Origin)*u/sqr(xLen),
206                            (FocalPoint - Origin)*v/sqr(yLen));
207       focalLen := VectLen(focalCoord);
208       if (focalLen + ComputedFocalRadius + 0.01 >= ComputedRadius) and not
209         (ComputedFocalRadius > focalLen + ComputedRadius + 0.01) then
210         result := false;
211     end;
212   end;
213 end;
214 
215 procedure TBGRALayerGradientOriginal.SetColorInterpolation(
216   AValue: TBGRAColorInterpolation);
217 begin
218   if FColorInterpolation=AValue then Exit;
219   BeginUpdate;
220   FColorInterpolation:=AValue;
221   EndUpdate;
222 end;
223 
224 procedure TBGRALayerGradientOriginal.SetEndColor(AValue: TBGRAPixel);
225 begin
226   if FEndColor.EqualsExactly(AValue) then Exit;
227   BeginUpdate;
228   FEndColor:=AValue;
229   EndUpdate;
230 end;
231 
232 procedure TBGRALayerGradientOriginal.SetFocalPoint(AValue: TPointF);
233 begin
234   if FFocalPoint=AValue then Exit;
235   BeginUpdate;
236   FFocalPoint:=AValue;
237   EndUpdate;
238 end;
239 
240 procedure TBGRALayerGradientOriginal.SetFocalRadius(AValue: Single);
241 begin
242   if FFocalRadius=AValue then Exit;
243   BeginUpdate;
244   FFocalRadius:=AValue;
245   EndUpdate;
246 end;
247 
248 procedure TBGRALayerGradientOriginal.SetGradientType(AValue: TGradientType);
249 begin
250   if FGradientType=AValue then Exit;
251   BeginUpdate;
252   FGradientType:=AValue;
253   if FGradientType in [gtLinear,gtReflected] then FYAxis := EmptyPointF;
254   EndUpdate;
255 end;
256 
257 procedure TBGRALayerGradientOriginal.SetOrigin(AValue: TPointF);
258 begin
259   if FOrigin=AValue then Exit;
260   BeginUpdate;
261   FOrigin:=AValue;
262   EndUpdate;
263 end;
264 
265 procedure TBGRALayerGradientOriginal.SetRadius(AValue: Single);
266 begin
267   if FRadius=AValue then Exit;
268   BeginUpdate;
269   FRadius:=AValue;
270   EndUpdate;
271 end;
272 
273 procedure TBGRALayerGradientOriginal.SetRepetition(
274   AValue: TBGRAGradientRepetition);
275 begin
276   if FRepetition=AValue then Exit;
277   BeginUpdate;
278   FRepetition:=AValue;
279   EndUpdate;
280 end;
281 
282 procedure TBGRALayerGradientOriginal.SetStartColor(AValue: TBGRAPixel);
283 begin
284   if FStartColor.EqualsExactly(AValue) then Exit;
285   BeginUpdate;
286   FStartColor:=AValue;
287   EndUpdate;
288 end;
289 
290 procedure TBGRALayerGradientOriginal.SetXAxis(AValue: TPointF);
291 begin
292   if FXAxis=AValue then Exit;
293   BeginUpdate;
294   FXAxis:=AValue;
295   EndUpdate;
296 end;
297 
298 procedure TBGRALayerGradientOriginal.SetYAxis(AValue: TPointF);
299 begin
300   if FYAxis=AValue then Exit;
301   BeginUpdate;
302   FYAxis:=AValue;
303   EndUpdate;
304 end;
305 
TBGRALayerGradientOriginal.GetComputedYAxisnull306 function TBGRALayerGradientOriginal.GetComputedYAxis: TPointF;
307 var
308   u: TPointF;
309 begin
310   if isEmptyPointF(FYAxis) then
311   begin
312     u := FXAxis - FOrigin;
313     result := FOrigin + PointF(-u.y,u.x)
314   end
315   else
316     result := FYAxis;
317 end;
318 
GetComputedFocalPointnull319 function TBGRALayerGradientOriginal.GetComputedFocalPoint: TPointF;
320 begin
321   if isEmptyPointF(FFocalPoint) then result := FOrigin else result := FFocalPoint;
322 end;
323 
GetComputedFocalRadiusnull324 function TBGRALayerGradientOriginal.GetComputedFocalRadius: single;
325 begin
326   if FFocalRadius = EmptySingle then result := 0 else result := FFocalRadius;
327 end;
328 
329 procedure TBGRALayerGradientOriginal.OnMoveOrigin(ASender: TObject; APrevCoord,
330   ANewCoord: TPointF; AShift: TShiftState);
331 var
332   delta: TPointF;
333 begin
334   BeginUpdate;
335   delta := ANewCoord-APrevCoord;
336   FOrigin.Offset(delta);
337   FXAxis.Offset(delta);
338   FYAxis.Offset(delta);
339   FFocalPoint.Offset(delta);
340   EndUpdate;
341 end;
342 
343 procedure TBGRALayerGradientOriginal.OnMoveXAxis(ASender: TObject; APrevCoord,
344   ANewCoord: TPointF; AShift: TShiftState);
345 var
346   m: TAffineMatrix;
347   c: TPointF;
348 begin
349   BeginUpdate;
350   if not (ssAlt in AShift) or (GradientType in [gtLinear,gtReflected]) then
351   begin
352     if not isEmptyPointF(FYAxis) and not isEmptyPointF(FYAxisBackup) then
353     begin
354       m := AffineMatrixScaledRotation(FXAxisBackup, ANewCoord, FOrigin);
355       FYAxis := m*FYAxisBackup;
356     end;
357   end else
358     if isEmptyPointF(FYAxis) then FYAxis := ComputedYAxis;
359 
360   if (GradientType = gtLinear) and (ssShift in AShift) then
361   begin
362     c := (FOriginBackup+FXAxisBackup)*0.5;
363     m := AffineMatrixScaledRotation(FXAxisBackup, ANewCoord, c);
364     FOrigin := m*FOriginBackup;
365   end
366   else
367     FOrigin := FOriginBackup;
368 
369   FXAxis := ANewCoord;
370   EndUpdate;
371 end;
372 
373 procedure TBGRALayerGradientOriginal.OnMoveXAxisNeg(ASender: TObject;
374   APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
375 var
376   delta, c: TPointF;
377   m: TAffineMatrix;
378 begin
379   BeginUpdate;
380   delta := ANewCoord-APrevCoord;
381 
382   if (GradientType = gtLinear) and (ssShift in AShift) then
383   begin
384     c := (FOriginBackup+FXAxisBackup)*0.5;
385     m := AffineMatrixScaledRotation(FOriginBackup, (FOrigin+delta), c);
386     FXAxis := m*FXAxisBackup;
387   end
388   else
389     FXAxis := FXAxisBackup;
390 
391   FOrigin.Offset(delta);
392   EndUpdate;
393 end;
394 
395 procedure TBGRALayerGradientOriginal.OnMoveYAxis(ASender: TObject; APrevCoord,
396   ANewCoord: TPointF; AShift: TShiftState);
397 var
398   m: TAffineMatrix;
399 begin
400   BeginUpdate;
401   if not (ssAlt in AShift) or (GradientType in [gtLinear,gtReflected]) then
402   begin
403     if not isEmptyPointF(FXAxis) then
404     begin
405       m := AffineMatrixScaledRotation(FYAxisBackup, ANewCoord, FOrigin);
406       FXAxis := m*FXAxisBackup;
407     end;
408   end;
409   FYAxis := ANewCoord;
410   EndUpdate;
411 end;
412 
413 procedure TBGRALayerGradientOriginal.OnMoveFocalPoint(ASender: TObject;
414   APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
415 begin
416   FocalPoint := ANewCoord;
417 end;
418 
419 procedure TBGRALayerGradientOriginal.OnMoveFocalRadius(ASender: TObject;
420   APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
421 var refLen: single;
422   u, focalOrig: TPointF;
423 begin
424   BeginUpdate;
425   focalOrig := ComputedFocalPoint;
426   if isEmptyPointF(focalOrig) or isEmptyPointF(FOrigin) or isEmptyPointF(FXAxis) then exit;
427   refLen := VectLen(FOrigin-FXAxis);
428   if refLen = 0 then exit;
429 
430   u := (FOrigin-FXAxis)*(1/refLen);
431   FFocalRadius := u * (ANewCoord-focalOrig) / refLen - 0.1;
432   if FFocalRadius < 0 then FFocalRadius:= 0;
433   EndUpdate;
434 end;
435 
436 procedure TBGRALayerGradientOriginal.OnStartMove(ASender: TObject;
437   AIndex: integer; AShift: TShiftState);
438 begin
439   FOriginBackup := FOrigin;
440   FXAxisBackup := FXAxis;
441   FYAxisBackup := ComputedYAxis;
442 end;
443 
444 procedure TBGRALayerGradientOriginal.BeginUpdate;
445 begin
446   if DiffExpected and (FUpdateCount = 0) then
447     FUpdateDiff := TBGRAGradientOriginalDiff.Create(self);
448   inc(FUpdateCount);
449 end;
450 
451 procedure TBGRALayerGradientOriginal.EndUpdate;
452 begin
453   if FUpdateCount > 0 then
454   begin
455     dec(FUpdateCount);
456     if FUpdateCount = 0 then
457     begin
458       if Assigned(FUpdateDiff) then
459         FUpdateDiff.ComputeDifference(self);
460       NotifyChange(FUpdateDiff);
461       FUpdateDiff := nil;
462     end;
463   end;
464 end;
465 
466 procedure TBGRALayerGradientOriginal.NotifyChangeWithoutDiff;
467 begin
468   NotifyChange;
469 end;
470 
471 constructor TBGRALayerGradientOriginal.Create;
472 begin
473   inherited Create;
474   FStartColor := BGRABlack;
475   FEndColor := BGRAWhite;
476   FGradientType := gtLinear;
477   FColorInterpolation:= ciStdRGB;
478   FRepetition := grPad;
479   FRadius := EmptySingle;
480   FFocalRadius := EmptySingle;
481   FFocalPoint := EmptyPointF;
482   FOrigin := PointF(0,0);
483   FXAxis := EmptyPointF;
484   FYAxis := EmptyPointF;
485 end;
486 
487 destructor TBGRALayerGradientOriginal.Destroy;
488 begin
489   FUpdateDiff.Free;
490   inherited Destroy;
491 end;
492 
ConvertToSVGnull493 function TBGRALayerGradientOriginal.ConvertToSVG(const AMatrix: TAffineMatrix; out AOffset: TPoint): TObject;
494 var
495   svg: TBGRASVG;
496   def: TSVGDefine;
497   grad: TSVGGradient;
498   r: TSVGRectangle;
499 begin
500   AOffset:= Point(0, 0);
501   svg := TBGRASVG.Create(640, 480, cuPixel);  // potentially infinite
502   result := svg;
503   def := svg.Content.AppendDefine;
504   grad := AddToSVGDefs(AMatrix, def) as TSVGGradient;
505   r := svg.Content.AppendRect(0, 0, 100, 100, cuPercent);
506   if Assigned(grad) then
507   begin
508     grad.ID := 'grad1';
509     r.fill:= 'url(#grad1)';
510   end else
511     r.fillColor := AverageColor;
512 end;
513 
AddToSVGDefsnull514 function TBGRALayerGradientOriginal.AddToSVGDefs(const AMatrix: TAffineMatrix;
515   ADefs: TSVGDefine): TObject;
516 const ApproxCount = 16;
517   MaxReflectRepeatCount = 8;
518 var
519   grad: TSVGGradient;
520   colors: TBGRASimpleGradient;
521   tOrigin, tXAxis, tYAxis, tFocalPoint, reflectedXAxis, repeatedXAxis: TPointF;
522   gt: TGradientType;
523 
524   procedure AddColorStops(AOffset, AFactor: single; AIncludeStart: boolean);
525   var i, i0: integer;
526   begin
527     if (Repetition <> grSine) and (ColorInterpolation in [ciStdRGB, ciLinearRGB])  then
528     begin
529       if AFactor >= 0 then
530       begin
531         if AIncludeStart then
532           grad.Content.AppendStop(StartColor, AOffset, false);
533         grad.Content.AppendStop(EndColor, AOffset + AFactor*1, false);
534       end else
535       begin
536         grad.Content.AppendStop(EndColor, AOffset + AFactor*1, false);
537         if AIncludeStart then
538           grad.Content.AppendStop(StartColor, AOffset, false);
539       end;
540     end else
541     begin
542       colors := TBGRASimpleGradient.CreateAny(ColorInterpolation, StartColor,EndColor, Repetition);
543       try
544         if AIncludeStart then i0 := 0 else i0 := 1;
545         if AFactor >= 0 then
546         begin
547           for i := i0 to ApproxCount do
548             grad.Content.AppendStop(colors.GetColorAtF(i/ApproxCount), AOffset + AFactor*i/ApproxCount, false);
549         end else
550           for i := ApproxCount downto i0 do
551             grad.Content.AppendStop(colors.GetColorAtF(i/ApproxCount), AOffset + AFactor*i/ApproxCount, false);
552       finally
553         colors.Free;
554       end;
555     end;
556   end;
557 
558 var j: integer;
559   m: TAffineMatrix;
560   radialScale: Single;
561   fp, u, v: TPointF;
562   lenU, lenV: Single;
563 
564 begin
565   m := AffineMatrixTranslation(0.5, 0.5) * AMatrix;
566   tOrigin := m * Origin;
567   tXAxis := m * XAxis;
568   tYAxis := m * ComputedYAxis;
569   tFocalPoint := m * ComputedFocalPoint;
570   gt := GradientType;
571   if (GradientType = gtReflected) and (Repetition = grReflect) then
572     gt := gtLinear; // same as linear in this case
573   case gt of
574   gtLinear:
575       grad := ADefs.Content.AppendLinearGradient(tOrigin.X,tOrigin.Y,tXAxis.X,tXAxis.Y,cuCustom);
576   gtReflected:
577   begin
578     if Repetition <> grPad then j := MaxReflectRepeatCount else j := 1;
579     reflectedXAxis := tOrigin - j*(tXAxis - tOrigin);
580     repeatedXAxis := tOrigin + j*(tXAxis - tOrigin);
581     grad := ADefs.Content.AppendLinearGradient(reflectedXAxis.X,reflectedXAxis.Y,
582       repeatedXAxis.X,repeatedXAxis.Y,cuCustom);
583   end;
584   gtDiamond, gtRadial: // diamond approximated by radial
585     begin
586       u := tXAxis - tOrigin;
587       v := tYAxis - tOrigin;
588       lenU := u.Length;
589       lenV := v.Length;
590       radialScale := (lenU + lenV)/2;
591       if radialScale = 0 then
592         grad := ADefs.Content.AppendRadialGradient(tOrigin.X,tOrigin.Y,0,
593           tOrigin.X,tOrigin.Y,0, cuCustom)
594       else if (lenU = lenV) and (u*v = 0) then
595         grad := ADefs.Content.AppendRadialGradient(tOrigin.X,tOrigin.Y,radialScale*ComputedRadius,
596           tFocalPoint.X,tFocalPoint.Y,radialScale*ComputedFocalRadius, cuCustom)
597       else
598       begin
599         if lenU = 0 then lenU := 1;
600         if lenV = 0 then lenV := 1;
601         fp := PointF((tFocalPoint - tOrigin) * u / sqr(lenU),
602           (tFocalPoint - tOrigin)*v / sqr(lenV));
603         tFocalPoint := tOrigin + (fp.x * radialScale / lenU) * u + (fp.y * radialScale / lenV) * v;
604         grad := ADefs.Content.AppendRadialGradient(tOrigin.X,tOrigin.Y,radialScale*ComputedRadius,
605           tFocalPoint.X,tFocalPoint.Y,radialScale*ComputedFocalRadius, cuCustom);
606         grad.gradientMatrix[cuPixel] :=
607           AffineMatrix((1 / radialScale)*u, (1 / radialScale)*v, tOrigin) *
608           AffineMatrixTranslation(-tOrigin.X, -tOrigin.Y);
609       end;
610     end;
611   gtAngular: exit(nil); // not implemented
612   end;
613   case Repetition of
614   grPad: grad.spreadMethod := ssmPad;
615   grReflect: grad.spreadMethod := ssmReflect;
616   grRepeat, grSine: grad.spreadMethod := ssmRepeat;
617   end;
618   if gt = gtReflected then
619   begin
620     if Repetition <> grPad then
621     begin
622       for j := -MaxReflectRepeatCount+1 to 0 do
623         AddColorStops(0.5 + j/MaxReflectRepeatCount*0.5, -0.5/MaxReflectRepeatCount, true);
624       for j := 0 to MaxReflectRepeatCount-1 do
625         AddColorStops(0.5 + j*0.5/MaxReflectRepeatCount, 0.5/MaxReflectRepeatCount, j > 0);
626     end else
627     begin
628       AddColorStops(0.5, -0.5, true);
629       AddColorStops(0.5, 0.5, false);
630     end;
631   end else
632     AddColorStops(0, 1, true);
633   if ColorInterpolation = ciStdRGB then
634     grad.colorInterpolation := sciStdRGB
635     else grad.colorInterpolation := sciLinearRGB;
636   result := grad;
637 end;
638 
IsInfiniteSurfacenull639 function TBGRALayerGradientOriginal.IsInfiniteSurface: boolean;
640 begin
641   Result:= true;
642 end;
643 
644 procedure TBGRALayerGradientOriginal.Render(ADest: TBGRABitmap;
645   AMatrix: TAffineMatrix; ADraft: boolean);
646 begin
647   Render(ADest,AMatrix,ADraft,dmSet);
648 end;
649 
650 procedure TBGRALayerGradientOriginal.Render(ADest: TBGRABitmap;
651   AMatrix: TAffineMatrix; ADraft: boolean; ADrawMode: TDrawMode);
652 var
653   grad: TBGRACustomScanner;
654   temp: TBGRABitmap;
655 begin
656   if (ADrawMode in[dmDrawWithTransparency, dmLinearBlend, dmSetExceptTransparent]) and
657     IsOpaque then ADrawMode := dmSet;
658 
659   if ADraft and (ADest.ClipRect.Width*ADest.ClipRect.Height > 512*512) then
660   begin
661     temp := TBGRABitmap.Create(0,0);
662     temp.SetSize(min(400,ADest.Width),min(400,ADest.Height));
663     Render(temp, AffineMatrixScale(temp.Width/ADest.Width,
664                                    temp.Height/ADest.Height)*AMatrix, ADraft);
665     ADest.StretchPutImage(rect(0,0,ADest.Width,Adest.Height),temp, ADrawMode);
666     temp.Free;
667   end else
668   begin
669     grad := CreateScanner(AMatrix, ADraft);
670     if ADraft then
671       ADest.FillRect(ADest.ClipRect, grad,ADrawMode)
672       else ADest.FillRect(ADest.ClipRect, grad,ADrawMode, daFloydSteinberg);
673     grad.Free;
674   end;
675 end;
676 
TBGRALayerGradientOriginal.CreateScannernull677 function TBGRALayerGradientOriginal.CreateScanner(AMatrix: TAffineMatrix; ADraft: boolean): TBGRACustomScanner;
678 var
679   colors: TBGRACustomGradient;
680   grad: TBGRAGradientScanner;
681 begin
682   if isEmptyPointF(FOrigin) or isEmptyPointF(FXAxis) then exit(nil);
683 
684   colors := TBGRASimpleGradient.CreateAny(FColorInterpolation, FStartColor,FEndColor, FRepetition);
685   if ADraft then
686     colors := TBGRABufferedGradient.Create(colors, true, FRepetition = grPad, 1024);
687 
688   if FGradientType = gtRadial then
689   begin
690     grad := TBGRAGradientScanner.Create(FOrigin,FXAxis,ComputedYAxis,ComputedFocalPoint,ComputedRadius,ComputedFocalRadius);
691   end else
692     grad := TBGRAGradientScanner.Create(FGradientType, FOrigin,FXAxis,ComputedYAxis);
693 
694   grad.SetGradient(colors, true);
695   grad.Transform := AMatrix;
696 
697   exit(grad);
698 end;
699 
700 procedure TBGRALayerGradientOriginal.ConfigureEditor(
701   AEditor: TBGRAOriginalEditor);
702 var
703   originPoint: Integer;
704 begin
705   if not isEmptyPointF(FOrigin) then
706   begin
707     AEditor.AddStartMoveHandler(@OnStartMove);
708 
709     if not isEmptyPointF(FXAxis) and (FGradientType = gtLinear) then
710       originPoint := AEditor.AddPoint((FOrigin + FXAxis)*0.5, @OnMoveOrigin, true)
711     else originPoint := AEditor.AddPoint(FOrigin, @OnMoveOrigin, true);
712 
713     if not isEmptyPointF(FXAxis) then
714     begin
715       if not isEmptyPointF(FXAxis) and (FGradientType = gtLinear) then
716       begin
717         AEditor.AddArrow((FOrigin + FXAxis)*0.5, FXAxis, @OnMoveXAxis);
718         AEditor.AddArrow((FOrigin + FXAxis)*0.5, FOrigin, @OnMoveXAxisNeg);
719       end
720       else AEditor.AddArrow(FOrigin, FXAxis, @OnMoveXAxis);
721 
722       if FGradientType in[gtDiamond, gtRadial, gtAngular] then
723         AEditor.AddArrow(FOrigin, ComputedYAxis, @OnMoveYAxis);
724     end;
725     if FGradientType = gtRadial then
726     begin
727       AEditor.AddPoint(ComputedFocalPoint, @OnMoveFocalPoint, false, originPoint);
728       AEditor.AddArrow(ComputedFocalPoint, ComputedFocalPoint - (FXAxis - FOrigin) * (ComputedFocalRadius + 0.1), @OnMoveFocalRadius, false);
729     end;
730   end;
731 end;
732 
TBGRALayerGradientOriginal.GetRenderBoundsnull733 function TBGRALayerGradientOriginal.GetRenderBounds(ADestRect: TRect;
734   AMatrix: TAffineMatrix): TRect;
735 begin
736   result := ADestRect;
737 end;
738 
739 procedure TBGRALayerGradientOriginal.LoadFromStorage(
740   AStorage: TBGRACustomOriginalStorage);
741 var
742   colorArray: ArrayOfTBGRAPixel;
743 begin
744   colorArray := AStorage.ColorArray['colors'];
745 
746   FStartColor := colorArray[0];
747   FEndColor := colorArray[high(colorArray)];
748 
749   case AStorage.RawString['gradient-type'] of
750   'reflected': FGradientType := gtReflected;
751   'radial': FGradientType := gtRadial;
752   'diamond': FGradientType := gtDiamond;
753   'angular': FGradientType := gtAngular;
754   else {'linear'} FGradientType := gtLinear;
755   end;
756 
757   FOrigin := AStorage.PointF['origin'];
758   FXAxis := AStorage.PointF['x-axis'];
759   FYAxis := AStorage.PointF['y-axis'];
760   FFocalPoint := AStorage.PointF['focal-point'];
761 
762   FRadius := AStorage.Float['radial'];
763   FFocalRadius := AStorage.Float['focal-radius'];
764 
765   case AStorage.RawString['color-interpolation'] of
766   'RGB': FColorInterpolation:= ciLinearRGB;
767   'HSL+': FColorInterpolation:= ciLinearHSLPositive;
768   'HSL-': FColorInterpolation:= ciLinearHSLNegative;
769   'GSB+': FColorInterpolation:= ciGSBPositive;
770   'GSB-': FColorInterpolation:= ciGSBNegative;
771   else {'sRGB'} FColorInterpolation:= ciStdRGB;
772   end;
773 
774   case AStorage.RawString['repetition'] of
775   'repeat': FRepetition:= grRepeat;
776   'reflect': FRepetition:= grReflect;
777   'sine': FRepetition := grSine;
778   else {'pad'} FRepetition:= grPad;
779   end;
780 end;
781 
782 procedure TBGRALayerGradientOriginal.SaveToStorage(
783   AStorage: TBGRACustomOriginalStorage);
784 var
785   gtStr, ciStr: String;
786   colorArray: ArrayOfTBGRAPixel;
787 begin
788   setlength(colorArray,2);
789   colorArray[0] := FStartColor;
790   colorArray[1] := FEndColor;
791   AStorage.ColorArray['colors'] := colorArray;
792 
793   case FGradientType of
794   gtReflected: gtStr := 'reflected';
795   gtRadial: gtStr := 'radial';
796   gtDiamond: gtStr := 'diamond';
797   gtAngular: gtStr := 'angular';
798   else {gtLinear} gtStr := 'linear';
799   end;
800   AStorage.RawString['gradient-type'] := gtStr;
801 
802   AStorage.PointF['origin'] := FOrigin;
803   AStorage.PointF['x-axis'] := FXAxis;
804 
805   if FGradientType in[gtRadial,gtDiamond,gtAngular] then
806     AStorage.PointF['y-axis'] := FYAxis
807   else
808     AStorage.RemoveAttribute('y-axis');
809 
810   if FGradientType = gtRadial then
811   begin
812     AStorage.Float['radius'] := FRadius;
813     AStorage.Float['focal-radius'] := FFocalRadius;
814     AStorage.PointF['focal-point'] := FFocalPoint;
815   end else
816   begin
817     AStorage.RemoveAttribute('radius');
818     AStorage.RemoveAttribute('focal-radius');
819   end;
820 
821   case FColorInterpolation of
822   ciLinearRGB: ciStr := 'RGB';
823   ciLinearHSLPositive: ciStr := 'HSL+';
824   ciLinearHSLNegative: ciStr := 'HSL-';
825   ciGSBPositive: ciStr := 'GSB+';
826   ciGSBNegative: ciStr := 'GSB-';
827   else {ciStdRGB} ciStr := 'sRGB';
828   end;
829   AStorage.RawString['color-interpolation'] := ciStr;
830 
831   case FRepetition of
832   grRepeat: AStorage.RawString['repetition'] := 'repeat';
833   grReflect: AStorage.RawString['repetition'] := 'reflect';
834   grSine: AStorage.RawString['repetition'] := 'sine';
835   else {grPad} AStorage.RawString['repetition'] := 'pad';
836   end;
837 end;
838 
TBGRALayerGradientOriginal.StorageClassNamenull839 class function TBGRALayerGradientOriginal.StorageClassName: RawByteString;
840 begin
841   result := 'gradient';
842 end;
843 
TBGRALayerGradientOriginal.CanConvertToSVGnull844 class function TBGRALayerGradientOriginal.CanConvertToSVG: boolean;
845 begin
846   Result:= true;
847 end;
848 
849 procedure TBGRALayerGradientOriginal.Transform(AMatrix: TAffineMatrix);
850 begin
851   BeginUpdate;
852   if not isEmptyPointF(FOrigin) then FOrigin := AMatrix*FOrigin;
853   if not isEmptyPointF(FXAxis) then FXAxis := AMatrix*FXAxis;
854   if not isEmptyPointF(FYAxis) then FYAxis := AMatrix*FYAxis;
855   if not isEmptyPointF(FFocalPoint) then FFocalPoint := AMatrix*FFocalPoint;
856   EndUpdate;
857 end;
858 
859 procedure TBGRALayerGradientOriginal.AssignExceptGeometry(
860   AOther: TBGRALayerGradientOriginal);
861 begin
862   if (GradientType = AOther.GradientType) and
863     (StartColor.EqualsExactly(AOther.StartColor)) and
864     (EndColor.EqualsExactly(AOther.EndColor)) and
865     (ColorInterpolation = AOther.ColorInterpolation) and
866     (Repetition = AOther.Repetition) then exit;
867   BeginUpdate;
868   GradientType := AOther.GradientType;
869   StartColor:= AOther.StartColor;
870   EndColor:= AOther.EndColor;
871   ColorInterpolation:= AOther.ColorInterpolation;
872   Repetition:= AOther.Repetition;
873   EndUpdate;
874 end;
875 
876 procedure TBGRALayerGradientOriginal.FitGeometry(const ABox: TAffineBox);
877 begin
878   BeginUpdate;
879   if GradientType = gtLinear then
880   begin
881     Origin := ABox.TopLeft;
882     XAxis := ABox.BottomRight;
883   end else
884   begin
885     Origin := (ABox.TopLeft + ABox.BottomRight)*0.5;
886     if GradientType = gtReflected then
887       XAxis := ABox.BottomRight
888     else
889     begin
890       XAxis := (ABox.TopRight + ABox.BottomRight)*0.5;
891       YAxis := (ABox.BottomLeft + ABox.BottomRight)*0.5;
892     end;
893   end;
894   EndUpdate;
895 end;
896 
897 procedure TBGRALayerGradientOriginal.SetColors(AStartColor,
898   AEndColor: TBGRAPixel);
899 begin
900   if (AStartColor = StartColor) and (AEndColor = EndColor) then exit;
901   BeginUpdate;
902   StartColor := AStartColor;
903   EndColor := AEndColor;
904   EndUpdate;
905 end;
906 
907 procedure TBGRALayerGradientOriginal.ApplyOpacity(AOpacity: byte);
908 var
909   cStart, cEnd: TBGRAPixel;
910 begin
911   cStart := StartColor;
912   cStart.alpha := BGRABlend.ApplyOpacity(cStart.alpha, AOpacity);
913   cEnd := EndColor;
914   cEnd.alpha := BGRABlend.ApplyOpacity(cEnd.alpha, AOpacity);
915   SetColors(cStart, cEnd);
916 end;
917 
Equalsnull918 function TBGRALayerGradientOriginal.Equals(Obj: TObject): boolean;
919 var
920   other: TBGRALayerGradientOriginal;
921 begin
922   if Obj is TBGRALayerGradientOriginal then
923   begin
924     other := TBGRALayerGradientOriginal(Obj);
925     result := StartColor.EqualsExactly(other.StartColor) and
926               EndColor.EqualsExactly(other.EndColor) and
927               (GradientType = other.GradientType) and
928               (Origin = other.Origin) and
929               (XAxis = other.XAxis) and
930               ((GradientType in[gtLinear, gtReflected]) or
931                (YAxis = other.YAxis)) and
932               ((GradientType <> gtRadial) or
933                ((FocalPoint = other.FocalPoint) and
934                 (FocalRadius = other.FocalRadius))) and
935               (ColorInterpolation = other.ColorInterpolation) and
936               (Repetition = other.Repetition);
937   end else
938     Result:=inherited Equals(Obj);
939 end;
940 
941 initialization
942 
943   RegisterLayerOriginal(TBGRALayerGradientOriginal);
944 
945 end.
946