1 // SPDX-License-Identifier: GPL-3.0-only
2 unit UBlendOp;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
10 StdCtrls, ExtCtrls, types, BGRABitmap, BGRABitmapTypes, LazPaintType;
11
12 type
13
14 { TFBlendOp }
15
16 TFBlendOp = class(TForm)
17 Bevel1: TBevel;
18 Button_Cancel: TButton;
19 Button_OK: TButton;
20 Label_PreviewWith: TLabel;
21 Label_BlendOpCategory: TLabel;
22 Label_BlendOpValue: TLabel;
23 Label_SelectedBlendOp: TLabel;
24 Label_SvgOver: TLabel;
25 Label_KritaOver: TLabel;
26 Label_OtherOver: TLabel;
27 Label_PatternUnder: TLabel;
28 Label_PatternOver: TLabel;
29 ListBox_BlendOther: TListBox;
30 ListBox_BlendSvg: TListBox;
31 ListBox_BlendKrita: TListBox;
32 ListBox_PatternUnder: TListBox;
33 ListBox_PatternOver: TListBox;
34 ScrollBar1: TScrollBar;
35 TimerResize: TTimer;
36 procedure Button_OKClick(Sender: TObject);
37 procedure FormCreate(Sender: TObject);
38 procedure FormHide(Sender: TObject);
39 procedure FormResize(Sender: TObject);
40 procedure FormShow(Sender: TObject);
41 procedure ListBox_BlendDblClick(Sender: TObject);
42 procedure ListBox_BlendSelectionChange(Sender: TObject; {%H-}User: boolean);
43 procedure ListBox_DrawBlendItem(Control: TWinControl; Index: Integer;
44 ARect: TRect; State: TOwnerDrawState);
45 procedure ListBox_DrawPatternItem(Control: TWinControl;
46 Index: Integer; ARect: TRect; State: TOwnerDrawState);
47 procedure ListBox_PatternSelectionChange(Sender: TObject; {%H-}User: boolean
48 );
49 procedure ListBox_MeasureItem(Control: TWinControl;
50 {%H-}Index: Integer; var AHeight: Integer);
51 procedure TimerResizeTimer(Sender: TObject);
52 private
53 FPatterns: array of record
54 name:string;
55 bmp: TBGRABitmap;
56 width,height: integer;
57 end;
58 FListBoxInternalMargin: integer;
59 FFirstColumnLeft: integer;
60 FLastColumnRightMargin: integer;
61 FComputedWidth,FComputedHeight: integer;
62 procedure DrawPattern(ACanvas: TCanvas; ARect: TRect; APattern: string;
63 State: TOwnerDrawState);
GetPatternnull64 function GetPattern(AWidth, AHeight: integer; APattern: string;
65 ACheckers: boolean): TBGRABitmap;
66 { private declarations }
67 procedure UpdateBlendOpLabel;
68 procedure DiscardPatterns;
69 public
70 { public declarations }
71 SelectedBlendOp: TBlendOperation;
72 PatternUnder,PatternOver: TBGRABitmap;
73 end;
74
ShowBlendOpDialognull75 function ShowBlendOpDialog(AInstance: TLazPaintCustomInstance; var BlendOp: TBlendOperation; APatternUnder, APatternOver: TBGRABitmap): boolean;
76
77 implementation
78
79 uses LCLType,LCScaleDPI,umac,uresourcestrings,ugraph,BGRAThumbnail,Math, BGRATextFX;
80
GetPatternnull81 function TFBlendOp.GetPattern(AWidth,AHeight: integer; APattern: string; ACheckers: boolean): TBGRABitmap;
82 var lColor: TBGRAPixel;
83 idx: integer;
84 fullPatternName, attr: string;
85 i: integer;
86 begin
87 fullPatternName:= APattern;
88 for i := 0 to high(FPatterns) do
89 begin
90 if (FPatterns[i].name = fullPatternName) and (FPatterns[i].width = AWidth) and (FPatterns[i].height = AHeight) then
91 begin
92 result := FPatterns[i].bmp;
93 exit;
94 end;
95 end;
96 BGRAThumbnail.CheckersScale:= GetCanvasScaleFactor;
97 if APattern = 'Under' then
98 begin
99 result := GetBitmapThumbnail(PatternUnder,AWidth,AHeight,BGRAPixelTransparent,ACheckers) as TBGRABitmap;
100 end else
101 if APattern = 'Over' then
102 begin
103 result := GetBitmapThumbnail(PatternOver,AWidth,AHeight,BGRAPixelTransparent,ACheckers) as TBGRABitmap;
104 end else
105 begin
106 result := TBGRABitmap.Create(AWidth,AHeight, BGRABlack);
107 lColor := BGRAWhite;
108 idx := pos('.',APattern);
109 if idx <> 0 then
110 begin
111 attr := copy(APattern,idx+1,length(APattern)-idx);
112 delete(APattern,idx,length(APattern)-idx+1);
113 lColor := StrToBGRA(attr,BGRAWhite);
114 end;
115 if APattern = 'LeftToRight' then
116 result.GradientFill(0,0,result.Width,result.Height,BGRABlack,lColor,gtLinear,PointF(0,0),PointF(result.Width-1,0),dmSet,False) else
117 if APattern = 'TopToBottom' then
118 result.GradientFill(0,0,result.Width,result.Height,BGRABlack,lColor,gtLinear,PointF(0,0),PointF(0,result.Height-1),dmSet,False) else
119 if APattern = 'Ellipse' then
120 result.GradientFill(0,0,result.Width,result.Height,lColor,BGRABlack,gtRadial,PointF((result.Width-1)/2,(result.Height-1)/2),PointF(0,(result.Height-1)/2),dmSet,False);
121 BGRAReplace(result,GetBitmapThumbnail(result,AWidth,AHeight,BGRAPixelTransparent,false));
122 end;
123 BGRAThumbnail.CheckersScale:= 1;
124 setlength(FPatterns,length(FPatterns)+1);
125 FPatterns[high(FPatterns)].name := fullPatternName;
126 FPatterns[high(FPatterns)].bmp := result;
127 FPatterns[high(FPatterns)].width:= AWidth;
128 FPatterns[high(FPatterns)].height:= AHeight;
129 end;
130
131 procedure DrawPatternHighlight(ABmp: TBGRABitmap);
132 begin
133 ABmp.FillPoly([PointF(0,0),PointF(ABmp.Width,0),PointF(ABmp.Width,ABmp.Height),PointF(0,ABmp.Height),EmptyPointF,
134 PointF(ABmp.Width div 8,ABmp.Height*7 div 8),PointF(ABmp.Width*7 div 8,ABmp.Height*7 div 8),
135 PointF(ABmp.Width*7 div 8,ABmp.Height div 8),PointF(ABmp.Width div 8,ABmp.Height div 8)],
136 ColorToBGRA(ColorToRGB(clHighlight),128),dmDrawWithTransparency);
137 end;
138
139 procedure AddCheckersIfNeeded(var ABmp: TBGRABitmap);
140 var temp: TBGRABitmap;
141 begin
142 if ABmp.HasTransparentPixels then
143 begin
144 temp := TBGRABitmap.Create(ABmp.Width,ABmp.Height);
145 DrawCheckers(temp, rect(0,0,temp.Width,temp.Height));
146 temp.PutImage(0,0,ABmp,dmDrawWithTransparency);
147 ABmp.Free;
148 ABmp := temp;
149 end;
150 end;
151
152 procedure TFBlendOp.DrawPattern(ACanvas: TCanvas; ARect: TRect; APattern: string; State: TOwnerDrawState);
153 var bmp: TBGRABitmap;
154 scaling: Double;
155 begin
156 if (ARect.Right <= ARect.Left) or (ARect.Bottom <= ARect.Top) then exit;
157 scaling := GetCanvasScaleFactor;
158 bmp := TBGRABitmap.Create(round(ARect.Width*scaling),
159 round(ARect.Height*scaling), ColorToRGB(clBtnFace));
160 bmp.PutImage(0,0, GetPattern(bmp.width,bmp.height,APattern,True), dmDrawWithTransparency);
161 if odSelected in State then DrawPatternHighlight(bmp);
162 bmp.Draw(ACanvas,ARect,false);
163 bmp.Free;
164 end;
165
ShowBlendOpDialognull166 function ShowBlendOpDialog(AInstance: TLazPaintCustomInstance; var BlendOp: TBlendOperation; APatternUnder,
167 APatternOver: TBGRABitmap): boolean;
168 var f: TFBlendOp;
169 begin
170 result := false;
171 f:= TFBlendOp.Create(nil);
172 f.PatternOver := APatternOver;
173 f.PatternUnder := APatternUnder;
174 try
175 if f.ShowModal = mrOK then
176 begin
177 result := true;
178 BlendOp := f.SelectedBlendOp;
179 end;
180 except on ex:Exception do
181 AInstance.ShowError('ShowBlendOpDialog',ex.Message);
182 end;
183 f.Free;
184 end;
185
BlendThumbNailSizenull186 function BlendThumbNailSize: integer;
187 begin
188 result := ScaleY(80,OriginalDPI);
189 end;
190
191 { TFBlendOp }
192
193 procedure TFBlendOp.ListBox_DrawPatternItem(Control: TWinControl;
194 Index: Integer; ARect: TRect; State: TOwnerDrawState);
195 begin
196 {$IFDEF LINUX}
197 ARect.Right := ARect.Left+Control.Width-FListBoxInternalMargin;
198 {$ENDIF}
199 if Index <> -1 then
200 DrawPattern((Control as TListBox).Canvas,ARect,(Control as TListBox).Items[Index],State);
201 end;
202
203 procedure TFBlendOp.ListBox_PatternSelectionChange(Sender: TObject;
204 User: boolean);
205 begin
206 ListBox_BlendSvg.Invalidate;
207 ListBox_BlendKrita.Invalidate;
208 ListBox_BlendOther.Invalidate;
209 end;
210
211 procedure TFBlendOp.ListBox_MeasureItem(Control: TWinControl;
212 Index: Integer; var AHeight: Integer);
213 begin
214 AHeight := (Control as TListBox).ItemHeight;
215 end;
216
217 procedure TFBlendOp.TimerResizeTimer(Sender: TObject);
218 var leftPos: integer;
219 columnWidth, rowHeight: integer;
220 begin
221 DiscardPatterns;
222 leftPos := FFirstColumnLeft;
223 columnWidth := (ClientWidth - FLastColumnRightMargin - leftPos) div 3;
224 if columnWidth < 4 then columnWidth:= 4;
225 rowHeight := columnWidth*600 div 800;
226 Label_SvgOver.Left := leftPos;
227 Label_SvgOver.Width := columnWidth-2;
228 ListBox_BlendSvg.Left := leftPos;
229 ListBox_BlendSvg.Width := columnWidth-2;
230 ListBox_BlendSvg.ItemHeight := rowHeight;
231 leftPos += columnWidth;
232 Label_KritaOver.Left := leftPos;
233 Label_KritaOver.Width := columnWidth-2;
234 ListBox_BlendKrita.Left := leftPos;
235 ListBox_BlendKrita.Width := columnWidth-2;
236 ListBox_BlendKrita.ItemHeight := rowHeight;
237 leftPos += columnWidth;
238 Label_OtherOver.Left := leftPos;
239 Label_OtherOver.Width := columnWidth-2;
240 ListBox_BlendOther.Left := leftPos;
241 ListBox_BlendOther.Width := columnWidth-2;
242 ListBox_BlendOther.ItemHeight := rowHeight;
243 TimerResize.Enabled := false;
244 end;
245
246 procedure TFBlendOp.UpdateBlendOpLabel;
247 var str: string;
248 compatible: TStringList;
249 begin
250 if SelectedBlendOp = boTransparent then
251 str := rsNormalBlendOp
252 else
253 begin
254 str := BlendOperationStr[SelectedBlendOp];
255 compatible := TStringList.Create;
256 if SelectedBlendOp in[boColorBurn,boColorDodge,boDarken,boHardLight,boLighten,
257 boMultiply,boOverlay,boScreen,boSoftLight,boLinearDifference] then compatible.Add(rsAllApplications);
258 if SelectedBlendOp in[boLinearAdd,boXor,boGlow,boReflect,boLinearNegation] then compatible.Add('Paint.NET');
259 if SelectedBlendOp in[boDivide,boLinearAdd,boLinearExclusion,boLinearSubtract,boLinearSubtractInverse] then compatible.Add('Krita');
260 if compatible.Count = 0 then str += ' ('+rsLazPaintOnly+')' else
261 str += ' (' + compatible.CommaText+')';
262 compatible.Free;
263 end;
264 Label_BlendOpValue.Left := Label_SelectedBlendOp.Left + Label_SelectedBlendOp.Width + ScaleX(8,OriginalDPI);
265 Label_BlendOpValue.Caption := str;
266 end;
267
268 procedure TFBlendOp.DiscardPatterns;
269 var i: integer;
270 begin
271 for i := 0 to high(FPatterns) do
272 FPatterns[i].bmp.free;
273 FPatterns := nil;
274 end;
275
276 procedure TFBlendOp.FormCreate(Sender: TObject);
277 begin
278 ScaleControl(self,OriginalDPI);
279 FListBoxInternalMargin:= ListBox_PatternUnder.Width - ListBox_PatternUnder.ClientWidth + ScrollBar1.Height;
280 {$IFDEF LINUX}
281 ListBox_PatternUnder.Style := lbOwnerDrawVariable;
282 ListBox_PatternUnder.ScrollWidth := 0;
283 ListBox_PatternOver.Style := lbOwnerDrawVariable;
284 ListBox_PatternOver.ScrollWidth := 0;
285 ListBox_BlendSvg.Style := lbOwnerDrawVariable;
286 ListBox_BlendSvg.ScrollWidth := 0;
287 ListBox_BlendKrita.Style := lbOwnerDrawVariable;
288 ListBox_BlendKrita.ScrollWidth := 0;
289 ListBox_BlendOther.Style := lbOwnerDrawVariable;
290 ListBox_BlendOther.ScrollWidth := 0;
291 {$ENDIF}
292 ListBox_PatternUnder.ItemHeight := BlendThumbNailSize;
293 ListBox_PatternOver.ItemHeight := BlendThumbNailSize;
294 ListBox_BlendSvg.ItemHeight := BlendThumbNailSize;
295 ListBox_BlendKrita.ItemHeight := BlendThumbNailSize;
296 ListBox_BlendOther.ItemHeight := BlendThumbNailSize;
297 ListBox_PatternUnder.ItemIndex := 0;
298 ListBox_PatternOver.ItemIndex := 0;
299 CheckOKCancelBtns(Button_OK,Button_Cancel);
300 FFirstColumnLeft := ListBox_BlendSvg.Left;
301 FLastColumnRightMargin:= ClientWidth-(ListBox_BlendOther.Left+ListBox_BlendOther.Width);
302 TimerResizeTimer(nil);
303 end;
304
305 procedure TFBlendOp.FormHide(Sender: TObject);
306 begin
307 DiscardPatterns;
308 end;
309
310 procedure TFBlendOp.FormResize(Sender: TObject);
311 begin
312 TimerResize.Enabled := false;
313 TimerResize.Enabled := true;
314 end;
315
316 procedure TFBlendOp.Button_OKClick(Sender: TObject);
317 begin
318 ModalResult:= mrOk;
319 end;
320
321 procedure TFBlendOp.FormShow(Sender: TObject);
322 begin
323 SelectedBlendOp := boTransparent;
324 FComputedWidth := Max(PatternOver.Width,PatternUnder.Width);
325 FComputedHeight := Max(PatternOver.Height,PatternUnder.Height);
326 UpdateBlendOpLabel;
327 end;
328
329 procedure TFBlendOp.ListBox_BlendDblClick(Sender: TObject);
330 begin
331 if not Visible then exit;
332 with Sender as TListBox do
333 begin
334 if ItemIndex <> -1 then
335 begin
336 SelectedBlendOp := StrToBlendOperation(Items[ItemIndex]);
337 UpdateBlendOpLabel;
338 ModalResult := mrOk;
339 end;
340 end;
341 end;
342
343 procedure TFBlendOp.ListBox_BlendSelectionChange(Sender: TObject;
344 User: boolean);
345 begin
346 if not Visible then exit;
347 with Sender as TListBox do
348 begin
349 if ItemIndex <> -1 then
350 begin
351 SelectedBlendOp := StrToBlendOperation(Items[ItemIndex]);
352 UpdateBlendOpLabel;
353 if not (Sender = ListBox_BlendSvg) then ListBox_BlendSvg.ItemIndex := -1;
354 if not (Sender = ListBox_BlendKrita) then ListBox_BlendKrita.ItemIndex := -1;
355 if not (Sender = ListBox_BlendOther) then ListBox_BlendOther.ItemIndex := -1;
356 end;
357 end;
358 end;
359
360 procedure TFBlendOp.ListBox_DrawBlendItem(Control: TWinControl; Index: Integer;
361 ARect: TRect; State: TOwnerDrawState);
362 var
363 background,preview,over: TBGRABitmap;
364 w,h, checkerSize, shadowOfs: integer;
365 BlendStr: string;
366 fx: TBGRATextEffect;
367 scaling: Double;
368 begin
369 {$IFDEF LINUX}
370 ARect.Right := ARect.Left+Control.Width-FListBoxInternalMargin;
371 {$ENDIF}
372 if (ListBox_PatternUnder.ItemIndex <> -1) and
373 (ListBox_PatternOver.ItemIndex <> -1) and
374 (Index <> -1) then
375 begin
376 if (ARect.Right <= ARect.Left) or (ARect.Bottom <= ARect.Top) then exit;
377 BlendStr := (Control as TListBox).Items[Index];
378 scaling := GetCanvasScaleFactor;
379 checkerSize := DoScaleX(round(8*scaling), OriginalDPI);
380 w := round(ARect.Width*scaling);
381 h := round(ARect.Height*scaling);
382 background := TBGRABitmap.Create(w,h,ColorToBGRA(ColorToRGB(clBtnFace)));
383 background.DrawCheckers(background.ClipRect, ImageCheckersColor1, ImageCheckersColor2, checkerSize, checkerSize);
384 preview := GetPattern(w,h,ListBox_PatternUnder.Items[ListBox_PatternUnder.ItemIndex],False).Duplicate as TBGRABitmap;
385 over := GetPattern(w,h,ListBox_PatternOver.Items[ListBox_PatternOver.ItemIndex],False);
386 preview.BlendImageOver(0,0,over,StrToBlendOperation(BlendStr));
387 background.PutImage(0,0,preview,dmDrawWithTransparency);
388 preview.Free;
389 if odSelected in State then DrawPatternHighlight(background);
390 fx := TBGRATextEffect.Create(BlendStr,'Arial',Max(DoScaleY(round(12*scaling),OriginalDPI),h div 10),true);
391 shadowOfs := round(DoScaleX(round(10*scaling), OriginalDPI)/10);
392 fx.DrawShadow(background,1+shadowOfs,1+shadowOfs,DoScaleX(round(2*scaling), OriginalDPI),BGRABlack);
393 fx.DrawOutline(background,1,1,BGRABlack);
394 fx.Draw(background,1,1,BGRAWhite);
395 fx.Free;
396 background.FontName := 'Arial';
397 background.Draw((Control as TListBox).Canvas,ARect,True);
398 background.Free;
399 end;
400 end;
401
402 {$R *.lfm}
403
404 end.
405
406