source: trunk/Packages/bgrabitmap/bgragradientoriginal.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 15.6 KB
Line 
1unit BGRAGradientOriginal;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, BGRALayerOriginal, BGRABitmap, BGRABitmapTypes, BGRAGradientScanner;
9
10type
11 TBGRAColorInterpolation = BGRAGradientScanner.TBGRAColorInterpolation;
12 TBGRAGradientRepetition = BGRAGradientScanner.TBGRAGradientRepetition;
13
14 { TBGRALayerGradientOriginal }
15
16 TBGRALayerGradientOriginal = class(TBGRALayerCustomOriginal)
17 private
18 procedure SetColorInterpoaltion(AValue: TBGRAColorInterpolation);
19 procedure SetEndColor(AValue: TBGRAPixel);
20 procedure SetFocalPoint(AValue: TPointF);
21 procedure SetFocalRadius(AValue: Single);
22 procedure SetGradientType(AValue: TGradientType);
23 procedure SetOrigin(AValue: TPointF);
24 procedure SetRadius(AValue: Single);
25 procedure SetRepetition(AValue: TBGRAGradientRepetition);
26 procedure SetStartColor(AValue: TBGRAPixel);
27 procedure SetXAxis(AValue: TPointF);
28 procedure SetYAxis(AValue: TPointF);
29 protected
30 FStartColor,FEndColor: TBGRAPixel;
31 FGradientType: TGradientType;
32 FOrigin,FXAxis,FYAxis,FFocalPoint: TPointF;
33 FOriginBackup,FXAxisBackup, FYAxisBackup: TPointF;
34 FRadius,FFocalRadius: single;
35 FColorInterpolation: TBGRAColorInterpolation;
36 FRepetition: TBGRAGradientRepetition;
37 function GetComputedRadius: single;
38 function GetComputedYAxis: TPointF;
39 function GetComputedFocalPoint: TPointF;
40 function GetComputedFocalRadius: single;
41 procedure OnMoveOrigin({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
42 procedure OnMoveXAxis({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
43 procedure OnMoveXAxisNeg({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
44 procedure OnMoveYAxis({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
45 procedure OnMoveFocalPoint({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
46 procedure OnMoveFocalRadius({%H-}ASender: TObject; {%H-}APrevCoord, ANewCoord: TPointF; {%H-}AShift: TShiftState);
47 procedure OnStartMove({%H-}ASender: TObject; {%H-}AIndex: integer; {%H-}AShift: TShiftState);
48 public
49 constructor Create; override;
50 procedure Render(ADest: TBGRABitmap; AMatrix: TAffineMatrix; ADraft: boolean); override;
51 function CreateScanner(AMatrix: TAffineMatrix): TBGRACustomScanner;
52 procedure ConfigureEditor(AEditor: TBGRAOriginalEditor); override;
53 function GetRenderBounds(ADestRect: TRect; {%H-}AMatrix: TAffineMatrix): TRect; override;
54 procedure LoadFromStorage(AStorage: TBGRACustomOriginalStorage); override;
55 procedure SaveToStorage(AStorage: TBGRACustomOriginalStorage); override;
56 class function StorageClassName: RawByteString; override;
57 property ComputedYAxis: TPointF read GetComputedYAxis;
58 property ComputedRadius: single read GetComputedRadius;
59 property ComputedFocalPoint: TPointF read GetComputedFocalPoint;
60 property ComputedFocalRadius: single read GetComputedFocalRadius;
61 procedure Transform(AMatrix: TAffineMatrix);
62
63 property StartColor: TBGRAPixel read FStartColor write SetStartColor;
64 property EndColor: TBGRAPixel read FEndColor write SetEndColor;
65 property GradientType: TGradientType read FGradientType write SetGradientType; //default gtLinear
66 property Origin: TPointF read FOrigin write SetOrigin;
67 property XAxis: TPointF read FXAxis write SetXAxis;
68 property YAxis: TPointF read FYAxis write SetYAxis;
69 property FocalPoint: TPointF read FFocalPoint write SetFocalPoint; //default Origin
70 property Radius: Single read FRadius write SetRadius; //default 1
71 property FocalRadius: Single read FFocalRadius write SetFocalRadius; //default 0
72 property ColorInterpolation: TBGRAColorInterpolation read FColorInterpolation write SetColorInterpoaltion;
73 property Repetition: TBGRAGradientRepetition read FRepetition write SetRepetition;
74
75 end;
76
77implementation
78
79uses BGRATransform;
80
81{ TBGRALayerGradientOriginal }
82
83function TBGRALayerGradientOriginal.GetComputedRadius: single;
84begin
85 if FRadius = EmptySingle then result := 1 else result := FRadius;
86end;
87
88procedure TBGRALayerGradientOriginal.SetColorInterpoaltion(
89 AValue: TBGRAColorInterpolation);
90begin
91 if FColorInterpolation=AValue then Exit;
92 FColorInterpolation:=AValue;
93 NotifyChange;
94end;
95
96procedure TBGRALayerGradientOriginal.SetEndColor(AValue: TBGRAPixel);
97begin
98 if FEndColor=AValue then Exit;
99 FEndColor:=AValue;
100 NotifyChange;
101end;
102
103procedure TBGRALayerGradientOriginal.SetFocalPoint(AValue: TPointF);
104begin
105 if FFocalPoint=AValue then Exit;
106 FFocalPoint:=AValue;
107 NotifyChange;
108end;
109
110procedure TBGRALayerGradientOriginal.SetFocalRadius(AValue: Single);
111begin
112 if FFocalRadius=AValue then Exit;
113 FFocalRadius:=AValue;
114 NotifyChange;
115end;
116
117procedure TBGRALayerGradientOriginal.SetGradientType(AValue: TGradientType);
118begin
119 if FGradientType=AValue then Exit;
120 FGradientType:=AValue;
121 if FGradientType in [gtLinear,gtReflected] then FYAxis := EmptyPointF;
122 NotifyChange;
123end;
124
125procedure TBGRALayerGradientOriginal.SetOrigin(AValue: TPointF);
126begin
127 if FOrigin=AValue then Exit;
128 FOrigin:=AValue;
129 NotifyChange;
130end;
131
132procedure TBGRALayerGradientOriginal.SetRadius(AValue: Single);
133begin
134 if FRadius=AValue then Exit;
135 FRadius:=AValue;
136 NotifyChange;
137end;
138
139procedure TBGRALayerGradientOriginal.SetRepetition(
140 AValue: TBGRAGradientRepetition);
141begin
142 if FRepetition=AValue then Exit;
143 FRepetition:=AValue;
144 NotifyChange;
145end;
146
147procedure TBGRALayerGradientOriginal.SetStartColor(AValue: TBGRAPixel);
148begin
149 if FStartColor=AValue then Exit;
150 FStartColor:=AValue;
151 NotifyChange;
152end;
153
154procedure TBGRALayerGradientOriginal.SetXAxis(AValue: TPointF);
155begin
156 if FXAxis=AValue then Exit;
157 FXAxis:=AValue;
158 NotifyChange;
159end;
160
161procedure TBGRALayerGradientOriginal.SetYAxis(AValue: TPointF);
162begin
163 if FYAxis=AValue then Exit;
164 FYAxis:=AValue;
165 NotifyChange;
166end;
167
168function TBGRALayerGradientOriginal.GetComputedYAxis: TPointF;
169var
170 u: TPointF;
171begin
172 if isEmptyPointF(FYAxis) then
173 begin
174 u := FXAxis - FOrigin;
175 result := FOrigin + PointF(-u.y,u.x)
176 end
177 else
178 result := FYAxis;
179end;
180
181function TBGRALayerGradientOriginal.GetComputedFocalPoint: TPointF;
182begin
183 if isEmptyPointF(FFocalPoint) then result := FOrigin else result := FFocalPoint;
184end;
185
186function TBGRALayerGradientOriginal.GetComputedFocalRadius: single;
187begin
188 if FFocalRadius = EmptySingle then result := 0 else result := FFocalRadius;
189end;
190
191procedure TBGRALayerGradientOriginal.OnMoveOrigin(ASender: TObject; APrevCoord,
192 ANewCoord: TPointF; AShift: TShiftState);
193var
194 delta: TPointF;
195begin
196 delta := ANewCoord-APrevCoord;
197 FOrigin += delta;
198 if not isEmptyPointF(FXAxis) then FXAxis += delta;
199 if not isEmptyPointF(FYAxis) then FYAxis += delta;
200 if not isEmptyPointF(FFocalPoint) then FFocalPoint += delta;
201 NotifyChange;
202end;
203
204procedure TBGRALayerGradientOriginal.OnMoveXAxis(ASender: TObject; APrevCoord,
205 ANewCoord: TPointF; AShift: TShiftState);
206var
207 m: TAffineMatrix;
208 c: TPointF;
209begin
210 if not (ssAlt in AShift) or (GradientType in [gtLinear,gtReflected]) then
211 begin
212 if not isEmptyPointF(FYAxis) and not isEmptyPointF(FYAxisBackup) then
213 begin
214 m := AffineMatrixScaledRotation(FXAxisBackup, ANewCoord, FOrigin);
215 FYAxis := m*FYAxisBackup;
216 end;
217 end else
218 if isEmptyPointF(FYAxis) then FYAxis := ComputedYAxis;
219
220 if (GradientType = gtLinear) and (ssShift in AShift) then
221 begin
222 c := (FOriginBackup+FXAxisBackup)*0.5;
223 m := AffineMatrixScaledRotation(FXAxisBackup, ANewCoord, c);
224 FOrigin := m*FOriginBackup;
225 end
226 else
227 FOrigin := FOriginBackup;
228
229 FXAxis := ANewCoord;
230
231 NotifyChange;
232end;
233
234procedure TBGRALayerGradientOriginal.OnMoveXAxisNeg(ASender: TObject;
235 APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
236var
237 delta, c: TPointF;
238 m: TAffineMatrix;
239begin
240 delta := ANewCoord-APrevCoord;
241
242 if (GradientType = gtLinear) and (ssShift in AShift) then
243 begin
244 c := (FOriginBackup+FXAxisBackup)*0.5;
245 m := AffineMatrixScaledRotation(FOriginBackup, (FOrigin+delta), c);
246 FXAxis := m*FXAxisBackup;
247 end
248 else
249 FXAxis := FXAxisBackup;
250
251 FOrigin += delta;
252 NotifyChange;
253end;
254
255procedure TBGRALayerGradientOriginal.OnMoveYAxis(ASender: TObject; APrevCoord,
256 ANewCoord: TPointF; AShift: TShiftState);
257var
258 m: TAffineMatrix;
259begin
260 if not (ssAlt in AShift) or (GradientType in [gtLinear,gtReflected]) then
261 begin
262 if not isEmptyPointF(FXAxis) then
263 begin
264 m := AffineMatrixScaledRotation(FYAxisBackup, ANewCoord, FOrigin);
265 FXAxis := m*FXAxisBackup;
266 end;
267 end;
268 FYAxis := ANewCoord;
269 NotifyChange;
270end;
271
272procedure TBGRALayerGradientOriginal.OnMoveFocalPoint(ASender: TObject;
273 APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
274begin
275 FocalPoint := ANewCoord;
276end;
277
278procedure TBGRALayerGradientOriginal.OnMoveFocalRadius(ASender: TObject;
279 APrevCoord, ANewCoord: TPointF; AShift: TShiftState);
280var refLen: single;
281 u, focalOrig: TPointF;
282begin
283 focalOrig := ComputedFocalPoint;
284 if isEmptyPointF(focalOrig) or isEmptyPointF(FOrigin) or isEmptyPointF(FXAxis) then exit;
285 refLen := VectLen(FOrigin-FXAxis);
286 if refLen = 0 then exit;
287
288 u := (FOrigin-FXAxis)*(1/refLen);
289 FFocalRadius := u * (ANewCoord-focalOrig) / refLen - 0.1;
290 if FFocalRadius < 0 then FFocalRadius:= 0;
291 NotifyChange;
292end;
293
294procedure TBGRALayerGradientOriginal.OnStartMove(ASender: TObject;
295 AIndex: integer; AShift: TShiftState);
296begin
297 FOriginBackup := FOrigin;
298 FXAxisBackup := FXAxis;
299 FYAxisBackup := ComputedYAxis;
300end;
301
302constructor TBGRALayerGradientOriginal.Create;
303begin
304 inherited Create;
305 FStartColor := BGRABlack;
306 FEndColor := BGRAWhite;
307 FGradientType := gtLinear;
308 FColorInterpolation:= ciStdRGB;
309 FRepetition := grPad;
310 FRadius := EmptySingle;
311 FFocalRadius := EmptySingle;
312 FFocalPoint := EmptyPointF;
313 FOrigin := PointF(0,0);
314 FXAxis := EmptyPointF;
315 FYAxis := EmptyPointF;
316end;
317
318procedure TBGRALayerGradientOriginal.Render(ADest: TBGRABitmap;
319 AMatrix: TAffineMatrix; ADraft: boolean);
320var
321 grad: TBGRACustomScanner;
322 dither: TDitheringAlgorithm;
323begin
324 grad := CreateScanner(AMatrix);
325 if ADraft then dither := daNearestNeighbor else dither := daFloydSteinberg;
326 ADest.FillRect(ADest.ClipRect, grad,dmSet, dither);
327 grad.Free;
328end;
329
330function TBGRALayerGradientOriginal.CreateScanner(AMatrix: TAffineMatrix): TBGRACustomScanner;
331var
332 colors: TBGRACustomGradient;
333 grad: TBGRAGradientScanner;
334begin
335 if isEmptyPointF(FOrigin) or isEmptyPointF(FXAxis) then exit(nil);
336
337 colors := TBGRASimpleGradient.CreateAny(FColorInterpolation, FStartColor,FEndColor, FRepetition);
338
339 if FGradientType = gtRadial then
340 begin
341 grad := TBGRAGradientScanner.Create(FOrigin,FXAxis,ComputedYAxis,ComputedFocalPoint,ComputedRadius,ComputedFocalRadius);
342 end else
343 grad := TBGRAGradientScanner.Create(FGradientType, FOrigin,FXAxis,ComputedYAxis);
344
345 grad.SetGradient(colors, true);
346 grad.Transform := AMatrix;
347
348 exit(grad);
349end;
350
351procedure TBGRALayerGradientOriginal.ConfigureEditor(
352 AEditor: TBGRAOriginalEditor);
353var
354 originPoint: Integer;
355begin
356 if not isEmptyPointF(FOrigin) then
357 begin
358 AEditor.AddStartMoveHandler(@OnStartMove);
359
360 if not isEmptyPointF(FXAxis) and (FGradientType = gtLinear) then
361 originPoint := AEditor.AddPoint((FOrigin + FXAxis)*0.5, @OnMoveOrigin, true)
362 else originPoint := AEditor.AddPoint(FOrigin, @OnMoveOrigin, true);
363
364 if not isEmptyPointF(FXAxis) then
365 begin
366 if not isEmptyPointF(FXAxis) and (FGradientType = gtLinear) then
367 begin
368 AEditor.AddArrow((FOrigin + FXAxis)*0.5, FXAxis, @OnMoveXAxis);
369 AEditor.AddArrow((FOrigin + FXAxis)*0.5, FOrigin, @OnMoveXAxisNeg);
370 end
371 else AEditor.AddArrow(FOrigin, FXAxis, @OnMoveXAxis);
372
373 if FGradientType in[gtDiamond, gtRadial, gtAngular] then
374 AEditor.AddArrow(FOrigin, ComputedYAxis, @OnMoveYAxis);
375 end;
376 if FGradientType = gtRadial then
377 begin
378 AEditor.AddPoint(ComputedFocalPoint, @OnMoveFocalPoint, false, originPoint);
379 AEditor.AddArrow(ComputedFocalPoint, ComputedFocalPoint - (FXAxis - FOrigin) * (ComputedFocalRadius + 0.1), @OnMoveFocalRadius, false);
380 end;
381 end;
382end;
383
384function TBGRALayerGradientOriginal.GetRenderBounds(ADestRect: TRect;
385 AMatrix: TAffineMatrix): TRect;
386begin
387 result := ADestRect;
388end;
389
390procedure TBGRALayerGradientOriginal.LoadFromStorage(
391 AStorage: TBGRACustomOriginalStorage);
392var
393 colorArray: ArrayOfTBGRAPixel;
394begin
395 colorArray := AStorage.ColorArray['colors'];
396
397 FStartColor := colorArray[0];
398 FEndColor := colorArray[high(colorArray)];
399
400 case AStorage.RawString['gradient-type'] of
401 'reflected': FGradientType := gtReflected;
402 'radial': FGradientType := gtRadial;
403 'diamond': FGradientType := gtDiamond;
404 'angular': FGradientType := gtAngular;
405 else {'linear'} FGradientType := gtLinear;
406 end;
407
408 FOrigin := AStorage.PointF['origin'];
409 FXAxis := AStorage.PointF['x-axis'];
410 FYAxis := AStorage.PointF['y-axis'];
411 FFocalPoint := AStorage.PointF['focal-point'];
412
413 FRadius := AStorage.Float['radial'];
414 FFocalRadius := AStorage.Float['focal-radius'];
415
416 case AStorage.RawString['color-interpolation'] of
417 'RGB': FColorInterpolation:= ciLinearRGB;
418 'HSL+': FColorInterpolation:= ciLinearHSLPositive;
419 'HSL-': FColorInterpolation:= ciLinearHSLNegative;
420 'GSB+': FColorInterpolation:= ciGSBPositive;
421 'GSB-': FColorInterpolation:= ciGSBNegative;
422 else {'sRGB'} FColorInterpolation:= ciStdRGB;
423 end;
424
425 case AStorage.RawString['repetition'] of
426 'repeat': FRepetition:= grRepeat;
427 'reflect': FRepetition:= grReflect;
428 'sine': FRepetition := grSine;
429 else {'pad'} FRepetition:= grPad;
430 end;
431end;
432
433procedure TBGRALayerGradientOriginal.SaveToStorage(
434 AStorage: TBGRACustomOriginalStorage);
435var
436 gtStr, ciStr: String;
437 colorArray: ArrayOfTBGRAPixel;
438begin
439 setlength(colorArray,2);
440 colorArray[0] := FStartColor;
441 colorArray[1] := FEndColor;
442 AStorage.ColorArray['colors'] := colorArray;
443
444 case FGradientType of
445 gtReflected: gtStr := 'reflected';
446 gtRadial: gtStr := 'radial';
447 gtDiamond: gtStr := 'diamond';
448 gtAngular: gtStr := 'angular';
449 else {gtLinear} gtStr := 'linear';
450 end;
451 AStorage.RawString['gradient-type'] := gtStr;
452
453 AStorage.PointF['origin'] := FOrigin;
454 AStorage.PointF['x-axis'] := FXAxis;
455
456 if FGradientType in[gtRadial,gtDiamond,gtAngular] then
457 AStorage.PointF['y-axis'] := FYAxis
458 else
459 AStorage.RemoveAttribute('y-axis');
460
461 if FGradientType = gtRadial then
462 begin
463 AStorage.Float['radius'] := FRadius;
464 AStorage.Float['focal-radius'] := FFocalRadius;
465 AStorage.PointF['focal-point'] := FFocalPoint;
466 end else
467 begin
468 AStorage.RemoveAttribute('radius');
469 AStorage.RemoveAttribute('focal-radius');
470 end;
471
472 case FColorInterpolation of
473 ciLinearRGB: ciStr := 'RGB';
474 ciLinearHSLPositive: ciStr := 'HSL+';
475 ciLinearHSLNegative: ciStr := 'HSL-';
476 ciGSBPositive: ciStr := 'GSB+';
477 ciGSBNegative: ciStr := 'GSB-';
478 else {ciStdRGB} ciStr := 'sRGB';
479 end;
480 AStorage.RawString['color-interpolation'] := ciStr;
481
482 case FRepetition of
483 grRepeat: AStorage.RawString['repetition'] := 'repeat';
484 grReflect: AStorage.RawString['repetition'] := 'reflect';
485 grSine: AStorage.RawString['repetition'] := 'sine';
486 else {grPad} AStorage.RawString['repetition'] := 'pad';
487 end;
488end;
489
490class function TBGRALayerGradientOriginal.StorageClassName: RawByteString;
491begin
492 result := 'gradient';
493end;
494
495procedure TBGRALayerGradientOriginal.Transform(AMatrix: TAffineMatrix);
496begin
497 if not isEmptyPointF(FOrigin) then FOrigin := AMatrix*FOrigin;
498 if not isEmptyPointF(FXAxis) then FXAxis := AMatrix*FXAxis;
499 if not isEmptyPointF(FYAxis) then FYAxis := AMatrix*FYAxis;
500 if not isEmptyPointF(FFocalPoint) then FFocalPoint := AMatrix*FFocalPoint;
501 NotifyChange;
502end;
503
504initialization
505
506 RegisterLayerOriginal(TBGRALayerGradientOriginal);
507
508end.
Note: See TracBrowser for help on using the repository browser.