1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 {
3  /**************************************************************************\
4                              bgragtkbitmap.pas
5                              -----------------
6                  This unit should NOT be added to the 'uses' clause.
7                  It contains patches for Gtk.
8 }
9 
10 unit BGRAGtkBitmap;
11 
12 {$mode objfpc}{$H+}
13 
14 interface
15 
16 uses
17   BGRAClasses, SysUtils, BGRALCLBitmap, Graphics,
18   GraphType;
19 
20 type
21   { TBGRAGtkBitmap }
22 
23   TBGRAGtkBitmap = class(TBGRALCLBitmap)
24   private
25     FPixBuf: Pointer;
26     procedure DrawTransparent(ACanvas: TCanvas; Rect: TRect);
27     procedure DrawOpaque(ACanvas: TCanvas; ARect: TRect);
28   protected
29     procedure ReallocData; override;
30     procedure FreeData; override;
31   public
32     procedure DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
33       AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
34       override;
35     procedure DrawPart(ARect: TRect; ACanvas: TCanvas; x, y: integer; Opaque: boolean); override;
36     procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); override;
37     procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override;
38     procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; AData: Pointer;
39       ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); overload; override;
40     procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; ADataFirstRow: Pointer;
41       ARowStride: integer; AWidth, AHeight: integer); overload;
42     procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override;
43   end;
44 
45 implementation
46 
47 uses BGRABitmapTypes, BGRADefaultBitmap, BGRAFilterScanner, LCLType,
48   LCLIntf, IntfGraphics,
49   {$IFDEF LCLgtk2}
50   gdk2, gtk2def, gdk2pixbuf, glib2,
51   {$ENDIF}
52   {$IFDEF LCLgtk}
53   gdk, gtkdef, gtkProc, gdkpixbuf, glib,
54   {$ENDIF}
55   FPImage, Dialogs;
56 
57 procedure TBGRAGtkBitmap.ReallocData;
58 begin
59   {$IFDEF LCLgtk2}
60   If FPixBuf <> nil then g_object_unref(FPixBuf);
61   {$ELSE}
62   If FPixBuf <> nil then gdk_pixbuf_unref(FPixBuf);
63   {$ENDIF}
64   FPixBuf := nil;
65   inherited ReallocData;
66   if (FWidth <> 0) and (FHeight <> 0) then
67   begin
68     FPixbuf := gdk_pixbuf_new_from_data(pguchar(FDataByte),
69       GDK_COLORSPACE_RGB, True, 8, Width, Height, Width*Sizeof(TBGRAPixel), nil, nil);
70     if FPixbuf = nil then
71       raise Exception.Create('Error initializing Pixbuf');
72   end;
73 end;
74 
75 procedure TBGRAGtkBitmap.FreeData;
76 begin
77   {$IFDEF LCLgtk2}
78   If FPixBuf <> nil then g_object_unref(FPixBuf);
79   {$ELSE}
80   If FPixBuf <> nil then gdk_pixbuf_unref(FPixBuf);
81   {$ENDIF}
82   FPixBuf := nil;
83   inherited FreeData;
84 end;
85 
86 procedure TBGRAGtkBitmap.DrawTransparent(ACanvas: TCanvas; Rect: TRect);
87 var DrawWidth,DrawHeight: integer;
88     stretched: TBGRAGtkBitmap;
89     P: TPoint;
90 begin
91   DrawWidth := Rect.Right-Rect.Left;
92   DrawHeight := Rect.Bottom-Rect.Top;
93   if (Height = 0) or (Width = 0) or (DrawWidth <= 0) or (DrawHeight <= 0) then
94     exit;
95 
96   if (DrawWidth <> Width) or (DrawHeight <> Height) then
97   begin
98     stretched := Resample(DrawWidth,DrawHeight,rmSimpleStretch) as TBGRAGtkBitmap;
99     stretched.DrawTransparent(ACanvas,Rect);
100     stretched.Free;
101     exit;
102   end;
103 
104   LoadFromBitmapIfNeeded;
105 
106   {$PUSH}{$WARNINGS OFF}If not TBGRAPixel_RGBAOrder then SwapRedBlue;{$POP}
107 
108   P := Rect.TopLeft;
109   LPToDP(ACanvas.Handle, P, 1);
110   gdk_pixbuf_render_to_drawable(FPixBuf,
111     TGtkDeviceContext(ACanvas.Handle).Drawable,
112     TGtkDeviceContext(ACanvas.Handle).GC,
113     0,0, P.X,P.Y,
114     Width,Height,
115     GDK_RGB_DITHER_NORMAL,0,0);
116 
117   {$PUSH}{$WARNINGS OFF}If not TBGRAPixel_RGBAOrder then SwapRedBlue;{$POP}
118 end;
119 
120 procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; ARect: TRect);
121 begin
122   DataDrawOpaque(ACanvas,ARect,Data,LineOrder,Width,Height);
123 end;
124 
125 procedure TBGRAGtkBitmap.DataDrawTransparent(ACanvas: TCanvas; Rect: TRect;
126   AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
127 var
128   TempGtk: TBGRAGtkBitmap;
129   temp: integer;
130 begin
131   if (AHeight = 0) or (AWidth = 0) or (Rect.Left = Rect.Right) or
132     (Rect.Top = Rect.Bottom) then
133     exit;
134 
135   if Rect.Right < Rect.Left then
136   begin
137     temp := Rect.Left;
138     Rect.Left := Rect.Right;
139     Rect.Right := temp;
140   end;
141 
142   if Rect.Bottom < Rect.Top then
143   begin
144     temp := Rect.Top;
145     Rect.Top := Rect.Bottom;
146     Rect.Bottom := temp;
147   end;
148 
149   TempGtk := TBGRAGtkBitmap.Create(AWidth, AHeight);
150   Move(AData^,TempGtk.Data^,TempGtk.NbPixels*sizeof(TBGRAPixel));
151   if ALineOrder <> TempGtk.LineOrder then TempGtk.VerticalFlip;
152   TempGtk.DrawTransparent(ACanvas,Rect);
153   TempGtk.Free;
154 end;
155 
156 procedure TBGRAGtkBitmap.DrawPart(ARect: TRect; ACanvas: TCanvas; x,
157   y: integer; Opaque: boolean);
158 var
159   rowStride,w,h: Integer;
160 begin
161   if Opaque then
162   begin
163     if LineOrder = riloTopToBottom then
164       rowStride := Width*sizeof(TBGRAPixel)
165     else
166       rowStride := -Width*sizeof(TBGRAPixel);
167     w:= ARect.Right-ARect.Left;
168     h:= ARect.Bottom-ARect.Top;
169     DataDrawOpaque(ACanvas, rect(x,y,x+w,y+h), Scanline[ARect.Top]+ARect.Left, rowStride, w,h);
170   end
171   else
172     inherited DrawPart(ARect, ACanvas, x, y, Opaque);
173 end;
174 
175 procedure TBGRAGtkBitmap.Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean);
176 begin
177   if self = nil then
178     exit;
179   if Opaque then
180     DrawOpaque(ACanvas, Rect(X, Y, X + Width, Y + Height))
181   else
182     DrawTransparent(ACanvas, Rect(X, Y, X + Width, Y + Height));
183 end;
184 
185 procedure TBGRAGtkBitmap.Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean);
186 begin
187   if self = nil then
188     exit;
189   if Opaque then
190     DrawOpaque(ACanvas, Rect)
191   else
192     DrawTransparent(ACanvas, Rect);
193 end;
194 
195 procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
196   AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
197 var
198   rowStride: Integer;
199   firstRow: Pointer;
200 begin
201   if ALineOrder = riloTopToBottom then
202   begin
203     rowStride := AWidth*sizeof(TBGRAPixel);
204     firstRow := AData;
205   end
206   else
207   begin
208     rowStride := -AWidth*sizeof(TBGRAPixel);
209     firstRow := PBGRAPixel(AData) + (AWidth*(AHeight-1));
210   end;
211 
212   DataDrawOpaque(ACanvas, ARect, firstRow, rowStride, AWidth, AHeight);
213 end;
214 
215 procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
216   ADataFirstRow: Pointer; ARowStride: integer; AWidth, AHeight: integer);
217 
218   procedure DataSwapRedBlue;
219   var
220     y: Integer;
221     p: PByte;
222   begin
223     p := PByte(ADataFirstRow);
224     for y := 0 to AHeight-1 do
225     begin
226       TBGRAFilterScannerSwapRedBlue.ComputeFilterAt(PBGRAPixel(p),PBGRAPixel(p),AWidth,False);
227       inc(p, ARowStride);
228     end;
229   end;
230 
231   procedure DrawStretched;
232   var
233     dataStart: Pointer;
234     ptr: TBGRAPtrBitmap;
235     stretched: TBGRACustomBitmap;
236   begin
237     if ARowStride < 0 then
238       dataStart := PByte(ADataFirstRow) + ARowStride*(Height-1)
239     else
240       dataStart := ADataFirstRow;
241 
242     if ARowStride <> abs(AWidth*sizeof(TBGRAPixel)) then
243       raise exception.Create('DataDrawOpaque not supported when using custom row stride and resample');
244 
245     ptr := TBGRAPtrBitmap.Create(AWidth,AHeight,dataStart);
246     if ARowStride < 0 then
247       ptr.LineOrder := riloBottomToTop
248     else
249       ptr.LineOrder := riloTopToBottom;
250     stretched := ptr.Resample(ARect.Right-ARect.Left,ARect.Bottom-ARect.Top);
251     ptr.free;
252     DataDrawOpaque(ACanvas,ARect,stretched.Data,stretched.LineOrder,stretched.Width,stretched.Height);
253     stretched.Free;
254   end;
255 
256 var
257   temp: integer;
258   pos: TPoint;
259   dest: HDC;
260 
261 begin
262   if (AHeight = 0) or (AWidth = 0) or (ARect.Left = ARect.Right) or
263     (ARect.Top = ARect.Bottom) then exit;
264 
265   if ARect.Right < ARect.Left then
266   begin
267     temp := ARect.Left;
268     ARect.Left := ARect.Right;
269     ARect.Right := temp;
270   end;
271 
272   if ARect.Bottom < ARect.Top then
273   begin
274     temp := ARect.Top;
275     ARect.Top := ARect.Bottom;
276     ARect.Bottom := temp;
277   end;
278 
279   if (AWidth <> ARect.Right-ARect.Left) or (AHeight <> ARect.Bottom-ARect.Top) then
280     DrawStretched
281   else
282   begin
283     dest := ACanvas.Handle;
284     pos := ARect.TopLeft;
285     LPtoDP(dest, pos, 1);
286     {$PUSH}{$WARNINGS OFF}if not TBGRAPixel_RGBAOrder then DataSwapRedBlue;{$POP}
287     gdk_draw_rgb_32_image(TGtkDeviceContext(dest).Drawable,
288       TGtkDeviceContext(Dest).GC, pos.x,pos.y,
289       AWidth,AHeight, GDK_RGB_DITHER_NORMAL,
290       ADataFirstRow, ARowStride);
291     {$PUSH}{$WARNINGS OFF}if not TBGRAPixel_RGBAOrder then DataSwapRedBlue;{$POP}
292     ACanvas.Changed;
293   end;
294 end;
295 
296 procedure TBGRAGtkBitmap.GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer);
297 var
298   subBmp: TBGRACustomBitmap;
299   subRect: TRect;
300   cw,ch: integer;
301   P: TPoint;
302 begin
303   cw := CanvasSource.Width;
304   ch := CanvasSource.Height;
305   if (x < 0) or (y < 0) or (x+Width > cw) or
306     (y+Height > ch) then
307   begin
308     FillTransparent;
309     if (x+Width <= 0) or (y+Height <= 0) or
310       (x >= cw) or (y >= ch) then
311       exit;
312 
313     if (x > 0) then subRect.Left := x else subRect.Left := 0;
314     if (y > 0) then subRect.Top := y else subRect.Top := 0;
315     if (x+Width > cw) then subRect.Right := cw else
316       subRect.Right := x+Width;
317     if (y+Height > ch) then subRect.Bottom := ch else
318       subRect.Bottom := y+Height;
319 
320     subBmp := NewBitmap(subRect.Right-subRect.Left,subRect.Bottom-subRect.Top);
321     subBmp.GetImageFromCanvas(CanvasSource,subRect.Left,subRect.Top);
322     PutImage(subRect.Left-x,subRect.Top-y,subBmp,dmSet);
323     subBmp.Free;
324     exit;
325   end;
326 
327   P := Point(x,y);
328   LPToDP(CanvasSource.Handle, P, 1);
329   gdk_pixbuf_get_from_drawable(FPixBuf,
330     TGtkDeviceContext(CanvasSource.Handle).Drawable,
331     nil, P.X,P.Y,0,0,Width,Height);
332   {$PUSH}{$WARNINGS OFF}If not TBGRAPixel_RGBAOrder then SwapRedBlue;{$POP}
333   InvalidateBitmap;
334 end;
335 
336 
337 end.
338 
339 
340