1 // SPDX-License-Identifier: GPL-3.0-only
2 unit UPhongFilter;
3 
4 {$mode objfpc}{$H+}
5 
6 interface
7 
8 uses
9   Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
10   StdCtrls, ExtCtrls, Spin, UFilterConnector, BGRABitmapTypes, BGRABitmap,
11   UScripting;
12 
13 type
14 
15   { TFPhongFilter }
16 
17   TFPhongFilter = class(TForm)
18     Button_Cancel: TButton;
19     Button_OK: TButton;
20     GroupBox_Color: TGroupBox;
21     GroupBox_Color1: TGroupBox;
22     Label_LightPosition: TLabel;
23     Label_Altitude: TLabel;
24     PaintBox1: TPaintBox;
25     Radio_MapLinearLightness: TRadioButton;
26     Radio_MapSaturation: TRadioButton;
27     Radio_UseKeep: TRadioButton;
28     Radio_UseBackColor: TRadioButton;
29     Radio_MapLightness: TRadioButton;
30     Radio_UsePenColor: TRadioButton;
31     Radio_MapAlpha: TRadioButton;
32     Radio_UseTexture: TRadioButton;
33     Radio_MapRed: TRadioButton;
34     Radio_MapGreen: TRadioButton;
35     Radio_MapBlue: TRadioButton;
36     SpinEdit_Altitude: TSpinEdit;
37     Timer1: TTimer;
38     procedure Button_OKClick(Sender: TObject);
39     procedure FormCreate(Sender: TObject);
40     procedure FormDestroy(Sender: TObject);
41     procedure FormShow(Sender: TObject);
42     procedure PaintBox1MouseDown(Sender: TObject; {%H-}Button: TMouseButton;
43       {%H-}Shift: TShiftState; X, Y: Integer);
44     procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
45       Y: Integer);
46     procedure PaintBox1Paint(Sender: TObject);
47     procedure Radio_MapChange(Sender: TObject);
48     procedure Radio_UseChange(Sender: TObject);
49     procedure SpinEdit_AltitudeChange(Sender: TObject);
50     procedure Timer1Timer(Sender: TObject);
51   private
52     { private declarations }
53     FInitializing: boolean;
54     FCenter: TPointF;
55     FHeightMap: TBGRABitmap;
56     FWorkspaceColor: TColor;
57     FTexture: TBGRACustomBitmap;
GetCurrentLightPosnull58     function GetCurrentLightPos: TPointF;
59     procedure InitParams;
60     procedure PreviewNeeded;
ComputeFilteredLayernull61     function ComputeFilteredLayer: TBGRABitmap;
62   public
63     FilterConnector: TFilterConnector;
64     property CurrentLightPos: TPointF read GetCurrentLightPos;
65   end;
66 
ShowPhongFilterDlgnull67 function ShowPhongFilterDlg(AFilterConnector: TObject): TScriptResult;
68 
69 implementation
70 
71 uses LCScaleDPI, UMac, BGRAGradients, LazPaintType;
72 
ShowPhongFilterDlgnull73 function ShowPhongFilterDlg(AFilterConnector: TObject): TScriptResult;
74 var
75   FPhongFilter: TFPhongFilter;
76 begin
77   FPhongFilter:= TFPhongFilter.create(nil);
78   FPhongFilter.FilterConnector := AFilterConnector as TFilterConnector;
79   FPhongFilter.FWorkspaceColor:= FPhongFilter.FilterConnector.LazPaintInstance.Config.GetWorkspaceColor;
80   try
81     if FPhongFilter.FilterConnector.ActiveLayer <> nil then
82     begin
83       if Assigned(FPhongFilter.FilterConnector.Parameters) and
84         FPhongFilter.FilterConnector.Parameters.Booleans['Validate'] then
85       begin
86         FPhongFilter.InitParams;
87         FPhongFilter.PreviewNeeded;
88         FPhongFilter.FilterConnector.PutImage(FPhongFilter.ComputeFilteredLayer,true,true);
89         FPhongFilter.FilterConnector.ValidateAction;
90         result := srOk;
91       end else
92       begin
93         if FPhongFilter.showModal = mrOk then result := srOk
94         else result := srCancelledByUser;
95       end;
96     end
97     else
98       result := srException;
99   finally
100     FPhongFilter.free;
101   end;
102 end;
103 
104 { TFPhongFilter }
105 
106 procedure TFPhongFilter.Button_OKClick(Sender: TObject);
107 begin
108   FilterConnector.ValidateAction;
109   FilterConnector.LazPaintInstance.Config.SetDefaultPhongFilterAltitude(SpinEdit_Altitude.Value);
110   FilterConnector.LazPaintInstance.ToolManager.LightPosition := CurrentLightPos;
111   ModalResult := mrOK;
112 end;
113 
114 procedure TFPhongFilter.FormCreate(Sender: TObject);
115 begin
116   ScaleControl(Self,OriginalDPI);
117   CheckOKCancelBtns(Button_OK,Button_Cancel);
118   FCenter := PointF(0.5,0.5);
119   FWorkspaceColor:= clAppWorkspace;
120 end;
121 
122 procedure TFPhongFilter.FormDestroy(Sender: TObject);
123 begin
124   FreeAndNil(FHeightMap);
125   if Assigned(FTexture) then FTexture.Free;
126 end;
127 
128 
129 procedure TFPhongFilter.FormShow(Sender: TObject);
130 begin
131   InitParams;
132   PreviewNeeded;
133 end;
134 
135 procedure TFPhongFilter.PaintBox1MouseDown(Sender: TObject;
136   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
137 begin
138   FCenter := PointF(X/PaintBox1.Width*2-0.5,Y/PaintBox1.Height*2-0.5);
139   PaintBox1.Invalidate;
140   PreviewNeeded;
141 end;
142 
143 procedure TFPhongFilter.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState;
144   X, Y: Integer);
145 begin
146   if ssLeft in Shift then
147   begin
148     FCenter := PointF(X/PaintBox1.Width*2-0.5,Y/PaintBox1.Height*2-0.5);
149     PaintBox1.Invalidate;
150     PreviewNeeded;
151   end;
152 end;
153 
154 procedure TFPhongFilter.PaintBox1Paint(Sender: TObject);
155 var x,y: integer;
156 begin
157   x := round((FCenter.X+0.5)*PaintBox1.Width/2);
158   y := round((FCenter.Y+0.5)*PaintBox1.Height/2);
159   PaintBox1.Canvas.Brush.Style := bsSolid;
160   PaintBox1.Canvas.Brush.Color := FWorkspaceColor;
161   PaintBox1.Canvas.Pen.Style := psSolid;
162   PaintBox1.Canvas.Pen.Color := MergeBGRA(ColorToBGRA(clBlack),ColorToBGRA(FWorkspaceColor));
163   PaintBox1.Canvas.Rectangle(0,0,PaintBox1.Width,PaintBox1.Height);
164   PaintBox1.Canvas.Pen.Style := psDot;
165   PaintBox1.Canvas.Pen.Color := clBlack;
166   PaintBox1.Canvas.Brush.Style := bsSolid;
167   PaintBox1.Canvas.Brush.Color := clWhite;
168   PaintBox1.Canvas.Rectangle(PaintBox1.Width div 4,PaintBox1.Height div 4,PaintBox1.Width*3 div 4,PaintBox1.Height*3 div 4);
169   PaintBox1.Canvas.Pen.Style := psSolid;
170   PaintBox1.Canvas.Pen.Color := clBlack;
171   PaintBox1.Canvas.Brush.Style := bsSolid;
172   PaintBox1.Canvas.Brush.Color := clWhite;
173   PaintBox1.Canvas.Ellipse(x-3,y-3,x+4,y+4);
174 end;
175 
176 procedure TFPhongFilter.Radio_MapChange(Sender: TObject);
177 begin
178   FreeAndNil(FHeightMap);
179   if not FInitializing then PreviewNeeded;
180 end;
181 
182 procedure TFPhongFilter.Radio_UseChange(Sender: TObject);
183 begin
184   if not FInitializing then PreviewNeeded;
185 end;
186 
187 procedure TFPhongFilter.SpinEdit_AltitudeChange(Sender: TObject);
188 begin
189   if SpinEdit_Altitude.Value < 6 then
190     SpinEdit_Altitude.Increment := 1
191   else if SpinEdit_Altitude.Value < 25 then
192     SpinEdit_Altitude.Increment := 3
193   else
194     SpinEdit_Altitude.Increment := 5;
195   if not FInitializing then PreviewNeeded;
196 end;
197 
198 procedure TFPhongFilter.Timer1Timer(Sender: TObject);
199 begin
200   Timer1.Enabled := false;
201   FilterConnector.PutImage(ComputeFilteredLayer,True,true);
202   Button_OK.Enabled := true;
203 end;
204 
205 procedure TFPhongFilter.PreviewNeeded;
206 begin
207   Timer1.Enabled := false;
208   Timer1.Enabled := True;
209   Button_OK.Enabled := false;
210 end;
211 
TFPhongFilter.GetCurrentLightPosnull212 function TFPhongFilter.GetCurrentLightPos: TPointF;
213 begin
214   result := PointF(FCenter.X*FilterConnector.ActiveLayer.Width,
215     FCenter.Y*FilterConnector.ActiveLayer.Height);
216 end;
217 
218 procedure TFPhongFilter.InitParams;
219 var
220   texOpacity: Byte;
221 begin
222   FInitializing:= true;
223   Radio_UseTexture.Enabled := (FilterConnector.LazPaintInstance.ToolManager.BackFill.Texture <> nil);
224   if FTexture <> nil then
225   begin
226     FTexture.FreeReference;
227     FTexture := nil;
228   end;
229   if Radio_UseTexture.Enabled then
230   begin
231     Radio_UseTexture.Checked := true;
232     texOpacity := FilterConnector.LazPaintInstance.ToolManager.BackFill.TextureOpacity;
233     if texOpacity <> 255 then
234     begin
235       FTexture := FilterConnector.LazPaintInstance.ToolManager.BackFill.Texture.Duplicate;
236       FTexture.ApplyGlobalOpacity(texOpacity);
237     end else
238       FTexture := FilterConnector.LazPaintInstance.ToolManager.BackFill.Texture.NewReference;
239   end
240   else Radio_UsePenColor.Checked := true;
241   SpinEdit_Altitude.Value := FilterConnector.LazPaintInstance.Config.DefaultPhongFilterAltitude;
242   with FilterConnector.LazPaintInstance.ToolManager.LightPosition do
243     FCenter := PointF(X/FilterConnector.LazPaintInstance.Image.Width,
244         Y/FilterConnector.LazPaintInstance.Image.Height);
245   if Assigned(FilterConnector.Parameters) then
246   with FilterConnector.Parameters do
247   begin
248     if IsDefined('ColorSource') then
249     case Strings['ColorSource'] of
250     'Pen': Radio_UsePenColor.checked := true;
251     'Back': Radio_UseBackColor.checked := true;
252     'Layer': Radio_UseKeep.checked := true;
253     end;
254     if IsDefined('AltitudePercent') then
255       SpinEdit_Altitude.Value := Integers['AltitudePercent'];
256     if IsDefined('LightPosPercent') then
257       FCenter := Points2D['LightPosPercent']*(1/100);
258     if IsDefined('LightXPercent') then
259       FCenter.x := Floats['LightXPercent']/100;
260     if IsDefined('LightYPercent') then
261       FCenter.y := Floats['LightYPercent']/100;
262     if IsDefined('AltitudeSource') then
263     case Strings['AltitudeSource'] of
264     'Lightness': Radio_MapLightness.Checked:= true;
265     'LinearLightness': Radio_MapLinearLightness.Checked:= true;
266     'Saturation': Radio_MapSaturation.Checked:= true;
267     'Alpha': Radio_MapAlpha.Checked:= true;
268     'Red': Radio_MapRed.Checked:= true;
269     'Green': Radio_MapGreen.Checked:= true;
270     'Blue': Radio_MapBlue.Checked:= true;
271     end;
272   end;
273   SpinEdit_AltitudeChange(nil);
274   FInitializing := false;
275 end;
276 
277 procedure ScanLineMapLightness(psrc,pdest: PBGRAPixel; count: integer);
278 const oneOver65535 = 1/65535;
279 begin
280   while count > 0 do
281   begin
282     pdest^ := MapHeightToBGRA(GetLightness(GammaExpansion(psrc^))*oneOver65535,psrc^.alpha);
283     inc(pdest);
284     inc(psrc);
285     dec(count);
286   end;
287 end;
288 
289 procedure ScanLineMapLinearLightness(psrc,pdest: PBGRAPixel; count: integer);
290 const oneOver255 = 1/255;
291 begin
292   while count > 0 do
293   begin
294     pdest^ := MapHeightToBGRA((psrc^.red*0.299+psrc^.green*0.587+psrc^.blue*0.114)*oneOver255,psrc^.alpha);
295     inc(pdest);
296     inc(psrc);
297     dec(count);
298   end;
299 end;
300 
301 procedure ScanLineMapAlpha(psrc,pdest: PBGRAPixel; count: integer);
302 begin
303   while count > 0 do
304   begin
305     pdest^ := BGRA(psrc^.alpha,psrc^.alpha,psrc^.alpha,255);
306     inc(pdest);
307     inc(psrc);
308     dec(count);
309   end;
310 end;
311 
312 procedure ScanLineMapBlue(psrc,pdest: PBGRAPixel; count: integer);
313 begin
314   while count > 0 do
315   begin
316     pdest^ := BGRA(psrc^.blue,psrc^.blue,psrc^.blue,psrc^.alpha);
317     inc(pdest);
318     inc(psrc);
319     dec(count);
320   end;
321 end;
322 
323 procedure ScanLineMapGreen(psrc,pdest: PBGRAPixel; count: integer);
324 begin
325   while count > 0 do
326   begin
327     pdest^ := BGRA(psrc^.green,psrc^.green,psrc^.green,psrc^.alpha);
328     inc(pdest);
329     inc(psrc);
330     dec(count);
331   end;
332 end;
333 
334 procedure ScanLineMapRed(psrc,pdest: PBGRAPixel; count: integer);
335 begin
336   while count > 0 do
337   begin
338     pdest^ := BGRA(psrc^.red,psrc^.red,psrc^.red,psrc^.alpha);
339     inc(pdest);
340     inc(psrc);
341     dec(count);
342   end;
343 end;
344 
345 procedure ScanLineMapSaturation(psrc,pdest: PBGRAPixel; count: integer);
346 const oneOver65535 = 1/65535;
347 begin
348   while count > 0 do
349   begin
350     with BGRAToHSLA(psrc^) do
351       pdest^ := MapHeightToBGRA(saturation*oneOver65535,psrc^.alpha);
352     inc(pdest);
353     inc(psrc);
354     dec(count);
355   end;
356 end;
357 
TFPhongFilter.ComputeFilteredLayernull358 function TFPhongFilter.ComputeFilteredLayer: TBGRABitmap;
359 var shader: TPhongShading;
360   yb: integer;
361   scanlineMapFunc: procedure(psrc,pdest: PBGRAPixel; count: integer);
362 
363 begin
364   result := TBGRABitmap.Create(FilterConnector.ActiveLayer.Width, FilterConnector.ActiveLayer.Height);
365   shader := TPhongShading.Create;
366   shader.AmbientFactor := 0.5;
367   shader.NegativeDiffusionFactor := 0.15;
368   shader.LightPositionF := CurrentLightPos;
369   shader.LightPositionZ := FilterConnector.LazPaintInstance.ToolManager.LightAltitude;
370   if FHeightMap = nil then
371   begin
372     if Radio_MapLightness.Checked then
373       scanlineMapFunc := @ScanLineMapLightness
374     else if Radio_MapLinearLightness.Checked then
375       scanlineMapFunc := @ScanLineMapLinearLightness
376     else if Radio_MapAlpha.Checked then
377       scanlineMapFunc := @ScanLineMapAlpha
378     else if Radio_MapBlue.Checked then
379       scanlineMapFunc := @ScanLineMapBlue
380     else if Radio_MapGreen.Checked then
381       scanlineMapFunc := @ScanLineMapGreen
382     else if Radio_MapRed.Checked then
383       scanlineMapFunc := @ScanLineMapRed
384     else if Radio_MapSaturation.Checked then
385       scanlineMapFunc := @ScanLineMapSaturation
386     else
387       scanlineMapFunc := nil;
388 
389     if Assigned(scanlineMapFunc) then
390     begin
391       FHeightMap := TBGRABitmap.Create(FilterConnector.BackupLayer.Width,FilterConnector.BackupLayer.Height);
392       for yb := FilterConnector.WorkArea.Top to FilterConnector.WorkArea.Bottom-1 do
393         scanlineMapFunc(FilterConnector.BackupLayer.ScanLine[yb]+FilterConnector.WorkArea.Left,
394           FHeightMap.ScanLine[yb]+FilterConnector.WorkArea.Left, FilterConnector.WorkArea.Right - FilterConnector.WorkArea.Left);
395     end;
396   end;
397   if FHeightMap <> nil then
398   begin
399     if Radio_UseTexture.Checked then
400       shader.DrawScan(result, FHeightMap, SpinEdit_Altitude.Value, 0, 0, FTexture)
401     else if Radio_UsePenColor.Checked then
402       shader.Draw(result, FHeightMap, SpinEdit_Altitude.Value,0,0,FilterConnector.LazPaintInstance.ToolManager.ForeColor)
403     else if Radio_UseKeep.Checked then
404       shader.Draw(result, FHeightMap, SpinEdit_Altitude.Value,0,0,FilterConnector.BackupLayer)
405     else
406       shader.Draw(result, FHeightMap, SpinEdit_Altitude.Value,0,0,FilterConnector.LazPaintInstance.ToolManager.BackColor);
407   end;
408   shader.Free;
409 end;
410 
411 {$R *.lfm}
412 
413 end.
414 
415