{*****************************************************************************}
{
    This original file was part of the Free Pascal's "Free Components Library".
    Copyright (c) 2003 by Mazen NEIFER of the Free Pascal development team

    BMP reader implementation.

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    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

  03/2014 by circular:
   - RLE optimisation using a read buffer
   - direct access to pixels with TBGRABitmap
   - vertical shrink option with MinifyHeight,WantedHeight,OutputHeight (useful for thumbnails)
}

{$mode objfpc}
{$h+}

unit BGRAReadBMP;

interface

uses FPImage, classes, sysutils, BMPcomn, BGRABitmapTypes;

type
  TBMPTransparencyOption = (toAuto, toTransparent, toOpaque);

  { TBGRAReaderBMP }

  TBGRAReaderBMP = class (TFPCustomImageReader)
    Private
      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
      Rect : TRect;
      Procedure FreeBufs;       // Free (and nil) buffers.
    protected
      ReadSize : Integer;       // Size (in bytes) of 1 scanline.
      BFI : TBitMapInfoHeader;  // The header as read from the stream.
      FPalette : PFPcolor;      // Buffer with Palette entries. (useless now)
      FBGRAPalette : PBGRAPixel;
      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;
      FOutputHeight: integer;
      FOriginalHeight: Integer;
      FTransparencyOption: TBMPTransparencyOption;
      FBuffer: packed array of byte;
      FBufferPos, FBufferSize: integer;
      FBufferStream: TStream;
      FHasAlphaValues: boolean;
      // 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;
      function ExpandColorBGRA(value : longword) : TBGRAPixel;
      procedure ExpandRLE8ScanLine(Row : Integer; Stream : TStream);
      procedure ExpandRLE4ScanLine(Row : Integer; Stream : TStream);
      procedure ReadScanLine(Row : Integer; Stream : TStream); virtual;
      procedure SkipScanLine(Row : Integer; Stream : TStream); virtual;
      procedure WriteScanLine(Row : Integer; Img : TFPCustomImage); virtual;
      procedure WriteScanLineBGRA(Row : Integer; Img : TFPCustomImage); virtual;
      // required by TFPCustomImageReader
      procedure InternalRead  (Stream:TStream; Img:TFPCustomImage); override;
      function  InternalCheck (Stream:TStream) : boolean; override;
      procedure InitReadBuffer(AStream: TStream; ASize: integer);
      procedure CloseReadBuffer;
      function GetNextBufferByte: byte;
      procedure MakeOpaque(Img: TFPCustomImage);
    public
      MinifyHeight,WantedHeight: integer;
      constructor Create; override;
      destructor Destroy; override;
      property OriginalHeight: integer read FOriginalHeight;
      property OutputHeight: integer read FOutputHeight;
      property TransparencyOption: TBMPTransparencyOption read FTransparencyOption write FTransparencyOption;
  end;

implementation

type
  TWriteScanlineProc = procedure (Row : Integer; Img : TFPCustomImage) of object;


function RGBAToFPColor(Const RGBA: TColorRGBA) : TFPcolor;

begin
  with Result, RGBA do
    begin
    Red   :=(R shl 8) or R;
    Green :=(G shl 8) or G;
    Blue  :=(B shl 8) or B;
    Alpha :=(A shl 8) or A
    end;
end;

Function RGBToFPColor(Const RGB : TColorRGB) : TFPColor;

begin
  with Result,RGB do
    begin  {Use only the high byte to convert the color}
    Red   := (R shl 8) + R;
    Green := (G shl 8) + G;
    Blue  := (B shl 8) + B;
    Alpha := AlphaOpaque;
    end;
end;

constructor TBGRAReaderBMP.Create;

begin
  inherited create;
  FTransparencyOption := toTransparent;
end;

destructor TBGRAReaderBMP.Destroy;

begin
  FreeBufs;
  inherited destroy;
end;

procedure TBGRAReaderBMP.FreeBufs;

begin
  If (LineBuf<>Nil) then
    begin
    FreeMem(LineBuf);
    LineBuf:=Nil;
    end;
  If (FPalette<>Nil) then
    begin
    FreeMem(FPalette);
    FPalette:=Nil;
    end;
  If (FBGRAPalette<>Nil) then
    begin
    FreeMem(FBGRAPalette);
    FBGRAPalette:=Nil;
    end;
end;

{ Counts how many bits are set }
function TBGRAReaderBMP.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 TBGRAReaderBMP.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 TBGRAReaderBMP.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;

function TBGRAReaderBMP.ExpandColorBGRA(value: longword): TBGRAPixel;
var tmpr, tmpg, tmpb : longword;
begin
  {$IFDEF ENDIAN_BIG}
  value:=swap(value);
  {$ENDIF}
  tmpr:=value and RedMask;
  tmpg:=value and GreenMask;
  tmpb:=value and BlueMask;
  if RedShift < 0 then result.red:=byte(tmpr shl (-RedShift))
  else result.red:=byte(tmpr shr RedShift);
  if GreenShift < 0 then result.green:=byte(tmpg shl (-GreenShift))
  else result.green:=byte(tmpg shr GreenShift);
  if BlueShift < 0 then result.blue:=byte(tmpb shl (-BlueShift))
  else result.blue:=byte(tmpb shr BlueShift);
  result.alpha:= 255;
end;

procedure TBGRAReaderBMP.SetupRead(nPalette, nRowBits: Integer; Stream : TStream);

var
  ColInfo: ARRAY OF TColorRGBA;
  i: Integer;

begin
  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));
    GetMem(FBGRAPalette, nPalette*SizeOf(TBGRAPixel));
    SetLength(ColInfo, nPalette);
    if BFI.ClrUsed>0 then
      Stream.Read(ColInfo[0],BFI.ClrUsed*SizeOf(TColorRGBA))
    else // Seems to me that this is dangerous.
      Stream.Read(ColInfo[0],nPalette*SizeOf(TColorRGBA));
    for i := 0 to High(ColInfo) do
    begin
      FPalette[i] := RGBToFPColor(ColInfo[i].RGB);
      FBGRAPalette[i]:= FPColorToBGRA(FPalette[i]);
    end
  end
  else if BFI.ClrUsed>0 then { Skip palette }
    {$PUSH}{$HINTS OFF}
    Stream.Position := Stream.Position + BFI.ClrUsed*SizeOf(TColorRGBA);
    {$POP}
  ReadSize:=((nRowBits + 31) div 32) shl 2;
  GetMem(LineBuf,ReadSize);
end;

procedure TBGRAReaderBMP.InternalRead(Stream:TStream; Img:TFPCustomImage);

Var
  PrevSourceRow,SourceRow, i, pallen, SourceRowDelta, SourceLastRow : Integer;
  BadCompression : boolean;
  WriteScanlineProc: TWriteScanlineProc;
  SourceRowAdd: integer;
  SourceRowAcc,SourceRowMod: integer;
  SourceRowAccAdd: integer;
  OutputLastRow, OutputRow, OutputRowDelta: integer;

  prevPercent, percent, percentAdd : byte;
  percentMod : longword;
  percentAcc, percentAccAdd : longword;

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);
  {$ENDIF}
  { 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);
    FOriginalHeight := 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
      Img.UsePalette:=true;
      Img.Palette.Clear;
    end
    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;
  end;
  Try
    { Note: it would be better to Fill the image palette in setupread instead of creating FPalette.
      FPalette is indeed useless but we cannot remove it since it's not private :\ }
    pallen:=0;
    if BFI.BitCount<=8 then
      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;
    if MinifyHeight < BFI.Height then FOutputHeight:= MinifyHeight else
    if WantedHeight <> 0 then FOutputHeight:= WantedHeight else
      FOutputHeight:= 0;

    percent:=0;
    percentAdd := 100 div BFI.Height;
    percentAcc:=BFI.Height div 2;
    percentAccAdd := 100 mod BFI.Height;
    percentMod:=BFI.Height;

    DeltaX:=-1; DeltaY:=-1;
    if TopDown then
    begin
      SourceRowDelta := 1;
      SourceRow := 0;
      SourceLastRow := BFI.Height-1;
    end else
    begin
      SourceRowDelta := -1;
      SourceRow := BFI.Height-1;
      SourceLastRow := 0;
    end;
    OutputRowDelta:= SourceRowDelta;
    if (OutputHeight <= 0) or (OutputHeight = BFI.Height) then
    begin
      SourceRowAdd := SourceRowDelta;
      SourceRowAcc := 0;
      SourceRowAccAdd := 0;
      SourceRowMod := 1;
      OutputRow := SourceRow;
      OutputLastRow := SourceLastRow;
      Img.SetSize(BFI.Width,BFI.Height);
    end else
    begin
      SourceRowAdd := (BFI.Height div OutputHeight)*SourceRowDelta;
      SourceRowAcc := OutputHeight div 2;
      SourceRowAccAdd := BFI.Height mod OutputHeight;
      SourceRowMod := OutputHeight;
      If TopDown then
      begin
        OutputRow := 0;
        OutputLastRow := OutputHeight-1;
      end
      else
      begin
        OutputRow := OutputHeight-1;
        OutputLastRow := 0;
      end;
      Img.SetSize(BFI.Width,OutputHeight);
    end;
    if Img is TBGRACustomBitmap then
      WriteScanlineProc := @WriteScanLineBGRA else
        WriteScanlineProc := @WriteScanLine;
    PrevSourceRow := SourceRow-SourceRowDelta;
    if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then InitReadBuffer(Stream,2048);
    FHasAlphaValues:= false;
    while SourceRow <> SourceLastRow+SourceRowDelta do
    begin
      while PrevSourceRow <> SourceRow do
      begin
        inc(PrevSourceRow, SourceRowDelta);
        if PrevSourceRow = SourceRow then
          ReadScanLine(PrevSourceRow,Stream)
        else
          SkipScanLine(PrevSourceRow,Stream);
      end;
      WriteScanLineProc(OutputRow,Img);
      if OutputRow = OutputLastRow then break;
      if not continue then exit;

      inc(OutputRow,OutputRowDelta);
      inc(SourceRow,SourceRowAdd);
      inc(SourceRowAcc,SourceRowAccAdd);
      if SourceRowAcc >= SourceRowMod then
      begin
       dec(SourceRowAcc,SourceRowMod);
       Inc(SourceRow,SourceRowDelta);
      end;

      prevPercent := percent;
      inc(percent,percentAdd);
      inc(percentAcc,percentAccAdd);
      if percentAcc>=percentMod then inc(percent);
      if percent<>prevPercent then Progress(psRunning,percent,false,Rect,'',continue);
    end;
    if not FHasAlphaValues and (TransparencyOption = toAuto) and (BFI.BitCount = 32) then
      MakeOpaque(Img);
    Progress(psEnding,100,false,Rect,'',continue);
  finally
    if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then CloseReadBuffer;
    FreeBufs;
  end;
end;

procedure TBGRAReaderBMP.ExpandRLE8ScanLine(Row : Integer; Stream : TStream);
var i,j,k : integer;
    b0, b1 : byte;
begin
  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:=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;

    b0 := GetNextBufferByte; b1 := GetNextBufferByte;
    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 }
             b0 := GetNextBufferByte; b1 := GetNextBufferByte;
             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) );
               for k := b1-1 downto 0 do
               Begin
                 LineBuf[i] := GetNextBufferByte;
                 Inc(i);
               end;
               { 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 GetNextBufferByte;
             end;
      end;
  end;
end;

procedure TBGRAReaderBMP.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;

      b0 := GetNextBufferByte; b1:= GetNextBufferByte;
      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 }
               b0 := GetNextBufferByte; b1:= GetNextBufferByte;
               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
                     b0 := GetNextBufferByte;
                     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 GetNextBufferByte;
               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 TBGRAReaderBMP.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 TBGRAReaderBMP.SkipScanLine(Row: Integer; Stream: TStream);
begin
  if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then ReadScanLine(Row,Stream)
  else Stream.Position := Stream.Position+ReadSize;
end;

procedure TBGRAReaderBMP.WriteScanLine(Row : Integer; Img : TFPCustomImage);

Var
  Column : Integer;
  c: TFPColor;
begin
  Case BFI.BitCount of
   1 :
     for Column:=0 to Img.Width-1 do
       if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
         img.Pixels[Column,Row]:=1
       else
         img.Pixels[Column,Row]:=0;
   4 :
      for Column:=0 to img.Width-1 do
        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.Pixels[Column,Row]:=LineBuf[Column];
   16 :
      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
        if BFI.Compression=BI_BITFIELDS then
          img.colors[Column,Row]:=ExpandColor(PLongWord(LineBuf)[Column])
        else
        begin
          if FTransparencyOption = toOpaque then
            img.colors[Column,Row]:=RGBToFPColor(PColorRGB(PColorRGBA(LineBuf)+Column)^)
          else
          begin
            c := RGBAToFPColor(PColorRGBA(LineBuf)[Column]);
            if c.alpha <> 0 then FHasAlphaValues:= true;
            img.colors[Column,Row]:= c;
          end;
        end;
    end;
end;

procedure TBGRAReaderBMP.WriteScanLineBGRA(Row: Integer; Img: TFPCustomImage);

Var
  Column : Integer;
  PDest: PBGRAPixel;
  PSrc: PByte;
begin
  PDest := TBGRACustomBitmap(Img).ScanLine[Row];
  Case BFI.BitCount of
   1 :
     for Column:=0 to Img.Width-1 do
     begin
       if ((LineBuf[Column div 8] shr (7-(Column and 7)) ) and 1) <> 0 then
         PDest^ := FBGRAPalette[1]
       else
         PDest^ := FBGRAPalette[0];
       inc(PDest);
     end;
   4 :
      for Column:=0 to img.Width-1 do
      begin
        PDest^ := FBGRAPalette[(LineBuf[Column div 2] shr (((Column+1) and 1)*4)) and $0f];
        inc(PDest);
      end;
   8 :
      for Column:=0 to img.Width-1 do
      begin
        PDest^ := FBGRAPalette[LineBuf[Column]];
        inc(PDest);
      end;
   16 :
      for Column:=0 to img.Width-1 do
      begin
        PDest^ :=ExpandColorBGRA(PWord(LineBuf)[Column]);
        inc(PDest);
      end;
   24 : begin
      PSrc := LineBuf;
      for Column:=0 to img.Width-1 do
      begin
        PDest^ := BGRA((Psrc+2)^,(Psrc+1)^,(Psrc)^);
        inc(PDest);
        inc(PSrc,3);
      end;
   end;
   32 :
     if BFI.Compression=BI_BITFIELDS then
     begin
      for Column:=0 to img.Width-1 do
      begin
        PDest^:=ExpandColorBGRA(PLongWord(LineBuf)[Column]);
        inc(PDest);
      end;
     end else
     if FTransparencyOption = toOpaque then
     begin
       if TBGRAPixel_RGBAOrder then
       begin
        PSrc := LineBuf;
        for Column:=0 to img.Width-1 do
        begin
          PDest^:= BGRA((PSrc)^,(PSrc+1)^,(PSrc+2)^);
          inc(PDest);
          Inc(PSrc,4);
        end;
       end
       else
       begin
        PSrc := LineBuf;
        for Column:=0 to img.Width-1 do
        begin
          PDest^:= BGRA((PSrc+2)^,(PSrc+1)^,(PSrc+1)^);
          inc(PDest);
          Inc(PSrc,4);
        end;
       end;
     end else
     begin
       if TBGRAPixel_RGBAOrder then
       begin
        PSrc := LineBuf;
        for Column:=0 to img.Width-1 do
        begin
          PDest^:= BGRA((PSrc)^,(PSrc+1)^,(PSrc+2)^,(PSrc+3)^);
          if PDest^.alpha <> 0 then FHasAlphaValues:= true;
          inc(PDest);
          Inc(PSrc,4);
        end;
       end
       else
       begin
         PSrc := LineBuf;
         for Column:=0 to img.Width-1 do
         begin
           PDest^ := PBGRAPixel(PSrc)^;
           if PDest^.alpha <> 0 then FHasAlphaValues:= true;
           inc(PDest);
           Inc(PSrc,4);
         end;
       end;
     end;
    end;
end;

function  TBGRAReaderBMP.InternalCheck (Stream:TStream) : boolean;

var
  {%H-}BFH:TBitMapFileHeader;
begin
  stream.Read({%H-}BFH,SizeOf(BFH));
  {$IFDEF ENDIAN_BIG}
  SwapBMPFileHeader(BFH);
  {$ENDIF}
  With BFH do
    Result:=(bfType=BMmagic); // Just check magic number
end;

procedure TBGRAReaderBMP.InitReadBuffer(AStream: TStream; ASize: integer);
begin
  setLength(FBuffer,ASize);
  FBufferSize := AStream.Read(FBuffer[0],ASize);
  FBufferPos := 0;
  FBufferStream := AStream;
end;

procedure TBGRAReaderBMP.CloseReadBuffer;
begin
  FBufferStream.Position:= FBufferStream.Position-FBufferSize+FBufferPos;
end;

function TBGRAReaderBMP.GetNextBufferByte: byte;
begin
  if FBufferPos < FBufferSize then
  begin
    result := FBuffer[FBufferPos];
    inc(FBufferPos);
  end else
  if FBufferSize = 0 then
    result := 0
  else
  begin
    FBufferSize := FBufferStream.Read(FBuffer[0],length(FBuffer));
    FBufferPos := 0;
    if FBufferPos < FBufferSize then
    begin
      result := FBuffer[FBufferPos];
      inc(FBufferPos);
    end else
      result := 0;
  end;
end;

procedure TBGRAReaderBMP.MakeOpaque(Img: TFPCustomImage);
var c: TFPColor;
  x,y: NativeInt;
begin
  if Img is TBGRACustomBitmap then
    TBGRACustomBitmap(Img).AlphaFill(255)
  else
    for y := 0 to Img.Height-1 do
      for x := 0 to Img.Width-1 do
      begin
        c := Img.Colors[x,y];
        c.alpha := alphaOpaque;
        Img.Colors[x,y] := c;
      end;
end;


initialization

  DefaultBGRAImageReader[ifBmp] := TBGRAReaderBMP;

end.
