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