made TIcon more independent of TBitmap from Colin

git-svn-id: trunk@5404 -

lcl/graphics.pp

@@ -38,7 +38,7 @@ interface
 
 
 uses
-  SysUtils, Classes, FPCAdds,
+  SysUtils, Classes, Contnrs, FPCAdds,
   {$IFNDEF DisableFPImage}
   FPImage, FPReadPNG, FPWritePNG, FPReadBMP, FPWriteBMP, IntfGraphics,
   {$ENDIF}
@@ -998,9 +998,6 @@ type
     procedure WriteData(Stream: TStream); override;
     procedure StoreOriginalStream(Stream: TStream; Size: integer); virtual;
     {$IFNDEF DisableFPImage}
-    procedure ReadStreamWithFPImage(Stream: TStream; UseSize: boolean;
-                               Size: Longint;
-                               ReaderClass: TFPCustomImageReaderClass); virtual;
     procedure WriteStreamWithFPImage(Stream: TStream; WriteSize: boolean;
                                WriterClass: TFPCustomImageWriterClass); virtual;
     procedure InitFPImageReader(ImgReader: TFPCustomImageReader); virtual;
@@ -1041,6 +1038,9 @@ type
       const FileExtension: string): TFPCustomImageWriterClass; override;
     class function GetDefaultFPReader: TFPCustomImageReaderClass; override;
     class function GetDefaultFPWriter: TFPCustomImageWriterClass; override;
+    procedure ReadStreamWithFPImage(Stream: TStream; UseSize: boolean;
+                               Size: Longint;
+                               ReaderClass: TFPCustomImageReaderClass); virtual;
     procedure WriteNativeStream(Stream: TStream; WriteSize: Boolean;
       SaveStreamType: TBitmapNativeType); virtual;
     {$ENDIF}
@@ -1110,11 +1110,25 @@ type
   { TIcon }
   {
     TIcon reads and writes .ICO file format.
-    ! Currently it is almost a TBitmap !
+    A .ico file typically contains several versions of the same image. When loading,
+    the largest/most colourful image is loaded as the TBitmap and so can be handled
+    as any other bitmap. Any other versions of the images are available via the
+    Bitmaps property
+    Writing is not (yet) implemented.
   }
   TIcon = class(TBitmap)
+  {$IFNDEF DisableFPImage}
+  private
+    FBitmaps: TObjectList;
   protected
     procedure ReadData(Stream: TStream); override;
+    procedure InitFPImageReader(ImgReader: TFPCustomImageReader); override;
+  public
+    class function GetFileExtensions: string; override;
+    property Bitmaps: TObjectList read FBitmaps;
+    destructor Destroy; override;
+    procedure AddBitmap(Bitmap: TBitmap); { Note that Ownership passes to TIcon }
+  {$ENDIF}
   end;
 
 
@@ -1588,6 +1602,11 @@ end;
 
 { TIcon }
 
+{$IFNDEF DisableFPImage}
+
+const
+  IconSignature: array [0..3] of char = #0#0#1#0;
+  
 function TestStreamIsIcon(const AStream: TStream): boolean;
 var
   Signature: array[0..3] of char;
@@ -1596,7 +1615,7 @@ var
 begin
   OldPosition:=AStream.Position;
   ReadSize:=AStream.Read(Signature, SizeOf(Signature));
-  Result:=(ReadSize=SizeOf(Signature)) and (Signature=#0#0#1#0);
+  Result:=(ReadSize=SizeOf(Signature)) and CompareMem(@Signature,@IconSignature,4);
   AStream.Position:=OldPosition;
 end;
 
@@ -1606,8 +1625,8 @@ var
   Position: TStreamSeekType;
 begin
   Position := Stream.Position;
-  Stream.Read(Size, SizeOf(Size));
+  Stream.Read(Size, 4); // Beware BigEndian and LowEndian sytems
-  if Size = $10000 then begin // Icon starts 00 00 01 00
+  if CompareMem(@Size,@IconSignature,4) then begin
     // Assume Icon - stream without explicit size
     Stream.Position := Position;
     ReadStream(Stream, false, Size);
@@ -1615,6 +1634,32 @@ begin
     ReadStream(Stream, true, Size);
 end;
 
+procedure TIcon.InitFPImageReader(ImgReader: TFPCustomImageReader);
+begin
+  inherited InitFPImageReader(ImgReader);
+  if ImgReader is TLazReaderIcon then
+    TLazReaderIcon(ImgReader).Icon := self;
+end;
+
+function TIcon.GetFileExtensions: string;
+begin
+  Result:='ico';
+end;
+
+destructor TIcon.Destroy;
+begin
+  inherited Destroy;
+  FreeAndNil(FBitmaps);
+end;
+
+procedure TIcon.AddBitmap(Bitmap: TBitmap);
+begin
+  if not Assigned(FBitmaps) then
+    FBitmaps := TObjectList.create(True);
+  FBitmaps.Add(Bitmap);
+end;
+{$ENDIF}
+
 initialization
   PicClipboardFormats:=nil;
   PicFileFormats:=nil;
@@ -1636,6 +1681,9 @@ end.
 { =============================================================================
 
   $Log$
+  Revision 1.134  2004/04/12 22:36:29  mattias
+  made TIcon more independent of TBitmap  from Colin
+
   Revision 1.133  2004/04/10 14:20:20  mattias
   fixed saving findtext  from vincent
 

lcl/include/picture.inc

@@ -50,9 +50,7 @@ begin
   {$IFNDEF DisableFPImage}
   Add('png', 'Portable Network Graphic', TPortableNetworkGraphic);
   {$ENDIF}
-  {$IFDEF HasIconGraphic}
   Add('ico', 'Icon', TIcon);
-  {$ENDIF}
 end;
 
 procedure TPicFileFormatsList.Clear;

lcl/interfaces/gtk/gtkwinapi.inc

@@ -3105,9 +3105,8 @@ var
   UnRef : Boolean;
   DCOrigin: TPoint;
   UnderLine: boolean;
-
+  buffer: PGdkDrawable;
-  buffer : PGdkPixmap;
+  buffered: Boolean;
-  buffered : boolean;
 
   procedure DrawTextLine;
   var
@@ -3202,25 +3201,12 @@ begin
         end;
       end;
 
-      //If we don't have double buffering, try and buffer each block of text,
-      //otherwise most text "flashes" by disapearing and then redrawing on account
-      //of the two passes, first one to draw bg and then another to draw fg.
-
-      //By doing it this way the "constant" flashing is replaced by more occasional
-      //flashing, and is primarily restricted to the larger blocks of text. Far
-      //more pleasant to work with, especially in the Lazarus Source Editor where
-      //each keyword, string, etc is its own block drawn individually, thus is
-      //constantly flashing during code changes, resizing,  scrolling, etc.
       if ((Options and ETO_OPAQUE) <> 0) then
       begin
         Width := Rect^.Right - Rect^.Left;
         Height := Rect^.Bottom - Rect^.Top;
         SelectedColors := dcscCustom;
         EnsureGCColor(DC, dccCurrentBackColor, True, False);
-        {$IFDEF EnableDoubleBuf}
-        buffered := True;
-        buffer := gdk_pixmap_new(Drawable, Width, Height, -1);
-        {$ENDIF}
         if buffered then begin
           Left:=0;
           Top:=0;
@@ -3285,13 +3271,6 @@ begin
           {$ENDIF}
         end;
       end;
-      if buffered then begin
-        BeginGDKErrorTrap;
-        gdk_draw_pixmap(drawable, gc, buffer, 0,0, Rect^.Left+DCOrigin.X,
-          Rect^.Top+DCOrigin.Y, Width, Height);
-        gdk_pixmap_unref(buffer);
-        EndGDKErrorTrap;
-      end;
     end;
   end;
   Assert(False, Format('trace:< [TGtkWidgetSet.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count]));
@@ -8715,6 +8694,9 @@ end;
 { =============================================================================
 
   $Log$
+  Revision 1.346  2004/04/12 22:36:29  mattias
+  made TIcon more independent of TBitmap  from Colin
+
   Revision 1.345  2004/04/03 16:47:46  mattias
   implemented converting gdkbitmap to RawImage mask
 

lcl/intfgraphics.pas

@@ -128,6 +128,7 @@ type
     FAlphaReadRawImageBits: TOnReadRawImageBits;
     FAlphaWriteRawImageBits: TOnWriteRawImageBits;
     procedure SetAutoCreateMask(const AValue: boolean);
+    procedure SetUsePalette (Value:boolean);override;
   protected
     OnGetInternalColor: TOnGetLazIntfImagePixel;
     OnSetInternalColor: TOnSetLazIntfImagePixel;
@@ -334,6 +335,7 @@ type
       ReadPalette: Boolean); virtual;
     procedure ReadScanLine(Row: Integer; Stream: TStream); virtual;
     procedure WriteScanLine(Row: Integer; Img: TFPCustomImage); virtual;
+    function BmpRGBAToFPColor(Const RGBA: TColorRGBA): TFPcolor; virtual;
     // required by TFPCustomImageReader
     procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
     procedure InternalReadBody(Stream: TStream; Img: TFPCustomImage);
@@ -343,16 +345,30 @@ type
     destructor Destroy; override;
   end;
 
-  { TLazReaderIcon }
+  { TLazReaderPartIcon }
-  { This is a FPImage writer for icon images. }
+  { This is a FPImage writer for a single icon from an icon file }
-  TLazReaderIcon = class (TLazReaderBMP)
+  TLazReaderPartIcon = class (TLazReaderBMP)
-    private
-      FnIcons: Integer;
-      FnStartPos: TStreamSeekType;
   protected
     // required by TFPCustomImageReader
     procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
     function  InternalCheck(Stream: TStream) : boolean; override;
+    function BmpRGBAToFPColor(Const RGBA: TColorRGBA): TFPcolor; override;
+  end;
+
+  { TLazReaderIcon }
+  { This is a FPImage writer for icon images. }
+  TLazReaderIcon = class (TLazReaderPartIcon)
+  private
+    FIcon: TObject; { Actually TIcon, but this would give rise to a circular reference }
+    FnIcons: Integer;
+    FnStartPos: TStreamSeekType;
+    procedure SetIcon(const AValue: TObject);
+  protected
+    // required by TFPCustomImageReader
+    procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
+    function  InternalCheck(Stream: TStream) : boolean; override;
+  public
+    property Icon: TObject read FIcon write SetIcon;
   end;
 
 function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string;
@@ -361,6 +377,8 @@ procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
 
 implementation
 
+uses Graphics;
+
 var
   IsSpaceChar, IsNumberChar, IsHexNumberChar: array[char] of Boolean;
 
@@ -1374,6 +1392,11 @@ begin
     FreeMaskData;
 end;
 
+procedure TLazIntfImage.SetUsePalette(Value: boolean);
+begin
+  inherited SetUsePalette(False);  // Can't handle palettes at the moment
+end;
+
 procedure TLazIntfImage.SetInternalColor(x, y: integer; const Value: TFPColor);
 begin
   {if (x=0) and (y=0) then begin
@@ -2870,34 +2893,19 @@ end;
 
 { TLazReaderBMP }
 
-type
+function TLazReaderBMP.BmpRGBAToFPColor(Const RGBA: TColorRGBA): TFPcolor;
-  TColorBmpRGB=packed record
-    B,G,R: Byte;
-  end;
-  PColorBmpRGB = ^TColorBmpRGB;
-
-  TColorBmpRGBA=packed record
-  case Boolean of
-    False:(B,G,R,A: Byte);
-    True:(RGB: TColorBmpRGB);
-  end;
-  PColorBmpRGBA = ^TColorBmpRGBA;
-
-function BmpRGBAToFPColor(Const RGBA: TColorBmpRGBA): TFPcolor;
-var
-  NewAlpha: Byte;
 begin
   with Result, RGBA do
     begin
     Red   :=(R shl 8) or R;
     Green :=(G shl 8) or G;
     Blue  :=(B shl 8) or B;
-    NewAlpha:=255-A;
+    // Specification for bitmap files has these bits always zero - unused
-    alpha :=(NewAlpha shl 8) or NewAlpha;
+    alpha := alphaOpaque;
     end;
 end;
 
-Function BmpRGBToFPColor(Const RGB: TColorBmpRGB) : TFPColor;
+Function BmpRGBToFPColor(Const RGB: TColorRGB) : TFPColor;
 begin
   with Result,RGB do
     begin
@@ -2941,48 +2949,55 @@ procedure TLazReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream: TStream;
   ReadPalette: Boolean);
 {$ifdef VER1_0}
 type
-  tcolinfo = ARRAY [0..0] OF TColorBmpRGBA;
+  tcolinfo = ARRAY [0..0] OF TColorRGBA;
   pcolinfo = ^tcolinfo;
 var
   ColInfo: pcolinfo;
 {$else}
 var
-  ColInfo: ARRAY OF TColorBmpRGBA;
+  ColInfo: ARRAY OF TColorRGBA;
 {$endif}
   i: Integer;
+  FPcolor: TFPcolor;
 begin
   if nPalette>0 then
     begin
     GetMem(FPalette, nPalette*SizeOf(TFPColor));
     {$ifdef VER1_0}
-    GetMem(ColInfo, nPalette*Sizeof(TColorBmpRGBA));
+    GetMem(ColInfo, nPalette*Sizeof(TColorRGBA));
     if ReadPalette then begin
       if BFI.biClrUsed>0 then
-        Stream.Read(ColInfo^[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
+        Stream.Read(ColInfo^[0],BFI.biClrUsed*SizeOf(TColorRGBA))
       else // Seems to me that this is dangerous.
-        Stream.Read(ColInfo^[0],nPalette*SizeOf(TColorBmpRGBA));
+        Stream.Read(ColInfo^[0],nPalette*SizeOf(TColorRGBA));
-      for i := 0 to nPalette-1 do
+      for i := 0 to nPalette-1 do begin
-        FPalette[i] := BmpRGBAToFPColor(ColInfo^[i]);
+        FPcolor := BmpRGBAToFPColor(ColInfo^[i]);
+        FPcolor.alpha := alphaOpaque; { No transparency info in palette }
+        FPalette[i] := FPcolor;
+      end;
     end;
     {$else}
     SetLength(ColInfo, nPalette);
     if ReadPalette then begin
       if BFI.biClrUsed>0 then
-        Stream.Read(ColInfo[0],BFI.biClrUsed*SizeOf(TColorBmpRGBA))
+        Stream.Read(ColInfo[0],BFI.biClrUsed*SizeOf(TColorRGBA))
       else // Seems to me that this is dangerous.
-        Stream.Read(ColInfo[0],nPalette*SizeOf(TColorBmpRGBA));
+        Stream.Read(ColInfo[0],nPalette*SizeOf(TColorRGBA));
-      for i := 0 to High(ColInfo) do
+      for i := 0 to nPalette-1 do begin
-        FPalette[i] := BmpRGBAToFPColor(ColInfo[i]);
+        FPcolor := BmpRGBAToFPColor(ColInfo[i]);
+        FPcolor.alpha := alphaOpaque; { No transparency info in palette }
+        FPalette[i] := FPcolor;
+      end;
     end;
     {$endif}
     end
   else if BFI.biClrUsed>0 then { Skip palette }
     Stream.Position := Stream.Position
-                      + TStreamSeekType(BFI.biClrUsed*SizeOf(TColorBmpRGBA));
+                      + TStreamSeekType(BFI.biClrUsed*SizeOf(TColorRGBA));
   ReadSize:=((nRowBits + 31) div 32) shl 2;
   GetMem(LineBuf,ReadSize);
   {$ifdef VER1_0}
-  FreeMem(ColInfo, nPalette*Sizeof(TColorBmpRGBA));
+  FreeMem(ColInfo, nPalette*Sizeof(TColorRGBA));
   {$endif}
 end;
 
@@ -3016,10 +3031,10 @@ begin
         img.colors[Column,Row]:=Bmp16BitToFPColor(PWord(LineBuf)[Column]);
    24 :
       for Column:=0 to img.Width-1 do
-        img.colors[Column,Row]:=BmpRGBToFPColor(PColorBmpRGB(LineBuf)[Column]);
+        img.colors[Column,Row]:=BmpRGBToFPColor(PColorRGB(LineBuf)[Column]);
    32 :
       for Column:=0 to img.Width-1 do
-        img.colors[Column,Row]:=BmpRGBAToFPColor(PColorBmpRGBA(LineBuf)[Column]);
+        img.colors[Column,Row]:=BmpRGBAToFPColor(PColorRGBA(LineBuf)[Column]);
     end;
 end;
 
@@ -3034,7 +3049,7 @@ Var
   Row : Integer;
 begin
   { This will move past any junk after the BFI header }
-  Stream.Position:=Stream.Position-TStreamSeekType(SizeOf(BFI)-BFI.biSize);
+  Stream.Position:=Stream.Position+TStreamSeekType(BFI.biSize-SizeOf(BFI));
   with BFI do
     begin
     if (biCompression<>0) then
@@ -3138,6 +3153,43 @@ begin
   end;
 end;
 
+{ TLazReaderPartIcon }
+
+procedure TLazReaderPartIcon.InternalRead(Stream: TStream; Img: TFPCustomImage);
+var
+  Row, Column: Integer;
+begin
+  Stream.Read(BFI,SizeOf(BFI));
+  BFI.biHeight := BFI.biHeight div 2; { Height field is doubled, to (sort of) accomodate mask }
+  InternalReadBody(Stream, Img); { Now read standard bitmap }
+  { Mask immediately follows unless bitmap was 32 bit - monchrome bitmap with no header }
+  if BFI.biBitCount < 32 then begin
+    ReadSize:=((Img.Width + 31) div 32) shl 2;
+    SetupRead(2,Img.Width,Stream,False);
+    try
+      for Row:=Img.Height-1 downto 0 do begin
+        ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
+        for Column:=0 to Img.Width-1 do
+          if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
+            img.colors[Column,Row]:=colTransparent
+      end;
+    finally
+      FreeBufs;
+    end;
+  end;
+end;
+
+function TLazReaderPartIcon.InternalCheck(Stream: TStream): boolean;
+begin
+  Result:=True; { Assumes stream in the correct place }
+end;
+
+function TLazReaderPartIcon.BmpRGBAToFPColor(const RGBA: TColorRGBA): TFPcolor;
+begin
+  Result:=inherited BmpRGBAToFPColor(RGBA);
+  Result.alpha := (RGBA.A shl 8) or RGBA.A; { For icon files (only) upper byte is used for transparency }
+end;
+
 { TLazReaderIcon }
 
 type
@@ -3159,44 +3211,62 @@ type
     dwImageOffset: Longint;  {pos of image as offset from the beginning of file}
   end;
   
+  PIconDirEntry = ^TIconDirEntry;
+
+procedure TLazReaderIcon.SetIcon(const AValue: TObject);
+begin
+  if AValue is TIcon then
+    FIcon:=AValue;
+end;
+
 procedure TLazReaderIcon.InternalRead(Stream: TStream; Img: TFPCustomImage);
 var
-  CurrentDirEntry, BestDirEntry: TIconDirEntry;
+  CurrentDirEntry, BestDirEntry, IconDir: PIconDirEntry;
-  Row, Column, i: Integer;
+  i: Integer;
+  Bitmap: TBitmap;
 begin
-  { For the time being, read the largest and/or most colourful icon }
+  GetMem(IconDir, FnIcons*Sizeof(TIconDirEntry));
-  Stream.Read(BestDirEntry, Sizeof(BestDirEntry));
-  CurrentDirEntry := BestDirEntry;
-  for i := 2 to FnIcons do begin
-    Stream.Read(CurrentDirEntry, Sizeof(CurrentDirEntry));
-    if ((CurrentDirEntry.bWidth > BestDirEntry.bWidth)
-         and (CurrentDirEntry.bHeight > BestDirEntry.bHeight))
-       or ((CurrentDirEntry.bWidth = BestDirEntry.bWidth)
-           and (CurrentDirEntry.bHeight = BestDirEntry.bHeight)
-           and (CurrentDirEntry.dwBytesInRes > BestDirEntry.dwBytesInRes)) then
-      BestDirEntry := CurrentDirEntry;
-  end;
-  Stream.Position := FnStartPos + BestDirEntry.dwImageOffset;
-  Stream.Read(BFI,SizeOf(BFI));
-  BFI.biHeight := BFI.biHeight div 2; { Height field is doubled, to (sort of) accomodate mask }
-  InternalReadBody(Stream, Img); { Now read standard bitmap }
-  { Mask immediately follows unless bitmap was 32 bit - monchrome bitmap with no header }
-  if BFI.biBitCount < 32 then begin
-    ReadSize:=((Img.Width + 31) div 32) shl 2;
-    SetupRead(2,Img.Width,Stream,False);
   try
-      for Row:=Img.Height-1 downto 0 do begin
+    Stream.Read(IconDir^, FnIcons*Sizeof(TIconDirEntry));
-        ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
+    BestDirEntry := IconDir;
-        for Column:=0 to Img.Width-1 do
+    CurrentDirEntry := IconDir+1;
-          if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
+    { First locate largest and/or most colourful icon as the default image }
-            img.colors[Column,Row]:=colTransparent
+    for i := 2 to FnIcons do begin
+      if ((CurrentDirEntry^.bWidth > BestDirEntry^.bWidth)
+           and (CurrentDirEntry^.bHeight > BestDirEntry^.bHeight))
+         or ((CurrentDirEntry^.bWidth = BestDirEntry^.bWidth)
+             and (CurrentDirEntry^.bHeight = BestDirEntry^.bHeight)
+             and (CurrentDirEntry^.dwBytesInRes > BestDirEntry^.dwBytesInRes)) then
+        BestDirEntry := CurrentDirEntry;
+      Inc(CurrentDirEntry);
+    end;
+    if Assigned(Icon) then begin
+      CurrentDirEntry := IconDir;
+      for i := 1 to FnIcons do begin
+        Stream.Position := FnStartPos + CurrentDirEntry^.dwImageOffset;
+        if CurrentDirEntry = BestDirEntry then
+         inherited InternalRead(Stream, Img)
+        else begin
+          Bitmap := TBitmap.Create;
+          try
+            Bitmap.ReadStreamWithFPImage(Stream, False, 0, TLazReaderPartIcon);
+          except
+            Bitmap.Free;
+            raise;
+          end;
+          TIcon(Icon).AddBitmap(Bitmap);
+        end;
+        Inc(CurrentDirEntry);
+      end;
+    end else begin
+      Stream.Position := FnStartPos + BestDirEntry^.dwImageOffset;
+      inherited InternalRead(Stream, Img);
+      { Finally skip remaining icons }
+      Stream.Position := FnStartPos + CurrentDirEntry^.dwImageOffset + CurrentDirEntry^.dwBytesInRes;
     end;
   finally
-      FreeBufs;
+    FreeMem(IconDir);
   end;
-  end;
-  { Finally skip remaining icons }
-  Stream.Position := FnStartPos + BestDirEntry.dwImageOffset + BestDirEntry.dwBytesInRes;
 end;
 
 function TLazReaderIcon.InternalCheck(Stream: TStream): boolean;