TBitmap with transparent pixels now saves in xpm format

git-svn-id: trunk@7554 -
2025-08-19 06:59:19 +02:00 · 2005-08-22 23:24:26 +00:00 · 2005-08-22 23:24:26 +00:00 · 49bbb18e35
commit 49bbb18e35
parent 7fc9aa2035
7 changed files with 86 additions and 17 deletions
--- a/lcl/graphtype.pp
+++ b/lcl/graphtype.pp
@ -171,16 +171,18 @@ procedure CreateRawImageLineStarts(Width, Height, BitsPerPixel: cardinal;
                                   LineEnd: TRawImageLineEnd;
                                   var LineStarts: PRawImagePosition);
 procedure CreateRawImageDescFromMask(SrcRawImageDesc,
-  DestRawImageDesc: PRawImageDescription);
+                                     DestRawImageDesc: PRawImageDescription);
 procedure GetRawImageXYPosition(RawImageDesc: PRawImageDescription;
                                LineStarts: PRawImagePosition; x, y: cardinal;
                                var Position: TRawImagePosition);
 procedure ExtractRawImageRect(SrcRawImage: PRawImage; const SrcRect: TRect;
                              DestRawImage: PRawImage);
 procedure ExtractRawImageDataRect(SrcRawImageDesc: PRawImageDescription;
-  const SrcRect: TRect; SrcData: Pointer;
-  DestRawImageDesc: PRawImageDescription;
-  var DestData: Pointer; var DestDataSize: cardinal);
+                             const SrcRect: TRect; SrcData: Pointer;
+                             DestRawImageDesc: PRawImageDescription;
+                             var DestData: Pointer; var DestDataSize: cardinal);
+function GetBytesPerLine(Width, BitsPerPixel: cardinal;
+                         LineEnd: TRawImageLineEnd): cardinal;
 function GetBitsPerLine(Width, BitsPerPixel: cardinal;
                        LineEnd: TRawImageLineEnd): cardinal;
 procedure ReadRawImageBits(TheData: PByte; const Position: TRawImagePosition;
@ -353,6 +355,7 @@ begin
      +' LineOrder='+RawImageLineOrderNames[LineOrder]
      +' ColorCount='+IntToStr(ColorCount)
      +' BitsPerPixel='+IntToStr(BitsPerPixel)
+      +' BytesPerLine='+IntToStr(GetBytesPerLine(Width,BitsPerPixel,LineEnd))
      +' LineEnd='+RawImageLineEndNames[LineEnd]
      +' RedPrec='+IntToStr(RedPrec)
      +' RedShift='+IntToStr(RedShift)
@ -367,6 +370,7 @@ begin
      +' AlphaLineEnd='+RawImageLineEndNames[AlphaLineEnd]
      +' AlphaBitOrder='+RawImageBitOrderNames[AlphaBitOrder]
      +' AlphaByteOrder='+RawImageByteOrderNames[AlphaByteOrder]
+      +' AlphaBytesPerLine='+IntToStr(GetBytesPerLine(Width,AlphaBitsPerPixel,AlphaLineEnd))
      +'';
  end;
 end;
@ -623,6 +627,12 @@ begin
  end;
 end;

+function GetBytesPerLine(Width, BitsPerPixel: cardinal;
+  LineEnd: TRawImageLineEnd): cardinal;
+begin
+  Result:=(GetBitsPerLine(Width,BitsPerPixel,LineEnd)+7) shr 3;
+end;
+
 function GetBitsPerLine(Width, BitsPerPixel: cardinal;
                        LineEnd: TRawImageLineEnd): cardinal;
 var
--- a/lcl/include/bitmap.inc
+++ b/lcl/include/bitmap.inc
@ -592,7 +592,7 @@ end;

 procedure TBitmap.WriteStream(Stream: TStream; WriteSize: Boolean);
 begin
-  WriteStreamWithFPImage(Stream,WriteSize,TFPWriterBMP);
+  WriteStreamWithFPImage(Stream,WriteSize,nil);
 end;

 procedure TBitmap.StoreOriginalStream(Stream: TStream; Size: integer);
@ -731,6 +731,7 @@ var
  MemStream: TMemoryStream;
  IntfImg: TLazIntfImage;
  ImgWriter: TFPCustomImageWriter;
+  RawImage: TRawImage;
 begin
  //DebugLn('WriteStreamWithFPImage Self=',DbgS(Self),' ',Width,',',Height,' Using SaveStream=',(FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0));
  if (FImage.SaveStream<>nil) and (FImage.SaveStream.Size>0)
@ -751,6 +752,27 @@ begin
  try
    IntfImg:=TLazIntfImage.Create(0,0);
    IntfImg.LoadFromBitmap(Handle,0);
+    
+    if WriterClass=nil then begin
+      // automatically use a TFPCustomImageWriterClass
+      // .bmp does not support transparency
+      // Delphi uses a trick and stores the transparent color in the bottom, left
+      // pixel. This changes the bitmap and requires to know the transparency
+      // on load.
+      // The LCL TBitmap is able to load .xpm and .bmp images. .xpm supports
+      // transparency. So, if the images has transparency use .xpm.
+      IntfImg.GetRawImage(RawImage);
+      if RawImageMaskIsEmpty(@RawImage,true) then
+        WriterClass:=TFPWriterBMP
+      else
+        WriterClass:=TLazWriterXPM;
+      //debugln('WriteStreamWithFPImage WriterClass=',WriterClass.ClassName,' ',RawImageDescriptionAsString(@RawImage),' MaskSize=',dbgs(RawImage.MaskSize));
+      //debugln(dbgMemRange(RawImage.Mask,RawImage.MaskSize,
+      //                    GetBytesPerLine(RawImage.Description.Width,
+      //                                   RawImage.Description.AlphaBitsPerPixel,
+      //                                   RawImage.Description.AlphaLineEnd)));
+    end;
+
    ImgWriter:=WriterClass.Create;
    InitFPImageWriter(ImgWriter);
    IntfImg.SaveToStream(MemStream,ImgWriter);
--- a/lcl/include/speedbutton.inc
+++ b/lcl/include/speedbutton.inc
@ -407,6 +407,7 @@ begin
  if FLastDrawFlags <> 0 then
    DrawFrameControl(Canvas.GetUpdatedHandle([csBrushValid,csPenValid]),
      PaintRect, DFC_BUTTON, FLastDrawFlags);
+
  //writeln('TCustomSpeedButton.Paint ',Name,':',ClassName,' Parent.Name=',Parent.Name,
  //  ' DFCS_BUTTONPUSH=',FLastDrawFlags and DFCS_BUTTONPUSH,
  //  ' DFCS_PUSHED=',FLastDrawFlags and DFCS_PUSHED,
--- a/lcl/interfaces/gtk/gtkobject.inc
+++ b/lcl/interfaces/gtk/gtkobject.inc
@ -2305,7 +2305,7 @@ begin
  end;
  // AlphaBitsPerPixel and AlphaLineEnd
  Desc^.AlphaBitsPerPixel:=Desc^.AlphaPrec;
-  Desc^.AlphaLineEnd:=rileByteBoundary; //TODO: MWE: check if alpha ending is the same as normal ending
+  Desc^.AlphaLineEnd:=rileByteBoundary;// gdk_bitmap_create_from_data in CreateBitmapFromRawImage expects rileByteBoundary
  Desc^.AlphaBitOrder:=riboBitsInOrder;
  Desc^.AlphaByteOrder:=riboLSBFirst;

@ -2440,6 +2440,7 @@ function TGTKWidgetSet.GetRawImageMaskFromGdkBitmap(MaskBitmap: PGdkBitmap;
 var
  Width, Height: cardinal;
  AnImage: PGdkImage;
+  BytesPerLine: Integer;
 begin
  Result:=false;

@ -2469,17 +2470,26 @@ begin
    {$ENDIF}
  
    // See also GetWindowRawImageDescription
-//    RawImage.Description.AlphaLineEnd:=rileDWordBoundary;
-    case AnImage^.Depth of
+    RawImage.Description.AlphaLineEnd:=rileDWordBoundary;// gdk_image_get uses rileDWordBoundary
+    {case AnImage^.Depth of
    0..8:   RawImage.Description.AlphaLineEnd:=rileByteBoundary;
-    9..32:  RawImage.Description.AlphaLineEnd:=rileDWordBoundary; //TODO MWE: Isn't there a word boundary (9..16) ?
+    9..32:  RawImage.Description.AlphaLineEnd:=rileDWordBoundary;// X does not seem to use Word boundaries
    else    RawImage.Description.AlphaLineEnd:=rileQWordBoundary;
-    end;
+    end;}
    RawImage.Description.AlphaBitsPerPixel:=AnImage^.bpp;

    // consistency checks
    if RawImage.Description.AlphaBitsPerPixel<>AnImage^.Depth then
      RaiseGDBException('RawImage.Description.AlphaBitsPerPixel<>AnImage^.Depth '+IntToStr(RawImage.Description.AlphaBitsPerPixel)+'<>'+IntToStr(AnImage^.Depth));
+    BytesPerLine:=GetBytesPerLine(RawImage.Description.Width,
+                   RawImage.Description.AlphaBitsPerPixel,
+                   RawImage.Description.AlphaLineEnd);
+    if BytesPerLine<>AnImage^.bpl then
+      RaiseGDBException('AnImage^.bpl<>BytesPerLine '+IntToStr(AnImage^.bpl)+'<>'+IntToStr(BytesPerLine));
+    if AnImage^.Height<>RawImage.Description.Height then
+      RaiseGDBException('AnImage^.Height<>RawImage.Description.Height '+IntToStr(AnImage^.Height)+'<>'+IntToStr(RawImage.Description.Height));
+    if AnImage^.Width<>RawImage.Description.Width then
+      RaiseGDBException('AnImage^.Width<>RawImage.Description.Width '+IntToStr(AnImage^.Width)+'<>'+IntToStr(RawImage.Description.Width));

    RawImage.MaskSize:=AnImage^.bpl * AnImage^.Height;
    {$IFDEF VerboseRawImage}
@ -2493,6 +2503,10 @@ begin
    ReAllocMem(RawImage.Mask,RawImage.MaskSize);
    if RawImage.MaskSize>0 then
      System.Move(AnImage^.Mem^,RawImage.Mask^,RawImage.MaskSize);
+    //debugln(dbgMemRange(RawImage.Mask,RawImage.MaskSize,
+    //                    GetBytesPerLine(RawImage.Description.Width,
+    //                                     RawImage.Description.AlphaBitsPerPixel,
+    //                                     RawImage.Description.AlphaLineEnd)));

    {$IFDEF VerboseRawImage}
    DebugLn('TGtkWidgetSet.GetRawImageMaskFromGdkBitmap H ',
--- a/lcl/interfaces/gtk/gtkwinapi.inc
+++ b/lcl/interfaces/gtk/gtkwinapi.inc
@ -1037,6 +1037,7 @@ begin
      {$IFDEF VerboseRawImage}
      DebugLn('TGtkWidgetSet.CreateBitmapFromRawImage creating mask .. ');
      {$ENDIF}
+      // gdk_bitmap_create_from_data expects rileByteBoundary
      GdiObject^.GDIBitmapMaskObject :=
          gdk_bitmap_create_from_data(DefGdkWindow,PGChar(RawImage.Mask),
                       RawImage.Description.Width, RawImage.Description.Height);
--- a/lcl/intfgraphics.pas
+++ b/lcl/intfgraphics.pas
@ -186,7 +186,7 @@ type
    procedure CreateBitmap(var Bitmap, MaskBitmap: HBitmap;
                           AlwaysCreateMask: boolean); virtual;
    procedure SetRawImage(const RawImage: TRawImage); virtual;
-    procedure GetRawImage(var RawImage: TRawImage); virtual;
+    procedure GetRawImage(out RawImage: TRawImage); virtual;
    procedure FillPixels(const Color: TFPColor); virtual;
    procedure GetXYDataPostion(x, y: integer; var Position: TRawImagePosition);
    procedure GetXYMaskPostion(x, y: integer; var Position: TRawImagePosition);
@ -1713,7 +1713,7 @@ begin
  end;
 end;

-procedure TLazIntfImage.GetRawImage(var RawImage: TRawImage);
+procedure TLazIntfImage.GetRawImage(out RawImage: TRawImage);
 begin
  FillChar(RawImage,SizeOf(TRawImage),0);
  RawImage.Description:=FDataDescription;
--- a/lcl/lclproc.pas
+++ b/lcl/lclproc.pas
@ -156,7 +156,7 @@ function DbgS(const b: boolean): string;
 function DbgSName(const p: TObject): string;
 function DbgSName(const p: TClass): string;
 function DbgStr(const StringWithSpecialChars: string): string;
-function dbgMemRange(P: PByte; Count: integer): string;
+function dbgMemRange(P: PByte; Count: integer; Width: integer = 0): string;
 function dbgMemStream(MemStream: TCustomMemoryStream; Count: integer): string;
 function dbgObjMem(AnObject: TObject): string;

@ -1138,18 +1138,39 @@ begin
  end;
 end;

-function dbgMemRange(P: PByte; Count: integer): string;
+function dbgMemRange(P: PByte; Count: integer; Width: integer): string;
 const
  HexChars: array[0..15] of char = '0123456789ABCDEF';
+  LineEnd: shortstring = LineEnding;
 var
  i: Integer;
+  NewLen: Integer;
+  Dest: PChar;
+  Col: Integer;
+  j: Integer;
 begin
  Result:='';
  if (p=nil) or (Count<=0) then exit;
-  SetLength(Result,Count*2);
+  NewLen:=Count*2;
+  if Width>0 then begin
+    inc(NewLen,(Count div Width)*length(LineEnd));
+  end;
+  SetLength(Result,NewLen);
+  Dest:=PChar(Result);
+  Col:=1;
  for i:=0 to Count-1 do begin
-    Result[i*2+1]:=HexChars[PByte(P)[i] shr 4];
-    Result[i*2+2]:=HexChars[PByte(P)[i] and $f];
+    Dest^:=HexChars[PByte(P)[i] shr 4];
+    inc(Dest);
+    Dest^:=HexChars[PByte(P)[i] and $f];
+    inc(Dest);
+    inc(Col);
+    if (Width>0) and (Col>Width) then begin
+      Col:=1;
+      for j:=1 to length(LineEnd) do begin
+        Dest^:=LineEnd[j];
+        inc(Dest);
+      end;
+    end;
  end;
 end;