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