Reducing the saturation of a bitmap

[MarkMLl]

I'm transferring a glyph (drawn with a saturated primary colour, or dark grey) from a TImageList onto a TBitmap, then placing a small amount of black text to its right.

I repeat this several times, resulting in different-coloured glyphs and accompanying text.

I'm then transferring the TBitmap to the canvas of a TPaintbox where it's visible.

The TBitmap remains buffered so that other redraws don't cause flickering.

Is there an easy way to reduce the saturation of both the glyph and the text before buffering it?

This is largely cosmetic, and I definitely don't want to get into anything like putting additional non-saturated colours into the TImageList.

MarkMLl

[MarkMLl]

Does anybody have any thoughts on this please? I anticipate that I'm going to have to work via an intermediate bitmap but the detail eludes me.

MarkMLl

[jamie]

R u referring to taking the contrast out of rhe image?

[Handoko]

Not exactly what MarkMLI needs, but has the code for doing color shifting:
https://forum.lazarus.freepascal.org/index.php/topic,37251.msg249962.html#msg249962

Then, we need to change the formula for reducing saturation. These info could be helpful:
https://sot.com.sg/hsl/
https://stackoverflow.com/questions/31627303/calculate-new-rgb-by-saturation

[MarkMLl]

That's another way of looking at it, but I want to leave the background (assumed to be transparent) unchanged.

Alternatively decreasing alpha.

I messed up the attached screenshot, but basically I want to de-emphasise a marker in the bottom part of the window if it's substantially to one side of the runway (i.e. in a parking area etc.).

MarkMLl

[MarkMLl]

Not exactly what MarkMLI needs, but has the code for doing color shifting:
https://forum.lazarus.freepascal.org/index.php/topic,37251.msg249962.html#msg249962

Then, we need to change the formula for reducing saturation. These info could be helpful:
https://sot.com.sg/hsl/
https://stackoverflow.com/questions/31627303/calculate-new-rgb-by-saturation

Thanks, looks helpful. Alternatively doing something with the pixels in a RawImage... I'm being cautious because of the warnings regarding poor performance on pixel-by-pixel operations on top of X11.

Considering https://wiki.freepascal.org/Developing_with_Graphics#Creating_and_drawing_a_transparent_bitmap_for_a_TImage I suspect that I might need to be careful with the drawing mode... or at least check that it's what's needed.

MarkMLl

[Ally]

Hello MarkMLl,

here is a small sample program.
The interesting part for you is the unit “rhsBitmapDesaturate.pas”.

Best regards
Roland

[MarkMLl]

here is a small sample program.
The interesting part for you is the unit “rhsBitmapDesaturate.pas”.

Now that looks like just about the job: thanks very much indeed :-)

MarkMLl

[Handoko]

I'm late. But here is my code:

Code: Pascal  [Select][+][-]

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Classes, SysUtils, Forms, Graphics, Dialogs, StdCtrls, ExtCtrls, LCLType,
9.   ComCtrls, Controls;
10.  
11. type
12.  
13.   { TForm1 }
14.  
15.   TForm1 = class(TForm)
16.     Button1: TButton;
17.     Button2: TButton;
18.     Image1: TImage;
19.     Image2: TImage;
20.     OpenDialog1: TOpenDialog;
21.     TrackBar1: TTrackBar;
22.     procedure Button1Click(Sender: TObject);
23.     procedure Button2Click(Sender: TObject);
24.     procedure FormCreate(Sender: TObject);
25.     procedure FormResize(Sender: TObject);
26.   end;
27.  
28. var
29.   Form1: TForm1;
30.  
31. implementation
32.  
33. const
34.   RedShift = 40;
35.   GreenShift = -40;
36.   BlueShift = -40;
37.  
38. {$R *.lfm}
39.  
40. { TForm1 }
41.  
42. procedure TForm1.Button1Click(Sender: TObject);
43. var
44.   AJpg:  TJPEGImage;
45. begin
46.   if not(OpenDialog1.Execute) then Exit;
47.   AJpg := TJpegImage.Create;
48.   AJpg.LoadFromFile(OpenDialog1.FileName);
49.   Image1.Picture.Bitmap.Assign(AJpg);
50.   AJpg.Free;
51.   Button2.Enabled := True;
52. end;
53.  
54. function inRange(S: Single): Byte;
55. begin
56.   if S <= 0 then
57.   begin
58.     Result := 0;
59.     Exit;
60.   end;
61.   if S >= 255 then
62.   begin
63.     Result := 255;
64.     Exit;
65.   end;
66.   Result := Round(S);
67. end;
68.  
69. procedure ChangeSaturation(Data: PRGBQUAD; Shift: Byte);
70. var
71.   Luminance:  Single;
72.   ValueRed:   Byte;
73.   ValueGreen: Byte;
74.   ValueBlue:  Byte;
75. begin
76.   ValueRed       := Data^.rgbRed;
77.   ValueGreen     := Data^.rgbGreen;
78.   ValueBlue      := Data^.rgbBlue;
79.   Luminance      := (ValueRed+ValueGreen+ValueBlue) / 3;
80.   Data^.rgbRed   := inRange((Shift/127*(ValueRed-Luminance)/Luminance + 1) *Luminance);
81.   Data^.rgbGreen := inRange((Shift/127*(ValueGreen-Luminance)/Luminance+1) *Luminance);
82.   Data^.rgbBlue  := inRange((Shift/127*(ValueBlue-Luminance)/Luminance+1)  *Luminance);
83. end;
84.  
85.  
86. procedure TForm1.Button2Click(Sender: TObject);
87. var
88.   ScanData: PRGBQuad;
89.   X, Y: Integer;
90. begin
91.   Image2.Picture.Clear;
92.   Image2.Picture.Assign(Image1.Picture);
93.   Image2.Picture.Bitmap.BeginUpdate;
94.   for Y := 0 to (Image1.Picture.Bitmap.Height-1) do
95.   begin
96.     ScanData := Image2.Picture.Bitmap.ScanLine[Y];
97.     for X:= 0 to (Image1.Picture.Bitmap.Width-1) do
98.     begin
99.       ChangeSaturation(ScanData, TrackBar1.Position);
100.       Inc(ScanData);
101.     end;
102.   end;
103.   Image2.Picture.Bitmap.EndUpdate;
104. end;
105.  
106. procedure TForm1.FormCreate(Sender: TObject);
107. begin
108.   Constraints.MinHeight := 200;
109.   Constraints.MinWidth  := 360;
110.   TrackBar1.Anchors := [akTop, akLeft, akRight];
111.   Image1.Anchors    := [akTop, akBottom, akLeft];
112.   Image2.Anchors    := [akTop, akBottom, akLeft];
113. end;
114.  
115. procedure TForm1.FormResize(Sender: TObject);
116. var
117.   i: Integer;
118. begin
119.   i := (Width - 60) div 2;
120.   Image1.Width := i;
121.   Image2.Left  := i + 40;
122.   Image2.Width := i;
123. end;
124.  
125. end.

[MarkMLl]

I'm late. But here is my code:

Thanks, tinkering continues.

I've backtracked a little and am investigating using the alpha colour component of the text that's being generated on-the-fly, that might possibly be a bit "jumpy" which might depend on the widgetset. /If/ that works then all I'll have to do is fiddle with the glyph which is small (typically 12x12) so "cheap" in computation terms, otherwise I can put both glyph and text into a temporary bitmap (term used loosely) for manipulation.

With reference to the image I posted earlier, what I'd like is for a plane doing an overhead crossfield pass to fade into and then out of visibility as it passes above the runway, or for planes parked near but not on the runway to appear as "ghosts".

Hopefully I'll get plenty of test data tomorrow since the local pilots will be out in force. I've been working on this on and off since 2023...

MarkMLl

[MarkMLl]

What needs to be done to use the alpha component of e.g. a colour when drawing into a bitmap or transferring to a canvas, or is this sufficiently implementation-specific as to be best avoided?

If I do something like this

Code: Pascal  [Select][+][-]

1.  (* Draw a border on the outermost pixels, the background colour should
2.     approximate that of the map so that the same coloured symbols representing
3.     aircraft show up.
4.   *)
5.   procedure border;
6.  
7.   begin
8. //    buffer.BeginUpdate;
9.     with buffer.Canvas do begin
10.       Pen.Color := $00f0f0f0;
11.       Pen.Style := psSolid;
12.       Pen.Width := 1;
13.       Brush.Color := $00f0f0f0;
14.       Rectangle(0, 0, bmW, bmH);
15.       Pen.Color := clBlack;
16.  
17.       Line(0, 0, bmW, 0);               (* Draw right to edge                   *)
18.       Line(bmW - 1, 0, bmW - 1, bmH);
19.       Line(bmW - 1, bmH - 1, 0, bmH - 1);
20.       Line(0, bmH - 1, 0, 0);
21.  
22.       if hud in [HudT, HudB] then begin
23.         Line(0, 0, bmW, 0);             (* Draw right to edge                   *)
24.         Line(0, bmH - 1, bmW, bmH - 1)
25.       end else begin
26.         Line(0, 0, 0, bmH);             (* Draw right to edge                   *)
27.         Line(bmW - 1, 0, bmW - 1, bmH)
28.       end
29. ;
30. Font.Color := TColor(clBlack + qword($00 << 24));
31. TextOut(15, 15, 'X')
32.  
33. ;
34. Font.Color := TColor(clBlack + qword($40 << 24));
35. TextOut(30, 30, 'X')
36.  
37. ;
38. Font.Color := TColor(clBlack + qword($80 << 24));
39. TextOut(45, 45, 'X')
40.  
41. ;
42. Font.Color := TColor(clBlack + qword($c0 << 24));
43. TextOut(60, 60, 'X')
44.  
45. ;
46. Font.Color := TColor(clBlack + qword($ff << 24));
47. TextOut(75, 75, 'X')
48.  
49.  
50.     end;
51. //    buffer.EndUpdate
52.   end { border } ;
53.  

where buffer is a TBitmap and bmH etc. is initialised to its container's size then Xs with an alpha component <= $7f appear OK but the others are invisible. If at the point of the bitmap's creation I do

Code: Pascal  [Select][+][-]

1.     hudBmps[hud] := TBitmap.Create;
2.     hudBmps[hud].PixelFormat := pf32bit;
3.  

nothing appears at all when the bitmap is transferred to a GUI component's canvas using Draw()... I suspect because the component's pixelformat hasn't been set.

So, is the transparency of text etc. easily set, or is this best avoided?

MarkMLl