1 // SPDX-License-Identifier: GPL-3.0-only
2 unit LCVectorialFillControl;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 Types, Classes, SysUtils, Controls, LCVectorialFillInterface,
10 LCVectorialFill, BGRABitmap, BGRABitmapTypes, BGRAGradientScanner,
11 LCVectorOriginal;
12
13 type
14 TLCFillTarget = LCVectorialFillInterface.TLCFillTarget;
15
16 const
17 ftPen = LCVectorialFillInterface.ftPen;
18 ftBack = LCVectorialFillInterface.ftBack;
19 ftOutline = LCVectorialFillInterface.ftOutline;
20
21 type
22 { TLCVectorialFillControl }
23
24 TLCVectorialFillControl = class(TWinControl)
25 private
GetAllowedFillTypesnull26 function GetAllowedFillTypes: TVectorialFillTypes;
GetAverageColornull27 function GetAverageColor: TBGRAPixel;
GetCanAdjustToShapenull28 function GetCanAdjustToShape: boolean;
GetCanEditGradTexPointsnull29 function GetCanEditGradTexPoints: boolean;
GetEditingGradTexPointsnull30 function GetEditingGradTexPoints: boolean;
GetFillTypenull31 function GetFillType: TVectorialFillType;
GetGradEndColornull32 function GetGradEndColor: TBGRAPixel;
GetGradInterpnull33 function GetGradInterp: TBGRAColorInterpolation;
GetGradRepetitionnull34 function GetGradRepetition: TBGRAGradientRepetition;
GetGradStartColornull35 function GetGradStartColor: TBGRAPixel;
GetGradTypenull36 function GetGradType: TGradientType;
GetIsTargetnull37 function GetIsTarget: boolean;
GetPreferredSizeAsSizenull38 function GetPreferredSizeAsSize: TSize;
GetSolidColornull39 function GetSolidColor: TBGRAPixel;
GetTexOpacitynull40 function GetTexOpacity: byte;
GetTexRepetitionnull41 function GetTexRepetition: TTextureRepetition;
GetTexturenull42 function GetTexture: TBGRABitmap;
GetToolIconSizenull43 function GetToolIconSize: integer;
GetVerticalPaddingnull44 function GetVerticalPadding: integer;
45 procedure InterfaceMouseDown(Sender: TObject; Button: TMouseButton;
46 Shift: TShiftState; X, Y: Integer);
47 procedure InterfaceMouseEnter(Sender: TObject);
48 procedure InterfaceMouseLeave(Sender: TObject);
49 procedure InterfaceMouseMove(Sender: TObject; Shift: TShiftState; X,
50 Y: Integer);
51 procedure InterfaceMouseUp(Sender: TObject; Button: TMouseButton;
52 Shift: TShiftState; X, Y: Integer);
53 procedure SetAllowedFillTypes(AValue: TVectorialFillTypes);
54 procedure SetCanAdjustToShape(AValue: boolean);
55 procedure SetCanEditGradTexPoints(AValue: boolean);
56 procedure SetEditingGradTexPoints(AValue: boolean);
57 procedure SetFillType(AValue: TVectorialFillType);
58 procedure SetGradEndColor(AValue: TBGRAPixel);
59 procedure SetGradientType(AValue: TGradientType);
60 procedure SetGradInterpolation(AValue: TBGRAColorInterpolation);
61 procedure SetGradRepetition(AValue: TBGRAGradientRepetition);
62 procedure SetGradStartColor(AValue: TBGRAPixel);
63 procedure SetIsTarget(AValue: boolean);
64 procedure SetOnChooseColor(AValue: TChooseColorEvent);
65 procedure SetOnTextureClick(AValue: TNotifyEvent);
66 procedure SetSolidColor(AValue: TBGRAPixel);
67 procedure SetTexture(AValue: TBGRABitmap);
68 procedure SetTextureOpacity(AValue: byte);
69 procedure SetTextureRepetition(AValue: TTextureRepetition);
70 procedure SetToolIconSize(AValue: integer);
71 procedure SetVerticalPadding(AValue: integer);
72 protected
73 FInterface: TVectorialFillInterface;
74 FOnAdjustToShape: TNotifyEvent;
75 FOnEditGradTexPoints: TNotifyEvent;
76 FOnChooseColor: TChooseColorEvent;
77 FOnFillChange: TNotifyEvent;
78 FOnFillTypeChange: TNotifyEvent;
79 FOnTextureClick: TNotifyEvent;
80 FOnTextureChange: TNotifyEvent;
81 procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
82 {%H-}WithThemeSpace: Boolean); override;
83 procedure DoOnAdjustToShape(Sender: TObject);
84 procedure DoOnEditGradTexPoints(Sender: TObject);
85 procedure DoOnFillChange(Sender: TObject);
86 procedure DoOnFillTypeChange(Sender: TObject);
87 procedure DoOnTextureClick(Sender: TObject);
88 procedure DoOnTextureChange(Sender: TObject);
89 procedure DoOnResize; override;
90 procedure DoOnChooseColor({%H-}ASender: TObject; AButton: TMouseButton;
91 AColorIndex: integer; var AColorValue: TBGRAPixel; out AHandled: boolean);
92 public
93 constructor Create(TheOwner: TComponent); override;
94 destructor Destroy; override;
95 procedure AssignFill(AFill: TVectorialFill);
CreateShapeFillnull96 function CreateShapeFill(AShape: TVectorShape): TVectorialFill;
97 procedure UpdateShapeFill(AShape: TVectorShape; ATarget: TLCFillTarget);
98 procedure UpdateFillExceptGeometry(ATargetFill: TVectorialFill);
99 property FillType: TVectorialFillType read GetFillType write SetFillType;
100 property IsTarget: boolean read GetIsTarget write SetIsTarget;
101 property AverageColor: TBGRAPixel read GetAverageColor;
102 property SolidColor: TBGRAPixel read GetSolidColor write SetSolidColor;
103 property GradientType: TGradientType read GetGradType write SetGradientType;
104 property GradStartColor: TBGRAPixel read GetGradStartColor write SetGradStartColor;
105 property GradEndColor: TBGRAPixel read GetGradEndColor write SetGradEndColor;
106 property GradRepetition: TBGRAGradientRepetition read GetGradRepetition write SetGradRepetition;
107 property GradInterpolation: TBGRAColorInterpolation read GetGradInterp write SetGradInterpolation;
108 property Texture: TBGRABitmap read GetTexture write SetTexture;
109 property TextureRepetition: TTextureRepetition read GetTexRepetition write SetTextureRepetition;
110 property TextureOpacity: byte read GetTexOpacity write SetTextureOpacity;
111 property CanAdjustToShape: boolean read GetCanAdjustToShape write SetCanAdjustToShape;
112 property PreferredSize: TSize read GetPreferredSizeAsSize;
113 published
114 property AutoSize;
115 property Align;
116 property Enabled;
117 property Visible;
118 property ToolIconSize: integer read GetToolIconSize write SetToolIconSize;
119 property VerticalPadding: integer read GetVerticalPadding write SetVerticalPadding;
120 property AllowedFillTypes: TVectorialFillTypes read GetAllowedFillTypes write SetAllowedFillTypes;
121 property CanEditGradTexPoints: boolean read GetCanEditGradTexPoints write SetCanEditGradTexPoints;
122 property EditingGradTexPoints: boolean read GetEditingGradTexPoints write SetEditingGradTexPoints;
123 property OnChooseColor: TChooseColorEvent read FOnChooseColor write SetOnChooseColor;
124 property OnFillChange: TNotifyEvent read FOnFillChange write FOnFillChange;
125 property OnTextureChange: TNotifyEvent read FOnTextureChange write FOnTextureChange;
126 property OnAdjustToShape: TNotifyEvent read FOnAdjustToShape write FOnAdjustToShape;
127 property OnEditGradTexPoints: TNotifyEvent read FOnEditGradTexPoints write FOnEditGradTexPoints;
128 property OnFillTypeChange: TNotifyEvent read FOnFillTypeChange write FOnFillTypeChange;
129 property OnTextureClick: TNotifyEvent read FOnTextureClick write SetOnTextureClick;
130 property OnMouseDown;
131 property OnMouseMove;
132 property OnMouseUp;
133 property OnMouseEnter;
134 property OnMouseLeave;
135 end;
136
137 procedure Register;
138
139 implementation
140
141 procedure Register;
142 begin
143 RegisterComponents('Lazpaint Controls', [TLCVectorialFillControl]);
144 end;
145
146 { TLCVectorialFillControl }
147
148 procedure TLCVectorialFillControl.DoOnChooseColor(ASender: TObject; AButton: TMouseButton;
149 AColorIndex: integer; var AColorValue: TBGRAPixel; out AHandled: boolean);
150 begin
151 If Assigned(FOnChooseColor) then
152 FOnChooseColor(self, AButton, AColorIndex, AColorValue, AHandled)
153 else
154 AHandled := false;
155 end;
156
157 procedure TLCVectorialFillControl.DoOnTextureClick(Sender: TObject);
158 begin
159 if Assigned(FOnTextureClick) then FOnTextureClick(self);
160 end;
161
TLCVectorialFillControl.GetAllowedFillTypesnull162 function TLCVectorialFillControl.GetAllowedFillTypes: TVectorialFillTypes;
163 begin
164 result := FInterface.AllowedFillTypes;
165 end;
166
TLCVectorialFillControl.GetAverageColornull167 function TLCVectorialFillControl.GetAverageColor: TBGRAPixel;
168 begin
169 result := FInterface.AverageColor;
170 end;
171
GetCanAdjustToShapenull172 function TLCVectorialFillControl.GetCanAdjustToShape: boolean;
173 begin
174 result := FInterface.CanAdjustToShape;
175 end;
176
GetCanEditGradTexPointsnull177 function TLCVectorialFillControl.GetCanEditGradTexPoints: boolean;
178 begin
179 result := FInterface.CanEditGradTexPoints;
180 end;
181
GetEditingGradTexPointsnull182 function TLCVectorialFillControl.GetEditingGradTexPoints: boolean;
183 begin
184 result := FInterface.EditingGradTexPoints;
185 end;
186
GetFillTypenull187 function TLCVectorialFillControl.GetFillType: TVectorialFillType;
188 begin
189 result := FInterface.FillType;
190 end;
191
GetGradEndColornull192 function TLCVectorialFillControl.GetGradEndColor: TBGRAPixel;
193 begin
194 result := FInterface.GradEndColor;
195 end;
196
GetGradInterpnull197 function TLCVectorialFillControl.GetGradInterp: TBGRAColorInterpolation;
198 begin
199 result := FInterface.GradInterpolation;
200 end;
201
GetGradRepetitionnull202 function TLCVectorialFillControl.GetGradRepetition: TBGRAGradientRepetition;
203 begin
204 result := FInterface.GradRepetition;
205 end;
206
GetGradStartColornull207 function TLCVectorialFillControl.GetGradStartColor: TBGRAPixel;
208 begin
209 result := FInterface.GradStartColor;
210 end;
211
GetGradTypenull212 function TLCVectorialFillControl.GetGradType: TGradientType;
213 begin
214 result := FInterface.GradientType;
215 end;
216
TLCVectorialFillControl.GetIsTargetnull217 function TLCVectorialFillControl.GetIsTarget: boolean;
218 begin
219 result := FInterface.IsTarget;
220 end;
221
TLCVectorialFillControl.GetPreferredSizeAsSizenull222 function TLCVectorialFillControl.GetPreferredSizeAsSize: TSize;
223 begin
224 result.cx:= Width;
225 result.cy:= Height;
226 GetPreferredSize(result.cx, result.cy);
227 end;
228
GetSolidColornull229 function TLCVectorialFillControl.GetSolidColor: TBGRAPixel;
230 begin
231 result := FInterface.SolidColor;
232 end;
233
TLCVectorialFillControl.GetTexOpacitynull234 function TLCVectorialFillControl.GetTexOpacity: byte;
235 begin
236 result := FInterface.TextureOpacity;
237 end;
238
TLCVectorialFillControl.GetTexRepetitionnull239 function TLCVectorialFillControl.GetTexRepetition: TTextureRepetition;
240 begin
241 result := FInterface.TextureRepetition;
242 end;
243
TLCVectorialFillControl.GetTexturenull244 function TLCVectorialFillControl.GetTexture: TBGRABitmap;
245 begin
246 result := FInterface.Texture;
247 end;
248
TLCVectorialFillControl.GetToolIconSizenull249 function TLCVectorialFillControl.GetToolIconSize: integer;
250 begin
251 result := FInterface.ImageListSize.cy;
252 end;
253
TLCVectorialFillControl.GetVerticalPaddingnull254 function TLCVectorialFillControl.GetVerticalPadding: integer;
255 begin
256 result := FInterface.VerticalPadding;
257 end;
258
259 procedure TLCVectorialFillControl.InterfaceMouseDown(Sender: TObject;
260 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
261 begin
262 if Assigned(OnMouseDown) then OnMouseDown(self, Button, Shift, X,Y);
263 end;
264
265 procedure TLCVectorialFillControl.InterfaceMouseEnter(Sender: TObject);
266 begin
267 if Assigned(OnMouseEnter) then OnMouseEnter(self);
268 end;
269
270 procedure TLCVectorialFillControl.InterfaceMouseLeave(Sender: TObject);
271 begin
272 if Assigned(OnMouseLeave) then OnMouseLeave(self);
273 end;
274
275 procedure TLCVectorialFillControl.InterfaceMouseMove(Sender: TObject;
276 Shift: TShiftState; X, Y: Integer);
277 begin
278 if Assigned(OnMouseMove) then OnMouseMove(self, Shift, X,Y);
279 end;
280
281 procedure TLCVectorialFillControl.InterfaceMouseUp(Sender: TObject;
282 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
283 begin
284 if Assigned(OnMouseUp) then OnMouseUp(self, Button, Shift, X,Y);
285 end;
286
287 procedure TLCVectorialFillControl.SetAllowedFillTypes(
288 AValue: TVectorialFillTypes);
289 begin
290 FInterface.AllowedFillTypes:= AValue;
291 end;
292
293 procedure TLCVectorialFillControl.SetCanAdjustToShape(AValue: boolean);
294 begin
295 FInterface.CanAdjustToShape := AValue;
296 end;
297
298 procedure TLCVectorialFillControl.SetCanEditGradTexPoints(AValue: boolean);
299 begin
300 FInterface.CanEditGradTexPoints:= AValue;
301 end;
302
303 procedure TLCVectorialFillControl.SetEditingGradTexPoints(AValue: boolean);
304 begin
305 FInterface.EditingGradTexPoints := AValue;
306 end;
307
308 procedure TLCVectorialFillControl.SetFillType(AValue: TVectorialFillType);
309 begin
310 FInterface.FillType := AValue;
311 end;
312
313 procedure TLCVectorialFillControl.SetGradEndColor(AValue: TBGRAPixel);
314 begin
315 FInterface.GradEndColor := AValue;
316 end;
317
318 procedure TLCVectorialFillControl.SetGradientType(AValue: TGradientType);
319 begin
320 FInterface.GradientType := AValue;
321 end;
322
323 procedure TLCVectorialFillControl.SetGradInterpolation(
324 AValue: TBGRAColorInterpolation);
325 begin
326 FInterface.GradInterpolation := AValue;
327 end;
328
329 procedure TLCVectorialFillControl.SetGradRepetition(
330 AValue: TBGRAGradientRepetition);
331 begin
332 FInterface.GradRepetition := AValue;
333 end;
334
335 procedure TLCVectorialFillControl.SetGradStartColor(AValue: TBGRAPixel);
336 begin
337 FInterface.GradStartColor := AValue;
338 end;
339
340 procedure TLCVectorialFillControl.SetIsTarget(AValue: boolean);
341 begin
342 FInterface.IsTarget := AValue;
343 end;
344
345 procedure TLCVectorialFillControl.SetOnChooseColor(AValue: TChooseColorEvent);
346 begin
347 if FOnChooseColor=AValue then Exit;
348 FOnChooseColor:=AValue;
349 end;
350
351 procedure TLCVectorialFillControl.SetOnTextureClick(AValue: TNotifyEvent);
352 begin
353 if FOnTextureClick=AValue then Exit;
354 FOnTextureClick:=AValue;
355 if Assigned(FOnTextureClick) then
356 FInterface.OnTextureClick:= @DoOnTextureClick
357 else
358 FInterface.OnTextureClick:= nil;
359 end;
360
361 procedure TLCVectorialFillControl.SetSolidColor(AValue: TBGRAPixel);
362 begin
363 FInterface.SolidColor := AValue;
364 end;
365
366 procedure TLCVectorialFillControl.SetTexture(AValue: TBGRABitmap);
367 begin
368 FInterface.Texture := AValue;
369 end;
370
371 procedure TLCVectorialFillControl.SetTextureOpacity(AValue: byte);
372 begin
373 FInterface.TextureOpacity := AValue;
374 end;
375
376 procedure TLCVectorialFillControl.SetTextureRepetition(
377 AValue: TTextureRepetition);
378 begin
379 FInterface.TextureRepetition := AValue;
380 end;
381
382 procedure TLCVectorialFillControl.SetToolIconSize(AValue: integer);
383 begin
384 FInterface.ImageListSize := Size(AValue,AValue);
385 end;
386
387 procedure TLCVectorialFillControl.SetVerticalPadding(AValue: integer);
388 begin
389 FInterface.VerticalPadding:= AValue;
390 end;
391
392 procedure TLCVectorialFillControl.CalculatePreferredSize(var PreferredWidth,
393 PreferredHeight: integer; WithThemeSpace: Boolean);
394 begin
395 with FInterface.PreferredSize do
396 begin
397 PreferredWidth := cx;
398 PreferredHeight := cy;
399 end;
400 end;
401
402 procedure TLCVectorialFillControl.DoOnAdjustToShape(Sender: TObject);
403 begin
404 if Assigned(FOnAdjustToShape) then FOnAdjustToShape(self);
405 end;
406
407 procedure TLCVectorialFillControl.DoOnEditGradTexPoints(Sender: TObject);
408 begin
409 if Assigned(FOnEditGradTexPoints) then FOnEditGradTexPoints(self);
410 end;
411
412 procedure TLCVectorialFillControl.DoOnFillChange(Sender: TObject);
413 begin
414 if Assigned(FOnFillChange) then FOnFillChange(self);
415 end;
416
417 procedure TLCVectorialFillControl.DoOnFillTypeChange(Sender: TObject);
418 begin
419 InvalidatePreferredSize;
420 AdjustSize;
421 if Assigned(FOnFillTypeChange) then FOnFillTypeChange(self);
422 end;
423
424 procedure TLCVectorialFillControl.DoOnTextureChange(Sender: TObject);
425 begin
426 if Assigned(FOnTextureChange) then FOnTextureChange(self);
427 end;
428
429 procedure TLCVectorialFillControl.DoOnResize;
430 begin
431 inherited DoOnResize;
432 FInterface.LoadImageList;
433 FInterface.ContainerSizeChanged;
434 end;
435
436 constructor TLCVectorialFillControl.Create(TheOwner: TComponent);
437 begin
438 inherited Create(TheOwner);
439 FInterface := TVectorialFillInterface.Create(nil, 16,16);
440 FInterface.OnChooseColor:=@DoOnChooseColor;
441 FInterface.OnFillChange:=@DoOnFillChange;
442 FInterface.OnTextureChange:=@DoOnTextureChange;
443 FInterface.OnAdjustToShape:=@DoOnAdjustToShape;
444 FInterface.OnEditGradTexPoints:=@DoOnEditGradTexPoints;
445 FInterface.OnFillTypeChange:=@DoOnFillTypeChange;
446 FInterface.OnMouseMove:=@InterfaceMouseMove;
447 FInterface.OnMouseDown:=@InterfaceMouseDown;
448 FInterface.OnMouseUp:=@InterfaceMouseUp;
449 FInterface.OnMouseEnter:=@InterfaceMouseEnter;
450 FInterface.OnMouseLeave:=@InterfaceMouseLeave;
451 FInterface.Container := self;
452 end;
453
454 destructor TLCVectorialFillControl.Destroy;
455 begin
456 FreeAndNil(FInterface);
457 inherited Destroy;
458 end;
459
460 procedure TLCVectorialFillControl.AssignFill(AFill: TVectorialFill);
461 begin
462 FInterface.AssignFill(AFill);
463 end;
464
TLCVectorialFillControl.CreateShapeFillnull465 function TLCVectorialFillControl.CreateShapeFill(AShape: TVectorShape): TVectorialFill;
466 begin
467 result := FInterface.CreateShapeFill(AShape);
468 end;
469
470 procedure TLCVectorialFillControl.UpdateShapeFill(AShape: TVectorShape;
471 ATarget: TLCFillTarget);
472 begin
473 FInterface.UpdateShapeFill(AShape, ATarget);
474 end;
475
476 procedure TLCVectorialFillControl.UpdateFillExceptGeometry(ATargetFill: TVectorialFill);
477 begin
478 FInterface.UpdateFillExceptGeometry(ATargetFill);
479 end;
480
481 end.
482
483