* Patches from Giulio BERNA

- BMP Reader enhanced to full Microsoft specs:
    + support for 15,16 bit bitmaps. 
    + support for strange color masks at 16, 32 bpp
    + rle4 and rle8 decoding
    + top-down stored bitmaps.
    + Palette behaviour changed: use palette at 1,4,8 bits.
    + Support for OnProgress
  - BMP Writer support:
    + BitsPerPixel property.
    + Writing at all color depths.
    + RLE8 and RLE4 compression.
  - Functions to create standard palettes:
    CreateBlackAndWhitePalette
    CreateWebSafePalette 
    CreateGrayScalePalette
    CreateVGAPalette

git-svn-id: trunk@987 -

fcl/image/bmpcomn.pp

@@ -21,6 +21,15 @@ interface
 const
 {BMP magic word is always 19778 : 'BM'}
   BMmagic=19778;
+
+{ Values for Compression field }
+  BI_RGB = 0;
+  BI_RLE8 = 1;
+  BI_RLE4 = 2;
+  BI_BITFIELDS = 3;
+  BI_JPEG = 4;
+  BI_PNG = 5;
+
 type
 
    TBitMapFileHeader = packed record
@@ -30,7 +39,7 @@ type
       bfSize:longint;
 {06+04 : Reserved}
       bfReserved:longint;
-{10+04 : Offset of image data : size if the file hieder + the info header}
+{10+04 : Offset of image data : size if the file hieder + the info header + palette}
       bfOffset:longint;
    end;
    PBitMapFileHeader = ^TBitMapFileHeader;
@@ -44,17 +53,17 @@ type
       Height:longint;
 {26+02 : Number of image planes : should be 1 always}
       Planes:word;
-{28+02 : Color resolution : Number of bits per pixel (1,4,8,24)}
+{28+02 : Color resolution : Number of bits per pixel (1,4,8,16,24,32)}
       BitCount:word;
 {30+04 : Compression Type}
       Compression:longint;
-{34+04 : Size of compressed image : should be 0 if no compression}
+{34+04 : Size of image data (not headers nor palette): can be 0 if no compression}
       SizeImage:longint;
 {38+04 : Horizontal resolution in pixel/meter}
       XPelsPerMeter:Longint;
 {42+04 : Vertical resolution in pixel/meter}
       YPelsPerMeter:Longint;
-{46+04 : Number of coros used}
+{46+04 : Number of colors used}
       ClrUsed:longint;
 {50+04 : Number of imprtant colors used : usefull for displaying on VGA256}
       ClrImportant:longint;

fcl/image/fpimage.pp

@@ -332,6 +332,11 @@ const
   GCM_Mathematical : TGrayConvMatrix = (red:0.334; green:0.333; blue:0.333);
   GCM_Photoshop : TGrayConvMatrix = (red:0.213; green:0.715; blue:0.072);
 
+function CreateBlackAndWhitePalette : TFPPalette;
+function CreateWebSafePalette : TFPPalette;
+function CreateGrayScalePalette : TFPPalette;
+function CreateVGAPalette : TFPPalette;
+
 implementation
 
 procedure FPImgError (Fmt:TErrorTextIndices; data : array of const);

fcl/image/fppalette.inc

@@ -148,3 +148,94 @@ procedure TFPPalette.Clear;
 begin
   SetCount (0);
 end;
+
+
+{ Functions to create standard palettes, by Giulio Bernardi 2005 }
+
+{ A simple 1 bit black and white palette }
+function CreateBlackAndWhitePalette : TFPPalette;
+var fppal : TFPPalette;
+    Col : TFPColor;
+begin
+  fppal:=TFPPalette.Create(2);
+  Col.Alpha:=AlphaOpaque;
+  Col.Red:=$FFFF; Col.Green:=$FFFF; Col.Blue:=$FFFF;
+  fppal.Color[0]:=Col;
+  Col.Red:=$0000; Col.Green:=$0000; Col.Blue:=$0000;
+  fppal.Color[1]:=Col;
+  Result:=fppal;
+end;
+
+{ The "standard" netscape 216-color palette (aka: web safe palette) }
+function CreateWebSafePalette : TFPPalette;
+var Col : TFPColor;
+    i : integer;
+    fppal : TFPPalette;
+begin
+  fppal:=TFPPalette.Create(216);
+  Col.Alpha:=AlphaOpaque;
+  i:=0;
+  Col.Red:=$FFFF;
+  while true do
+  begin
+    Col.Green:=$FFFF;
+    while true do
+    begin
+      Col.Blue:=$FFFF;
+      while true do
+      begin
+        fppal.Color[i]:=Col;
+        if Col.Blue=0 then break;
+        dec(Col.Blue,$3333);
+      end;
+      if Col.Green=0 then break;
+      dec(Col.Green,$3333);
+    end;
+    if Col.Red=0 then break;
+    dec(Col.Red,$3333);
+  end;
+  Result:=fppal;
+end;
+
+{ A grayscale palette. Not very useful. }
+function CreateGrayScalePalette : TFPPalette;
+var Col : TFPColor;
+    i : integer;
+    fppal : TFPPalette;
+begin
+  fppal:=TFPPalette.Create(256);
+  Col.Alpha:=AlphaOpaque;
+  for i:=$FF downto 0 do
+  begin
+    Col.Red:=i;
+    Col.Red:=(Col.Red shl 8) + Col.Red;
+    Col.Green:=Col.Red;
+    Col.Blue:=Col.Red;
+    fppal.Color[i]:=Col;
+  end;
+  Result:=fppal;
+end;
+
+{ Standard VGA 16 color palette. }
+function CreateVGAPalette : TFPPalette;
+var fppal : TFPPalette;
+begin
+  fppal:=TFPPalette.Create(16);
+  fppal.Color[0]:=colBlack;
+  fppal.Color[1]:=colNavy;
+  fppal.Color[2]:=colBlue;
+  fppal.Color[3]:=colMaroon;
+  fppal.Color[4]:=colPurple;
+  fppal.Color[5]:=colDkGreen;
+  fppal.Color[6]:=colRed;
+  fppal.Color[7]:=colTeal;
+  fppal.Color[8]:=colFuchsia;
+  fppal.Color[9]:=colOlive;
+  fppal.Color[10]:=colGray;
+  fppal.Color[11]:=colLime;
+  fppal.Color[12]:=colAqua;
+  fppal.Color[13]:=colSilver;
+  fppal.Color[14]:=colYellow;
+  fppal.Color[15]:=colWhite;
+  Result:=fppal;
+end;

fcl/image/fpreadbmp.pp

@@ -3,7 +3,7 @@
     This file is part of the Free Pascal's "Free Components Library".
     Copyright (c) 2003 by Mazen NEIFER of the Free Pascal development team
 
-    BMP writer implementation.
+    BMP reader implementation.
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -13,6 +13,12 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 }
 {*****************************************************************************}
+{ 08/2005 by Giulio Bernardi:
+   - Added support for 16 and 15 bpp bitmaps.
+   - If we have bpp <= 8 make an indexed image instead of converting it to RGB
+   - Support for RLE4 and RLE8 decoding
+   - Support for top-down bitmaps
+}
 
 {$mode objfpc}
 {$h+}
@@ -27,14 +33,27 @@ type
   TFPReaderBMP = class (TFPCustomImageReader)
     Private
       Procedure FreeBufs;       // Free (and nil) buffers.
+      DeltaX, DeltaY : integer; // Used for the never-used delta option in RLE
+      TopDown : boolean;        // If set, bitmap is stored top down instead of bottom up
+      continue : boolean;       // needed for onprogress event
+      percent : byte;
+      percentinterval : longword;
+      percentacc : longword;
+      Rect : TRect;
     protected
       ReadSize : Integer;       // Size (in bytes) of 1 scanline.
       BFI : TBitMapInfoHeader;  // The header as read from the stream.
-      FPalette : PFPcolor;      // Buffer with Palette entries.
+      FPalette : PFPcolor;      // Buffer with Palette entries. (useless now)
-      LineBuf : PByte;          // Buffer for 1 scanline. Can be Byte, TColorRGB or TColorRGBA
+      LineBuf : PByte;          // Buffer for 1 scanline. Can be Byte, Word, TColorRGB or TColorRGBA
-
+      RedMask, GreenMask, BlueMask : longword; //Used if Compression=bi_bitfields
+      RedShift, GreenShift, BlueShift : shortint;
       // SetupRead will allocate the needed buffers, and read the colormap if needed.
       procedure SetupRead(nPalette, nRowBits: Integer; Stream : TStream); virtual;
+      function CountBits(Value : byte) : shortint;
+      function ShiftCount(Mask : longword) : shortint;
+      function ExpandColor(value : longword) : TFPColor;
+      procedure ExpandRLE8ScanLine(Row : Integer; Stream : TStream);
+      procedure ExpandRLE4ScanLine(Row : Integer; Stream : TStream);
       procedure ReadScanLine(Row : Integer; Stream : TStream); virtual;
       procedure WriteScanLine(Row : Integer; Img : TFPCustomImage); virtual;
       // required by TFPCustomImageReader
@@ -101,6 +120,63 @@ begin
     end;
 end;
 
+{ Counts how many bits are set }
+function TFPReaderBMP.CountBits(Value : byte) : shortint;
+var i,bits : shortint;
+begin
+  bits:=0;
+  for i:=0 to 7 do
+  begin
+    if (value mod 2)<>0 then inc(bits);
+    value:=value shr 1;
+  end;
+  Result:=bits;
+end;
+
+{ If compression is bi_bitfields, there could be arbitrary masks for colors.
+  Although this is not compatible with windows9x it's better to know how to read these bitmaps
+  We must determine how to switch the value once masked
+  Example: 0000 0111 1110 0000, if we shr 5 we have 00XX XXXX for the color, but these bits must be the
+  highest in the color, so we must shr (5-(8-6))=3, and we have XXXX XX00.
+  A negative value means "shift left"  }
+function TFPReaderBMP.ShiftCount(Mask : longword) : shortint;
+var tmp : shortint;
+begin
+  tmp:=0;
+  if Mask=0 then
+  begin
+    Result:=0;
+    exit;
+  end;
+
+  while (Mask mod 2)=0 do { rightmost bit is 0 }
+  begin
+    inc(tmp);
+    Mask:= Mask shr 1;
+  end;
+  tmp:=tmp-(8-CountBits(Mask and $FF));
+  Result:=tmp;
+end;
+
+function TFPReaderBMP.ExpandColor(value : longword) : TFPColor;
+var tmpr, tmpg, tmpb : longword;
+    col : TColorRGB;
+begin
+  {$IFDEF ENDIAN_BIG}
+  value:=swap(value);
+  {$ENDIF}
+  tmpr:=value and RedMask;
+  tmpg:=value and GreenMask;
+  tmpb:=value and BlueMask;
+  if RedShift < 0 then col.R:=byte(tmpr shl (-RedShift))
+  else col.R:=byte(tmpr shr RedShift);
+  if GreenShift < 0 then col.G:=byte(tmpg shl (-GreenShift))
+  else col.G:=byte(tmpg shr GreenShift);
+  if BlueShift < 0 then col.B:=byte(tmpb shl (-BlueShift))
+  else col.B:=byte(tmpb shr BlueShift);
+  Result:=RGBToFPColor(col);
+end;
+
 procedure TFPReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream : TStream);
 
 var
@@ -108,7 +184,27 @@ var
   i: Integer;
 
 begin
-  if nPalette>0 then
+  if ((BFI.Compression=BI_RGB) and (BFI.BitCount=16)) then { 5 bits per channel, fixed mask }
+  begin
+    RedMask:=$7C00; RedShift:=7;
+    GreenMask:=$03E0; GreenShift:=2;
+    BlueMask:=$001F; BlueShift:=-3;
+  end
+  else if ((BFI.Compression=BI_BITFIELDS) and (BFI.BitCount in [16,32])) then { arbitrary mask }
+  begin
+    Stream.Read(RedMask,4);
+    Stream.Read(GreenMask,4);
+    Stream.Read(BlueMask,4);
+    {$IFDEF ENDIAN_BIG}
+    RedMask:=swap(RedMask);
+    GreenMask:=swap(GreenMask);
+    BlueMask:=swap(BlueMask);
+    {$ENDIF}
+    RedShift:=ShiftCount(RedMask);
+    GreenShift:=ShiftCount(GreenMask);
+    BlueShift:=ShiftCount(BlueMask);
+  end
+  else if nPalette>0 then
     begin
     GetMem(FPalette, nPalette*SizeOf(TFPColor));
     SetLength(ColInfo, nPalette);
@@ -128,9 +224,13 @@ end;
 procedure TFPReaderBMP.InternalRead(Stream:TStream; Img:TFPCustomImage);
 
 Var
-  Row : Integer;
+  Row, i, pallen : Integer;
-
+  BadCompression : boolean;
 begin
+  Rect.Left:=0; Rect.Top:=0; Rect.Right:=0; Rect.Bottom:=0;
+  continue:=true;
+  Progress(psStarting,0,false,Rect,'',continue);
+  if not continue then exit;
   Stream.Read(BFI,SizeOf(BFI));
   {$IFDEF ENDIAN_BIG}
   SwapBMPInfoHeader(BFI);
@@ -138,44 +238,225 @@ begin
   { This will move past any junk after the BFI header }
   Stream.Position:=Stream.Position-SizeOf(BFI)+BFI.Size;
   with BFI do
+  begin
+    BadCompression:=false;
+    if ((Compression=BI_RLE4) and (BitCount<>4)) then BadCompression:=true;
+    if ((Compression=BI_RLE8) and (BitCount<>8)) then BadCompression:=true;
+    if ((Compression=BI_BITFIELDS) and (not (BitCount in [16,32]))) then BadCompression:=true;
+    if not (Compression in [BI_RGB..BI_BITFIELDS]) then BadCompression:=true;
+    if BadCompression then
+      raise FPImageException.Create('Bad BMP compression mode');
+    TopDown:=(Height<0);
+    Height:=abs(Height);
+    if (TopDown and (not (Compression in [BI_RGB,BI_BITFIELDS]))) then
+      raise FPImageException.Create('Top-down bitmaps cannot be compressed');
+    Img.SetSize(0,0);
+    if BitCount<=8 then
     begin
-    if (Compression<>0) then
+      Img.UsePalette:=true;
-      Raise FPImageException.Create('Compressed bitmaps not supported');
+      Img.Palette.Clear;
-    Img.Width:=Width;
+    end
-    Img.Height:=Height;
+    else Img.UsePalette:=false;
+    Case BFI.BitCount of
+      1 : { Monochrome }
+        SetupRead(2,Width,Stream);
+      4 :
+        SetupRead(16,Width*4,Stream);
+      8 :
+        SetupRead(256,Width*8,Stream);
+      16 :
+        SetupRead(0,Width*8*2,Stream);
+      24:
+        SetupRead(0,Width*8*3,Stream);
+      32:
+        SetupRead(0,Width*8*4,Stream);
     end;
-  Case BFI.BitCount of
-    1 : { Monochrome }
-      SetupRead(2,Img.Width,Stream);
-    4 :
-      SetupRead(16,Img.Width*4,Stream);
-    8 :
-      SetupRead(256,Img.Width*8,Stream);
-    16 :
-      Raise FPImageException.Create('16 bpp bitmaps not supported');
-    24:
-      SetupRead(0,Img.Width*8*3,Stream);
-    32:
-      SetupRead(0,Img.Width*8*4,Stream);
   end;
   Try
-    for Row:=Img.Height-1 downto 0 do
+    { Note: it would be better to Fill the image palette in setupread instead of creating FPalette.
-      begin
+      FPalette is indeed useless but we cannot remove it since it's not private :\ }
-      ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
+    pallen:=0;
-      WriteScanLine(Row,Img);
+    if BFI.BitCount<=8 then
-      end;
+      if BFI.ClrUsed>0 then pallen:=BFI.ClrUsed
+      else pallen:=(1 shl BFI.BitCount);
+    if pallen>0 then
+    begin
+      Img.Palette.Count:=pallen;
+      for i:=0 to pallen-1 do
+        Img.Palette.Color[i]:=FPalette[i];
+    end;
+    Img.SetSize(BFI.Width,BFI.Height);
+
+    percent:=0;
+    percentinterval:=(Img.Height*4) div 100;
+    if percentinterval=0 then percentinterval:=$FFFFFFFF;
+    percentacc:=0;
+
+    DeltaX:=-1; DeltaY:=-1;
+      if TopDown then
+        for Row:=0 to Img.Height-1 do { A rare case of top-down bitmap! }
+        begin
+          ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
+          WriteScanLine(Row,Img);
+          if not continue then exit;
+        end
+      else
+        for Row:=Img.Height-1 downto 0 do
+        begin
+          ReadScanLine(Row,Stream); // Scanline in LineBuf with Size ReadSize.
+          WriteScanLine(Row,Img);
+          if not continue then exit;
+        end;
+    Progress(psEnding,100,false,Rect,'',continue);
   finally
     FreeBufs;
   end;
 end;
 
-procedure TFPReaderBMP.ReadScanLine(Row : Integer; Stream : TStream);
+procedure TFPReaderBMP.ExpandRLE8ScanLine(Row : Integer; Stream : TStream);
-
+var i,j : integer;
+    b0, b1 : byte;
 begin
-  {
+  i:=0;
-    Add here support for compressed lines. The 'readsize' is the same in the end.
+  while true do
-  }
+  begin
-  Stream.Read(LineBuf[0],ReadSize);
+    { let's see if we must skip pixels because of delta... }
+    if DeltaY<>-1 then
+    begin
+      if Row=DeltaY then j:=DeltaX { If we are on the same line, skip till DeltaX }
+      else j:=ReadSize;            { else skip up to the end of this line }
+      while (i<j) do
+        begin
+          LineBuf[i]:=0;
+          inc(i);
+        end;
+
+      if Row=DeltaY then { we don't need delta anymore }
+        DeltaY:=-1
+      else break; { skipping must continue on the next line, we are finished here }
+    end;
+
+    Stream.Read(b0,1); Stream.Read(b1,1);
+    if b0<>0 then { number of repetitions }
+    begin
+      if b0+i>ReadSize then
+        raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
+      j:=i+b0;
+      while (i<j) do
+      begin
+        LineBuf[i]:=b1;
+        inc(i);
+      end;
+    end
+    else
+      case b1 of 
+        0: break; { end of line }
+        1: break; { end of file }
+        2: begin  { Next pixel position. Skipped pixels should be left untouched, but we set them to zero }
+             Stream.Read(b0,1); Stream.Read(b1,1);
+             DeltaX:=i+b0; DeltaY:=Row+b1;
+           end
+        else begin { absolute mode }
+               if b1+i>ReadSize then
+                 raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
+               Stream.Read(LineBuf[i],b1);
+               inc(i,b1);
+               { aligned on 2 bytes boundary: every group starts on a 2 bytes boundary, but absolute group
+                 could end on odd address if there is a odd number of elements, so we pad it  }
+               if (b1 mod 2)<>0 then Stream.Seek(1,soFromCurrent); 
+             end;
+      end;
+  end;
+end;
+
+procedure TFPReaderBMP.ExpandRLE4ScanLine(Row : Integer; Stream : TStream);
+var i,j,tmpsize : integer;
+    b0, b1 : byte;
+    nibline : pbyte; { temporary array of nibbles }
+    even : boolean;
+begin
+  tmpsize:=ReadSize*2; { ReadSize is in bytes, while nibline is made of nibbles, so it's 2*readsize long }
+  getmem(nibline,tmpsize);
+  if nibline=nil then
+    raise FPImageException.Create('Out of memory');
+  try
+    i:=0;
+    while true do
+    begin
+      { let's see if we must skip pixels because of delta... }
+      if DeltaY<>-1 then
+      begin
+        if Row=DeltaY then j:=DeltaX { If we are on the same line, skip till DeltaX }
+        else j:=tmpsize;            { else skip up to the end of this line }
+        while (i<j) do
+          begin
+            NibLine[i]:=0;
+            inc(i);
+          end;
+
+        if Row=DeltaY then { we don't need delta anymore }
+          DeltaY:=-1
+        else break; { skipping must continue on the next line, we are finished here }
+      end;
+
+      Stream.Read(b0,1); Stream.Read(b1,1);
+      if b0<>0 then { number of repetitions }
+      begin
+        if b0+i>tmpsize then
+          raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
+        even:=true;
+        j:=i+b0;
+        while (i<j) do
+        begin
+          if even then NibLine[i]:=(b1 and $F0) shr 4
+          else NibLine[i]:=b1 and $0F;
+          inc(i);
+          even:=not even;
+        end;
+      end
+      else
+        case b1 of 
+          0: break; { end of line }
+          1: break; { end of file }
+          2: begin  { Next pixel position. Skipped pixels should be left untouched, but we set them to zero }
+               Stream.Read(b0,1); Stream.Read(b1,1);
+               DeltaX:=i+b0; DeltaY:=Row+b1;
+             end
+          else begin { absolute mode }
+                 if b1+i>tmpsize then
+                   raise FPImageException.Create('Bad BMP RLE chunk at row '+inttostr(row)+', col '+inttostr(i)+', file offset $'+inttohex(Stream.Position,16) );
+                 j:=i+b1;
+                 even:=true;
+                 while (i<j) do
+                 begin
+                   if even then
+                   begin
+                     Stream.Read(b0,1);
+                     NibLine[i]:=(b0 and $F0) shr 4;
+                   end
+                   else NibLine[i]:=b0 and $0F;
+                   inc(i);
+                   even:=not even;
+                 end;
+               { aligned on 2 bytes boundary: see rle8 for details  }
+                 b1:=b1+(b1 mod 2);
+                 if (b1 mod 4)<>0 then Stream.Seek(1,soFromCurrent);
+               end;
+        end;
+    end;
+    { pack the nibline into the linebuf }
+    for i:=0 to ReadSize-1 do
+      LineBuf[i]:=(NibLine[i*2] shl 4) or NibLine[i*2+1];
+  finally
+    FreeMem(nibline)
+  end;
+end;
+
+procedure TFPReaderBMP.ReadScanLine(Row : Integer; Stream : TStream);
+begin
+  if BFI.Compression=BI_RLE8 then ExpandRLE8ScanLine(Row,Stream)
+  else if BFI.Compression=BI_RLE4 then ExpandRLE4ScanLine(Row,Stream)
+  else Stream.Read(LineBuf[0],ReadSize);
 end;
 
 procedure TFPReaderBMP.WriteScanLine(Row : Integer; Img : TFPCustomImage);
@@ -188,23 +469,35 @@ begin
    1 :
      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]:=FPalette[1]
+         img.Pixels[Column,Row]:=1
        else
-         img.colors[Column,Row]:=FPalette[0];
+         img.Pixels[Column,Row]:=0;
    4 :
       for Column:=0 to img.Width-1 do
-        img.colors[Column,Row]:=FPalette[(LineBuf[Column div 2] shr (((Column+1) and 1)*4)) and $0f];
+        img.Pixels[Column,Row]:=(LineBuf[Column div 2] shr (((Column+1) and 1)*4)) and $0f;
    8 :
       for Column:=0 to img.Width-1 do
-        img.colors[Column,Row]:=FPalette[LineBuf[Column]];
+        img.Pixels[Column,Row]:=LineBuf[Column];
    16 :
-      Raise FPImageException.Create('16 bpp bitmaps not supported');
+      for Column:=0 to img.Width-1 do
+        img.colors[Column,Row]:=ExpandColor(PWord(LineBuf)[Column]);
    24 :
       for Column:=0 to img.Width-1 do
         img.colors[Column,Row]:=RGBToFPColor(PColorRGB(LineBuf)[Column]);
    32 :
       for Column:=0 to img.Width-1 do
-        img.colors[Column,Row]:=RGBAToFPColor(PColorRGBA(LineBuf)[Column]);
+        if BFI.Compression=BI_BITFIELDS then
+          img.colors[Column,Row]:=ExpandColor(PLongWord(LineBuf)[Column])
+        else
+          img.colors[Column,Row]:=RGBAToFPColor(PColorRGBA(LineBuf)[Column]);
+    end;
+
+    inc(percentacc,4);
+    if percentacc>=percentinterval then
+    begin
+      percent:=percent+(percentacc div percentinterval);
+      percentacc:=percentacc mod percentinterval;
+      Progress(psRunning,percent,false,Rect,'',continue);
     end;
 end;
 

fcl/image/fpwritebmp.pp

@@ -13,32 +13,53 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 }
 {*****************************************************************************}
+{ 08/2005 by Giulio Bernardi:
+   - Removed FBytesPerPixel, BytesPerPixel property is now deprecated, use BitsPerPixel instead.
+   - Rewritten a large part of the file, so we can handle all bmp color depths
+   - Support for RLE4 and RLE8 encoding
+}
+
 {$mode objfpc}{$h+}
 unit FPWriteBMP;
 
 interface
 
-uses FPImage, classes, sysutils;
+uses FPImage, classes, sysutils, BMPComn;
 
 type
 
   TFPWriterBMP = class (TFPCustomImageWriter)
   private
-    FBytesPerPixel : Byte;
+    StartPosition : int64; { save start of bitmap in the stream, if we must go back and fix something }
+    FBpp : byte;
+    FRLECompress : boolean;
+    BFH : TBitMapFileHeader;
+    BFI : TBitMapInfoHeader;
+    Colinfo : array of TColorRGBA;
     procedure SetColorSize (AValue : Byte);
+    function GetColorSize : byte;
+    procedure SetBpp (const abpp : byte);
+    procedure FillColorMap(Img : TFPCustomImage);
+    procedure Setup16bpp;
+    function PackWord555(const col : TFPColor) : word;
+    function PackWord565(const col : TFPColor) : word;
+    function Pack4bpp(const img : TFPCustomImage; var Col : integer; const Row : integer) : byte;
+    function Pack1bpp(const img : TFPCustomImage; var Col : integer; const Row : integer) : byte;
+    procedure CompressScanLineRLE8(ALine : pbyte; const Row, Width : Integer; Stream : TStream);
+    procedure CompressScanLineRLE4(ALine : pbyte; const Row, Width : Integer; Stream : TStream);
   protected
     function  SaveHeader(Stream:TStream; Img: TFPCustomImage):boolean; virtual;
     procedure InternalWrite (Stream:TStream; Img: TFPCustomImage); override;
   public
     constructor Create; override;
-    Property BytesPerPixel : Byte Read FBytesPerPixel Write SetColorSize;
+    property BitsPerPixel : byte read FBpp write SetBpp;
+    property RLECompress : boolean read FRleCompress write FRleCompress;
+    Property BytesPerPixel : Byte Read GetColorSize Write SetColorSize; deprecated;
   end;
 
 
 implementation
 
-uses BMPcomn;
-
 Function FPColorToRGB(Const Color : TFPColor) : TColorRGB;
 
 begin
@@ -65,24 +86,157 @@ end;
 constructor TFPWriterBMP.create;
 begin
   inherited create;
-  FBytesPerPixel:=3;
+  FBpp:=24;
+  FRleCompress:=false;
 end;
 
+{ Only for compatibility, BytesPerPixel should be removed }
+{ ******************************************************* }
 procedure TFPWriterBMP.SetColorSize (AValue : byte);
 begin
-  if (AValue>4) then
+  SetBpp(AValue*8);
-    AValue:=4;
+end;
-  if (AValue<1) then
+
-    AValue:=1;
+function TFPWriterBMP.GetColorSize : byte;
-  FBytesPerPixel:=AValue;
+begin
+  if FBpp<>15 then Result:=FBpp div 8
+  else Result:=2;
+end;
+{ ******************************************************* }
+
+procedure TFPWriterBMP.SetBpp (const abpp : byte);
+begin
+  if not (abpp in [1,4,8,15,16,24,32]) then
+    raise FPImageException.Create('Invalid color depth');
+  FBpp:=abpp;
+end;
+
+procedure TFPWriterBMP.FillColorMap(Img : TFPCustomImage);
+var BadPalette : boolean;
+    i : integer;
+begin
+  BadPalette:=false;
+  if not Img.UsePalette then BadPalette:=true
+  else if Img.Palette.Count>(1 shl FBpp) then BadPalette:=true;
+  if BadPalette then 
+    raise FPImageException.Create('Image palette is too big or absent');
+  setlength(ColInfo,Img.Palette.Count);
+  BFI.ClrUsed:=Img.Palette.Count;
+  for i:=0 to BFI.ClrUsed-1 do
+  begin
+    ColInfo[i]:=FPColorToRGBA(Img.Palette.Color[i]);
+    ColInfo[i].A:=0;
+  end;
+end;
+
+{ True 16 bit color is 5 bits red, 6 bits green and 5 bits blue.
+  Compression must be set to BI_BITFIELDS and we must specify masks for red, green and blue.
+  16 bit without compression and masks is 5 bits per channel, so it's 15 bit even if in the header we
+  must write 16.
+  It's possible to provide custom masks but this is not compatible with windows9x, so we use 555 for 15 bit
+  and 565 for 16 bit.
+  Masks are longwords stored in the palette instead of palette entries (which are 4 bytes long too, with
+  components stored in following order: B G R A. Since we must write a low-endian longword, B is LSB and A
+  is the MSB).
+  We must write first red mask, then green and then blue.
+
+  This sounds terribly confusing, if you don't understand take a look at
+  http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/bitmaps_1rw2.asp
+   }
+procedure TFPWriterBMP.Setup16bpp;
+var col : TColorRGBA;
+begin
+  BFI.Compression:=BI_BITFIELDS;
+  setlength(ColInfo,3);
+  {      A R G B
+  r := $0000F800
+  g := $000007E0
+  b := $0000001F
+  }
+  col.A:=0; Col.R:=0; { These are 0 for all the three masks}
+  { Red Mask }
+  Col.G:=$F8; Col.B:=0;
+  ColInfo[0]:=Col;
+  { Green Mask }
+  Col.G:=$07; Col.B:=$E0;
+  ColInfo[1]:=Col;
+  { Blue Mask }
+  Col.G:=$00; Col.B:=$1F;
+  ColInfo[2]:=Col;
+end;
+
+{ 16 bit bpp with 555 packing (that is, 15 bit color)
+  This is bit dislocation:
+  0RRR RRGG GGGB BBBB  }
+
+function TFPWriterBMP.PackWord555(const col : TFPColor) : word;
+var tmpcol : TColorRGB;
+    tmpr, tmpg, tmpb : word;
+begin
+  tmpcol:=FPColorToRGB(col);
+  tmpb:=tmpcol.b shr 3;
+  tmpg:=tmpcol.g and $F8; tmpg:= tmpg shl 2;
+  tmpr:=tmpcol.r and $F8; tmpr:= tmpr shl 7;
+  tmpb:= tmpr or tmpg or tmpb;
+  {$IFDEF ENDIAN_BIG}
+  tmpb:=swap(tmpb);
+  {$ENDIF}
+  Result:=tmpb;
+end;
+
+{ 16 bit bpp with 565 packing )
+  This is bit dislocation:
+  RRRR RGGG GGGB BBBB  }
+
+function TFPWriterBMP.PackWord565(const col : TFPColor) : word;
+var tmpcol : TColorRGB;
+    tmpr, tmpg, tmpb : word;
+begin
+  tmpcol:=FPColorToRGB(col);
+  tmpb:=tmpcol.b shr 3;
+  tmpg:=tmpcol.g and $FC; tmpg:= tmpg shl 3;
+  tmpr:=tmpcol.r and $F8; tmpr:= tmpr shl 8;
+  tmpb:= tmpr or tmpg or tmpb;
+  {$IFDEF ENDIAN_BIG}
+  tmpb:=swap(tmpb);
+  {$ENDIF}
+  Result:=tmpb;
+end;
+
+{ First pixel in the most significant nibble, second one in LSN. If we are at the end of the line,
+  pad with zero }
+function TFPWriterBMP.Pack4bpp(const img : TFPCustomImage; var Col : integer; const Row : integer) : byte;
+var b : byte;
+begin
+  b:=(img.Pixels[Col,Row] and $F) shl 4;
+  if Col<img.Width-1 then
+  begin
+    inc(Col);
+    b:=b + (img.Pixels[Col,Row] and $F);
+  end;
+  Result:=b;
+  inc(col);
+end;
+
+{ First pixel in the most significant bit, last one in LSN. If we are at the end of the line,
+  pad with zero }
+function TFPWriterBMP.Pack1bpp(const img : TFPCustomImage; var Col : integer; const Row : integer) : byte;
+var b : byte;
+    sh : shortint;
+begin
+  b:=0;
+  sh:=7;
+  while ((Col<Img.Width) and (sh>=0)) do
+  begin
+    if img.Pixels[Col,Row]<>0 then { set this bit }
+      b:=b+(1 shl sh);
+    dec(sh);
+    inc(Col);
+  end;
+  Result:=b;
 end;
 
 function TFPWriterBMP.SaveHeader(Stream:TStream; Img : TFPCustomImage):boolean;
-
-var
-  BFH:TBitMapFileHeader;
-  BFI:TBitMapInfoHeader;
-
 begin
   Result:=False;
   with BFI do
@@ -91,58 +245,485 @@ begin
     Width:=Img.Width;
     Height:=Img.Height;
     Planes:=1;
-    BitCount:=BytesPerPixel SHL 3;
+    if FBpp=15 then BitCount:=16
-    Compression:=0;
+    else BitCount:=FBpp;
-    SizeImage:=Width*Height;
     XPelsPerMeter:=100;
     YPelsPerMeter:=100;
-    ClrUsed:=0; // No palette yet.
     ClrImportant:=0;
     end;
   with BFH do
     begin
     bfType:=BMmagic;//'BM'
-    bfOffset:=sizeof(TBitMapFileHeader)+sizeof(TBitMapInfoHeader);
+    bfOffset:=sizeof(TBitMapFileHeader)+sizeof(TBitMapInfoHeader)+length(ColInfo)*4;
     bfReserved:=0;
-    bfSize:=bfOffset+BFI.SizeImage*BytesPerPixel;
+    bfSize:=bfOffset+BFI.SizeImage;
     end;
   {$IFDEF ENDIAN_BIG}
   SwapBMPFileHeader(BFH);
   SwapBMPInfoHeader(BFI);
   {$ENDIF}
-  Stream.seek(0,soFromBeginning);
+  StartPosition:=Stream.Position;
   Stream.Write(bfh,sizeof(TBitMapFileHeader));
   Stream.Write(bfi,sizeof(TBitMapInfoHeader));
+  {$IFDEF ENDIAN_BIG}
+  SwapBMPFileHeader(BFH);
+  SwapBMPInfoHeader(BFI);
+  {$ENDIF}
   Result:=true;
 end;
 
-procedure TFPWriterBMP.InternalWrite (Stream:TStream; Img:TFPCustomImage);
+{ This code is rather ugly and difficult to read, but compresses better than gimp.
-
+  Brief explanation:
-var
+  A repetition is good if it's made of 3 elements at least: we have 2 bytes instead of 1. Let's call this a 
-  Row,Col,nBpLine,WriteSize:Integer;
+  "repetition" or "true repetition".
-  aLine: PByte;
+  So we start finding the first repetition from current position.
-  S : Integer;
+  Once found, we must decide how to handle elements between current position (i) and the repetition position (j)
+  if j-i = 0 we are on the repetition, so we encode it
+  if j-i = 1 there is only one pixel. We can't do anything but encode it as a repetition of 1 element.
+  if j-i = 2 we have two pixels. These can be a couple (a repetition of 2 elements) or 2 singles
+             (2 repetitions of 1 element)
+  if j-i > 2 we have two choices. In fact, we must consider that absolute mode is 2 bytes + length of chunk.
+             A repetition is always 2 bytes, so for 1 element we leak 1 byte, while for 2 elements we don't leak
+             any byte.
+             So if we have at most 1 single this means that everything else is made up of couples: it's best to
+             use repetitions so that we leak 0 to 1 byte.
+             If we have 2 singles or more it's better to use absolute mode, since we leak 2 bytes always,
+             without regard to the size of chunk. }
 
+procedure TFPWriterBMP.CompressScanLineRLE8(ALine : pbyte; const Row, Width : Integer; Stream : TStream);
+var i, j, k, couples, singles : integer;
+    prev,tmp : byte;
 begin
-  If Not (BytesPerPixel in [3,4]) then
+  i:=0;
-    Raise FPImageException.Create('Only 24 or 32 bit images are currently supported.');
+  while (i<Width) do
-  SaveHeader(Stream,Img);
+  begin
-  nBpLine:=Img.Width*BytesPerPixel;
+    { let's see how bytes are disposed, so that we can choose the best way to compress }
-  WriteSize:=(nBpLine+3) AND $FFFFFFFC; //BMP needs evry line 4Bytes aligned
+    couples:=0; singles:=1;
-  GetMem(aLine,(Img.Width+1)*BytesPerPixel);//3 extra byte for BMP 4Bytes alignement.
+    prev:=Aline[i];
-  Try
+    j:=i+1;
-    for Row:=Img.Height-1 downto 0 do
+    while ((j<Width) and ((j-i)<255)) do
+    begin
+      if Aline[j]=prev then { this is a couple at least }
       begin
-      Case BytesPerPixel of
+        dec(singles); { so the previous one wasn't a single }
-        3 : for Col:=0 to img.Width-1 do
+        if (((j+1)<Width) and (Aline[j+1]=prev)) then { at least three equal items, it's a repetition }
-              PColorRGB(aLine)[Col]:=FPColorToRGB(img.colors[Col,Row]);
+        begin
-        4 : for Col:=0 to img.Width-1 do
+          dec(j); { repetition starts at j-1, since j is the middle pixel and j+1 is the third pixel }
-              PColorRGBA(aLine)[Col]:=FPColorToRGBA(img.colors[Col,Row]);
+          break;
+        end
+        else inc(couples) { ok it's a couple }
+      end
+      else inc(singles); { this is a single if next isn't a couple }
+      prev:=Aline[j];
+      inc(j);
+    end;
+
+    { ok, now that we know more about byte disposition we write data }
+    case (j-i) of
+      0 : begin { there is a repetition with count>=3 }
+            prev:=Aline[i];
+            j:=i+1;
+            while ((j<Width) and ((j-i)<255)) do
+            begin
+              if Aline[j]<>prev then break;
+              inc(j);
+            end;
+            tmp:=j-i;
+            Stream.Write(tmp,1);
+            Stream.Write(prev,1);
+          end;
+      1 : begin { single value: we write a repetition of 1 }
+            tmp:=1;
+            Stream.Write(tmp,1);
+            Stream.Write(Aline[i],1);
+          end;
+      2 : begin
+            if couples=1 then { a couple: we write a repetition of 2 }
+            begin
+              tmp:=2;
+              Stream.Write(tmp,1);
+              Stream.Write(Aline[i],1);
+            end
+            else { two singles: we write two repetitions of 1 each }
+            begin
+              tmp:=1;
+              Stream.Write(tmp,1);
+              Stream.Write(Aline[i],1);
+              Stream.Write(tmp,1);
+              Stream.Write(Aline[i+1],1);
+            end;
+          end;
+      else { here we have two choices }
+      begin
+        if singles>1 then { it's cheaper to use absolute mode }
+        begin
+          tmp:=0; Stream.Write(tmp,1);   { escape }
+          tmp:=j-i; Stream.Write(tmp,1); { number of pixels in absolute mode }
+          Stream.Write(Aline[i],j-i);    { write these pixels... }
+          if ((tmp mod 2)<>0) then       { we must end on a 2-byte boundary }
+          begin
+            tmp:=0; Stream.Write(tmp,1); { so pad with an additional zero }
+          end;
+        end
+        else { they're nearly all couples, don't use absolute mode }
+        begin
+          k:=i;
+          while (k<j) do
+          begin
+            if ((k+1<j) and (Aline[k]=Aline[k+1])) then
+            begin
+              tmp:=2;
+              inc(k);
+            end
+            else tmp:=1;
+            Stream.Write(tmp,1);
+            Stream.Write(Aline[k],1);
+            inc(k);
+          end;
+        end;
       end;
-      Stream.Write(aLine[0],WriteSize);
+    end;
+    i:=j;
+  end;
+  tmp:=0; Stream.Write(tmp,1); { escape }
+  if Row=0 then { last line, end of file }
+    tmp:=1;
+  Stream.Write(tmp,1);
+end;
+
+{ Ok, this is even uglier than the RLE8 version above, and this time gimp compresses better :\
+  Differences with RLE8: repetition count is pixel-relative, not byte-relative, but repetition data is made
+  of 2 pixels. So you have a repetition when you have pixels repeated in an alternate way, even if you can do
+  something like:
+  01E0 => E
+  0316 => 161.
+  A repetition is good if it's made of five elements at least (2 bytes instead of 3).
+  In rle4 we consider "single" either a single nibble or 2 (a byte), while a couple is a repetition of 3 or 4
+  elements. }
+
+procedure TFPWriterBMP.CompressScanLineRLE4(ALine : pbyte; const Row, Width : Integer; Stream : TStream);
+var i, j, k, couples, singles, lastsingle : integer;
+    prev1, prev2, prev : word;
+    tmp : byte;
+    nibline : pbyte; { temporary array of nibbles }
+    even : boolean;
+begin
+  getmem(nibline,width);
+  try
+    k:=(Width div 2) + (Width mod 2);
+    i:=0;
+    while (i<k) do
+    begin
+      nibline[i*2]:=aline[i] shr 4;
+      nibline[i*2+1]:=aline[i] and $F;
+      inc(i);
+    end;
+    i:=0;
+    while (i<Width) do
+    begin
+      { let's see how nibbles are disposed, so that we can choose the best way to compress }
+      couples:=0; singles:=1; lastsingle:=-10;
+      prev1:=nibline[i];
+      prev2:=nibline[i+1];
+      j:=i+2;
+      while ((j<Width) and ((j-i)<255)) do
+      begin
+        if nibline[j]=prev1 then { this is a half-couple at least (repetition of 3) }
+        begin
+          dec(singles); { so the previous one wasn't a single }
+          if (((j+1)<Width) and (nibline[j+1]=prev2)) then { at least a couple (repetition of 4) }
+          begin
+            if (((j+2)<Width) and (nibline[j+2]=prev1)) then { at least a repetition of 5, good }
+            begin
+              dec(j,2); { repetition starts at j-2: prev1 prev2 prev1* prev2 prev1, we are here * }
+              break;
+            end
+            else
+            begin { ok it's a couple }
+              inc(couples);
+              if (j-i)=254 then { in this rare case, j-i becomes 256. So, force a half-couple and exit }
+              begin
+                inc(j);
+                break;
+              end;
+              prev1:=256; { this is a couple, don't consider these positions in further scanning }
+              prev2:=256;
+              inc(j,2);
+              continue;
+            end
+          end
+          else
+            begin { ok it's a half-couple }
+            inc(couples);
+            prev:=256; //this is a half-couple, don't consider this position in further scanning.
+          end;
+        end
+        else
+        begin
+          if lastsingle<>(j-1) then
+          begin
+            inc(singles); { this is a single if next isn't a couple }
+            lastsingle:=j;
+          end;
+          prev:=nibline[j];
+        end;
+        prev1:=prev2;
+        prev2:=prev;
+        even:=not even;
+        inc(j);
       end;
-  Finally
+      if j>Width then j:=Width; { if j was Width-1 loop was skipped and j is Width+1, so we fix it }
-    FreeMem(aLine);
+
+      { ok, now that we know more about byte disposition we write data }
+      case (j-i) of
+        0 : begin { there is a repetition with count>=5 }
+              even:=true;
+              prev1:=nibline[i];
+              prev2:=nibline[i+1];
+              j:=i+2;
+              while ((j<Width) and ((j-i)<255)) do
+              begin
+                if even then if nibline[j]<>prev1 then break;
+                if not even then if nibline[j]<>prev2 then break;
+                even:=not even;
+                inc(j);
+              end;
+              tmp:=j-i;
+              Stream.Write(tmp,1);
+              prev:=(prev1 shl 4) + (prev2 and $F);
+              tmp:=prev;
+              Stream.Write(tmp,1);
+            end;
+        1 : begin { single value: we write a repetition of 1 }
+              tmp:=1;
+              Stream.Write(tmp,1);
+              tmp:=nibline[i] shl 4;
+              Stream.Write(tmp,1);
+            end;
+        2 : begin { 2 singles in the same byte: we write a repetition of 2 }
+              tmp:=2;
+              Stream.Write(tmp,1);
+              tmp:=(nibline[i] shl 4) + (nibline[i+1] and $F);
+              Stream.Write(tmp,1);
+            end;
+        3 : begin
+              if couples=1 then { a couple: we write a repetition of 3 }
+              begin
+                tmp:=3;
+                Stream.Write(tmp,1);
+                tmp:=(nibline[i] shl 4) + (nibline[i+1] and $F);
+                Stream.Write(tmp,1);
+              end
+              else
+              begin { 2 singles, 2 repetitions of 2 and 1 respectively }
+                tmp:=2;
+                Stream.Write(tmp,1);
+                tmp:=(nibline[i] shl 4) + (nibline[i+1] and $F);
+                Stream.Write(tmp,1);
+                tmp:=1;
+                Stream.Write(tmp,1);
+                tmp:=nibline[i+2] shl 4;
+                Stream.Write(tmp,1);
+              end;
+            end;
+        4 : begin
+              if singles=0 then { a couple: we write a repetition of 4 }
+              begin
+                tmp:=4;
+                Stream.Write(tmp,1);
+                tmp:=(nibline[i] shl 4) + (nibline[i+1] and $F);
+                Stream.Write(tmp,1);
+              end
+              else
+              begin { 2 singles, 2 repetitions of 2 each }
+                tmp:=2;
+                Stream.Write(tmp,1);
+                tmp:=(nibline[i] shl 4) + (nibline[i+1] and $F);
+                Stream.Write(tmp,1);
+                tmp:=2;
+                Stream.Write(tmp,1);
+                tmp:=(nibline[i+2] shl 4) + (nibline[i+3] and $F);
+                Stream.Write(tmp,1);
+              end;
+            end;
+        else { here we have two choices }
+        begin
+          if singles>1 then { it's cheaper to use absolute mode }
+          begin
+            tmp:=0; Stream.Write(tmp,1);    { escape }
+            tmp:=j-i; Stream.Write(tmp,1);  { number of pixels in absolute mode }
+            k:=i;
+            while (k<j) do                  { write these pixels... }
+            begin
+              tmp:=nibline[k] shl 4;
+              inc(k);
+              if k<j then
+              begin
+                tmp:=tmp+(nibline[k] and $F);
+                inc(k);
+              end;
+              Stream.Write(tmp,1);
+            end;
+            k:=j-i;
+            k:=k+(k mod 2);
+            if (k mod 4)<>0 then            { we must end on a 2-byte boundary }
+            begin
+              tmp:=0; Stream.Write(tmp,1); { so pad with an additional zero }
+            end;
+          end
+          else { they're nearly all couples, don't use absolute mode }
+          begin
+            k:=i;
+            while (k<j) do
+            begin
+              if ((k+2<j) and (nibline[k]=nibline[k+2])) then
+              begin
+                if ((k+3<j) and (nibline[k+1]=nibline[k+3])) then tmp:=4
+                else tmp:=3;
+              end
+              else
+              begin
+                if (k+1>=j) then tmp:=1
+                else if ((k+3<j) and (nibline[k+1]=nibline[k+3])) then tmp:=1
+                else tmp:=2;
+              end;
+              Stream.Write(tmp,1);
+              prev:=tmp;
+              tmp:=nibline[k] shl 4;
+              if tmp<>1 then tmp:=tmp+(nibline[k+1] and $F);
+              Stream.Write(tmp,1);
+              inc(k,prev);
+            end;
+          end;
+        end;
+      end;
+      i:=j;
+    end;
+    tmp:=0; Stream.Write(tmp,1); { escape }
+    if Row=0 then { last line, end of file }
+      tmp:=1;
+    Stream.Write(tmp,1);
+  finally
+    FreeMem(nibline);
+  end;
+end;
+
+procedure TFPWriterBMP.InternalWrite (Stream:TStream; Img:TFPCustomImage);
+var
+  Row,Col,RowSize:Integer;
+  PadCount : byte;
+  aLine: PByte;
+  i : Integer;
+  tmppos : int64;
+  continue : boolean;
+  percent : byte;
+  percentinterval : longword;
+  percentacc : longword;
+  Rect : TRect;
+begin
+  Rect.Left:=0; Rect.Top:=0; Rect.Right:=0; Rect.Bottom:=0;
+  continue:=true;
+  percent:=0;
+  percentinterval:=(Img.Height*4) div 100;
+  if percentinterval=0 then percentinterval:=$FFFFFFFF;
+  percentacc:=0;
+  Progress(psStarting,0,false,Rect,'',continue);
+  if not continue then exit;
+  if (FRLECompress and (not (FBpp in [4,8]))) then
+    raise FPImageException.Create('Can''t use RLE compression with '+IntToStr(FBpp)+' bits per pixel');
+  if FRLECompress and (FBpp=4) then BFI.Compression:=BI_RLE4
+  else if FRLECompress and (FBpp=8) then BFI.Compression:=BI_RLE8
+  else BFI.Compression:=BI_RGB;
+  BFI.ClrUsed:=0;
+  try
+    if FBpp<=8 then FillColorMap(Img); { sets colormap and ClrUsed}
+    if FBpp=16 then Setup16bpp; { sets colormap with masks and Compression }
+    RowSize:=0; { just to keep the compiler quiet. }
+    case FBpp of
+      1 : begin
+            RowSize:=Img.Width div 8;
+            if (Img.Width mod 8)<>0 then
+              inc(RowSize);
+          end;
+      4 : begin
+            RowSize:=Img.Width div 2;
+            if (Img.Width mod 2)<>0 then
+              inc(RowSize);
+          end;
+      8 : RowSize:=Img.Width;
+     15 : RowSize:=Img.Width*2;
+     16 : RowSize:=Img.Width*2;
+     24 : RowSize:=Img.Width*3;
+     32 : RowSize:=Img.Width*4;
+    end;
+    PadCount:=(4-(RowSize mod 4)) mod 4; { every row must end on 4 byte boundary }
+    inc(RowSize,PadCount);
+    BFI.SizeImage:=RowSize*Img.Height;
+
+    SaveHeader(Stream,Img); { write the headers }
+    for i:=0 to length(ColInfo)-1 do { write the palette (or the masks in 16bpp case) }
+      Stream.Write(ColInfo[i],sizeof(TColorRGBA));
+
+    GetMem(aLine,RowSize);
+    try
+      for Row:=Img.Height-1 downto 0 do
+      begin
+        i:=0; Col:=0;
+        case FBpp of
+          1 : while(Col<img.Width) do
+              begin
+                PByte(aline)[i]:=Pack1bpp(img,Col,Row); { increases Col by 8 each time }
+                inc(i);
+              end;
+          4 : while(Col<img.Width) do
+              begin
+                PByte(aline)[i]:=Pack4bpp(img,Col,Row); { increases Col by 2 each time }
+                inc(i);
+              end;
+          8 : for Col:=0 to img.Width-1 do
+                PByte(aline)[Col]:=img.Pixels[Col,Row];
+         15 : for Col:=0 to img.Width-1 do
+                PWord(aline)[Col]:=PackWord555(img.colors[Col,Row]);
+         16 : for Col:=0 to img.Width-1 do
+                PWord(aline)[Col]:=PackWord565(img.colors[Col,Row]);
+         24 : for Col:=0 to img.Width-1 do
+                PColorRGB(aLine)[Col]:=FPColorToRGB(img.colors[Col,Row]);
+         32 : for Col:=0 to img.Width-1 do
+                PColorRGBA(aLine)[Col]:=FPColorToRGBA(img.colors[Col,Row]);
+        end;
+        { pad the scanline with zeros }
+        for i:=RowSize-PadCount to RowSize-1 do
+          Pbyte(aline)[i]:=0;
+
+        if BFI.Compression=BI_RLE8 then CompressScanLineRLE8(aLine,Row,img.Width,Stream)
+        else if BFI.Compression=BI_RLE4 then CompressScanLineRLE4(aLine,Row,img.Width,Stream)
+        else Stream.Write(aLine[0],RowSize);
+
+        inc(percentacc,4);
+        if percentacc>=percentinterval then
+        begin
+          percent:=percent+(percentacc div percentinterval);
+          percentacc:=percentacc mod percentinterval;
+          Progress(psRunning,percent,false,Rect,'',continue);
+          if not continue then exit;
+        end;
+      end;
+      { If image is compressed we must fix the headers since we now know the size of the image }
+      if BFI.Compression in [BI_RLE4,BI_RLE8] then 
+      begin
+        tmppos:=Stream.Position-StartPosition-BFH.bfOffset;
+        BFI.SizeImage:=tmppos;          { set size of the image }
+        tmppos:=Stream.Position;        { remember where we are }
+        Stream.Position:=StartPosition; { rewind to the beginning }
+        SaveHeader(Stream,Img);         { rewrite headers (this will update BFH.Size too) }
+        Stream.Position:=tmppos;        { restore our position }
+      end;
+      Progress(psEnding,100,false,Rect,'',continue);
+    finally
+      FreeMem(aLine);
+    end;
+  finally
+    setlength(ColInfo,0);
   end;
 end;
 

fcl/image/imgconv.pp

@@ -69,7 +69,7 @@ begin
   else if T = 'B' then
     begin
     Writer := TFPWriterBMP.Create;
-    TFPWriterBMP(Writer).BytesPerPixel:=4;
+    TFPWriterBMP(Writer).BitsPerPixel:=32;
     end
   else if T = 'J' then
     Writer := TFPWriterJPEG.Create