{
    The original file before tweaking is:

    $Id: fpreadpng.pp,v 1.10 2003/10/19 21:09:51 luk Exp $
    This file is part of the Free Pascal run time library.
    Copyright (c) 2003 by the Free Pascal development team

    PNG 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.

 **********************************************************************

  Optimisations applied:
  - using "const" parameter for TColorData
  - direct pixel access with TBGRABitmap when possible
  - some fixes of hints and of initializations
  - vertical shrink option with MinifyHeight, OriginalHeight and VerticalShrinkFactor (useful for thumbnails)
 }
{$mode objfpc}{$h+}
unit BGRAReadPng;

interface

uses
  SysUtils,Classes, FPImage, FPImgCmn, PNGComn, ZStream, BGRABitmapTypes;

Type

  TSetPixelProc = procedure (x,y:integer; const CD : TColordata) of object;
  TConvertColorProc = function (const CD:TColorData) : TFPColor of object;
  TBGRAConvertColorProc = function (const CD:TColorData) : TBGRAPixel of object;
  THandleScanLineProc = procedure (const y : integer; const ScanLine : PByteArray) of object;

  { TBGRAReaderPNG }

  TBGRAReaderPNG = class (TBGRAImageReader)
    private

      FHeader : THeaderChunk;
      ZData : TMemoryStream;  // holds compressed data until all blocks are read
      Decompress : TDeCompressionStream; // decompresses the data
      FPltte : boolean;     // if palette is used
      FCountScanlines : EightLong; //Number of scanlines to process for each pass
      FScanLineLength : EightLong; //Length of scanline for each pass
      FCurrentPass : byte;
      ByteWidth : byte;          // number of bytes to read for pixel information
      BitsUsed : EightLong; // bitmasks to use to split a byte into smaller parts
      BitShift : byte;  // shift right to do of the bits extracted with BitsUsed for 1 element
      CountBitsUsed : byte;  // number of bit groups (1 pixel) per byte (when bytewidth = 1)
      //CFmt : TColorFormat; // format of the colors to convert from
      StartX,StartY, DeltaX,DeltaY, StartPass,EndPass : integer;  // number and format of passes
      FPalette : TFPPalette;
      FSetPixel : TSetPixelProc;
      FConvertColor : TConvertColorProc;
      FBGRAConvertColor : TBGRAConvertColorProc;
      FHandleScanLine: THandleScanLineProc;
      FVerticalShrinkMask: DWord;
      FVerticalShrinkShr: Integer;
      function GetOriginalHeight: integer;
      function GetOriginalWidth: integer;
      function GetVerticalShrinkFactor: integer;
      procedure ReadChunk;
      procedure HandleData;
      procedure HandleUnknown;
      function ColorGray1 (const CD:TColorData) : TFPColor;
      function ColorGray2 (const CD:TColorData) : TFPColor;
      function ColorGray4 (const CD:TColorData) : TFPColor;
      function ColorGray8 (const CD:TColorData) : TFPColor;
      function ColorGray16 (const CD:TColorData) : TFPColor;
      function ColorGrayAlpha8 (const CD:TColorData) : TFPColor;
      function ColorGrayAlpha16 (const CD:TColorData) : TFPColor;
      function ColorColor8 (const CD:TColorData) : TFPColor;
      function ColorColor16 (const CD:TColorData) : TFPColor;
      function ColorColorAlpha8 (const CD:TColorData) : TFPColor;
      function ColorColorAlpha16 (const CD:TColorData) : TFPColor;

      function BGRAColorGray1 (const CD:TColorData) : TBGRAPixel;
      function BGRAColorGray2 (const CD:TColorData) : TBGRAPixel;
      function BGRAColorGray4 (const CD:TColorData) : TBGRAPixel;
      function BGRAColorGray8 (const CD:TColorData) : TBGRAPixel;
      function BGRAColorGray16 (const CD:TColorData) : TBGRAPixel;
      function BGRAColorGrayAlpha8 (const CD:TColorData) : TBGRAPixel;
      function BGRAColorGrayAlpha16 (const CD:TColorData) : TBGRAPixel;
      function BGRAColorColor8 (const CD:TColorData) : TBGRAPixel;
      function BGRAColorColor16 (const CD:TColorData) : TBGRAPixel;
      function BGRAColorColorAlpha8 (const CD:TColorData) : TBGRAPixel;
      function BGRAColorColorAlpha16 (const CD:TColorData) : TBGRAPixel;
    protected
      Chunk : TChunk;
      UseTransparent, EndOfFile : boolean;
      TransparentDataValue : TColorData;
      UsingBitGroup : byte;
      DataIndex : longword;
      DataBytes : TColorData;
      procedure HandleChunk; virtual;
      procedure HandlePalette; virtual;
      procedure HandleAlpha; virtual;
      function CalcX (relX:integer) : integer;
      function CalcY (relY:integer) : integer;
      function CalcColor(const ScanLine : PByteArray): TColorData;
      procedure HandleScanLine (const y : integer; const ScanLine : PByteArray); virtual;
      procedure BGRAHandleScanLine(const y: integer; const ScanLine: PByteArray);
      procedure BGRAHandleScanLineTr(const y: integer; const ScanLine: PByteArray);
      procedure DoDecompress; virtual;
      procedure SetPalettePixel (x,y:integer; const CD : TColordata);
      procedure SetPalColPixel (x,y:integer; const CD : TColordata);
      procedure SetColorPixel (x,y:integer; const CD : TColordata);
      procedure SetColorTrPixel (x,y:integer; const CD : TColordata);
      procedure SetBGRAColorPixel (x,y:integer; const CD : TColordata);
      procedure SetBGRAColorTrPixel (x,y:integer; const CD : TColordata);
      function DecideSetPixel : TSetPixelProc; virtual;
      procedure InternalRead  ({%H-}Str:TStream; Img:TFPCustomImage); override;
      function  InternalCheck (Str:TStream) : boolean; override;
      //property ColorFormat : TColorformat read CFmt;
      property ConvertColor : TConvertColorProc read FConvertColor;
      property CurrentPass : byte read FCurrentPass;
      property Pltte : boolean read FPltte;
      property ThePalette : TFPPalette read FPalette;
      property Header : THeaderChunk read FHeader;
      property CountScanlines : EightLong read FCountScanlines;
      property ScanLineLength : EightLong read FScanLineLength;
    public
      MinifyHeight: integer;
      constructor create; override;
      destructor destroy; override;
      property VerticalShrinkFactor: integer read GetVerticalShrinkFactor;
      property OriginalWidth: integer read GetOriginalWidth;
      property OriginalHeight: integer read GetOriginalHeight;
      function GetQuickInfo(AStream: TStream): TQuickImageInfo; override;
      function GetBitmapDraft(AStream: TStream; {%H-}AMaxWidth, AMaxHeight: integer; out AOriginalWidth,AOriginalHeight: integer): TBGRACustomBitmap; override;
  end;

implementation

uses math;

const StartPoints : array[0..7, 0..1] of word =
         ((0,0),(0,0),(4,0),(0,4),(2,0),(0,2),(1,0),(0,1));
      Delta : array[0..7,0..1] of word =
         ((1,1),(8,8),(8,8),(4,8),(4,4),(2,4),(2,2),(1,2));
      BitsUsed1Depth : EightLong = ($80,$40,$20,$10,$08,$04,$02,$01);
      BitsUsed2Depth : EightLong = ($C0,$30,$0C,$03,0,0,0,0);
      BitsUsed4Depth : EightLong = ($F0,$0F,0,0,0,0,0,0);

constructor TBGRAReaderPNG.create;
begin
  inherited;
  chunk.acapacity := 0;
  chunk.data := nil;
  UseTransparent := False;
end;

destructor TBGRAReaderPNG.destroy;
begin
  with chunk do
    if acapacity > 0 then
      freemem (data);
  inherited;
end;

function TBGRAReaderPNG.GetQuickInfo(AStream: TStream): TQuickImageInfo;
const headerChunkSize = 13;
var
  {%H-}FileHeader : packed array[0..7] of byte;
  {%H-}ChunkHeader : TChunkHeader;
  {%H-}HeaderChunk : THeaderChunk;
begin
  fillchar({%H-}result, sizeof(result), 0);
  if AStream.Read({%H-}FileHeader, sizeof(FileHeader))<> sizeof(FileHeader) then exit;
  if QWord(FileHeader) <> QWord(PNGComn.Signature) then exit;
  if AStream.Read({%H-}ChunkHeader, sizeof(ChunkHeader))<> sizeof(ChunkHeader) then exit;
  if ChunkHeader.CType <> ChunkTypes[ctIHDR] then exit;
  if BEtoN(ChunkHeader.CLength) < headerChunkSize then exit;
  if AStream.Read({%H-}HeaderChunk, headerChunkSize) <> headerChunkSize then exit;
  result.width:= BEtoN(HeaderChunk.Width);
  result.height:= BEtoN(HeaderChunk.height);
  case HeaderChunk.ColorType and 3 of
    0,3: {grayscale, palette}
      if HeaderChunk.BitDepth > 8 then
        result.colorDepth := 8
      else
        result.colorDepth := HeaderChunk.BitDepth;

    2: {color} result.colorDepth := HeaderChunk.BitDepth*3;
  end;
  if (HeaderChunk.ColorType and 4) = 4 then
    result.alphaDepth := HeaderChunk.BitDepth
  else
    result.alphaDepth := 0;
end;

function TBGRAReaderPNG.GetBitmapDraft(AStream: TStream; AMaxWidth,
  AMaxHeight: integer; out AOriginalWidth, AOriginalHeight: integer): TBGRACustomBitmap;
var
  png: TBGRAReaderPNG;
begin
  png:= TBGRAReaderPNG.Create;
  result := BGRABitmapFactory.Create;
  try
    png.MinifyHeight := AMaxHeight;
    result.LoadFromStream(AStream, png);
    AOriginalWidth:= result.Width;
    AOriginalHeight:= png.OriginalHeight;
  finally
    png.Free;
  end;
end;

procedure TBGRAReaderPNG.ReadChunk;
var {%H-}ChunkHeader : TChunkHeader;
    readCRC : longword;
    l : longword;
begin
  TheStream.Read ({%H-}ChunkHeader,sizeof(ChunkHeader));
  with chunk do
    begin
    // chunk header
    with ChunkHeader do
      begin
      {$IFDEF ENDIAN_LITTLE}
      alength := swap(CLength);
      {$ELSE}
      alength := CLength;
      {$ENDIF}
      ReadType := CType;
      end;
    aType := low(TChunkTypes);
    while (aType < high(TChunkTypes)) and (ChunkTypes[aType] <> ReadType) do
      inc (aType);
    if alength > MaxChunkLength then
      raise PNGImageException.Create ('Invalid chunklength');
    if alength > acapacity then
      begin
      if acapacity > 0 then
        freemem (data);
      GetMem (data, alength);
      acapacity := alength;
      end;
    l := TheStream.read (data^, alength);
    if l <> alength then
      raise PNGImageException.Create ('Chunk length exceeds stream length');
    readCRC := 0;
    TheStream.Read (readCRC, sizeof(ReadCRC));
    l := CalculateCRC (All1Bits, ReadType, sizeOf(ReadType));
    l := CalculateCRC (l, data^, alength);
    {$IFDEF ENDIAN_LITTLE}
    l := swap(l xor All1Bits);
    {$ELSE}
    l := l xor All1Bits;
    {$ENDIF}
    if ReadCRC <> l then
      raise PNGImageException.Create ('CRC check failed');
    end;
end;

function TBGRAReaderPNG.GetVerticalShrinkFactor: integer;
begin
  result := 1 shl FVerticalShrinkShr;
end;

function TBGRAReaderPNG.GetOriginalHeight: integer;
begin
  result := Header.height;
end;

function TBGRAReaderPNG.GetOriginalWidth: integer;
begin
  result := header.Width;
end;

procedure TBGRAReaderPNG.HandleData;
var OldSize : longword;
begin
  OldSize := ZData.size;
  ZData.Size := OldSize;
  ZData.Size := ZData.Size + Chunk.aLength;
  ZData.Write (chunk.Data^, chunk.aLength);
end;

procedure TBGRAReaderPNG.HandleAlpha;
  procedure PaletteAlpha;
    var r : integer;
        a : word;
        c : TFPColor;
    begin
      with chunk do
        begin
        if alength > longword(ThePalette.count) then
          raise PNGImageException.create ('To much alpha values for palette');
        for r := 0 to alength-1 do
          begin
          c := ThePalette[r];
          a := data^[r];
          c.alpha := (a shl 8) + a;
          ThePalette[r] := c;
          end;
        end;
    end;
  procedure TransparentGray;
    var {%H-}a : word;
    begin
      move (chunk.data^[0], {%H-}a, 2);
      {$IFDEF ENDIAN_LITTLE}
      a := swap (a);
      {$ENDIF}
      TransparentDataValue := a;
      UseTransparent := True;
    end;
  procedure TransparentColor;
    var d : byte;
        {%H-}r,{%H-}g,{%H-}b : word;
        a : TColorData;
    begin
      with chunk do
        begin
        move (data^[0], {%H-}r, 2);
        move (data^[2], {%H-}g, 2);
        move (data^[4], {%H-}b, 2);
        end;
      {$IFDEF ENDIAN_LITTLE}
      r := swap (r);
      g := swap (g);
      b := swap (b);
      {$ENDIF}
      d := header.bitdepth;
      a := (TColorData(b) shl d) shl d;
      a := a + (TColorData(g) shl d) + r;
      TransparentDataValue := a;
      UseTransparent := True;
    end;
begin
  case header.ColorType of
    3 : PaletteAlpha;
    0 : TransparentGray;
    2 : TransparentColor;
  end;
end;

procedure TBGRAReaderPNG.HandlePalette;
var r : longword;
    c : TFPColor;
    t : word;
begin
  if header.colortype = 3 then
    with chunk do
      begin
      if TheImage.UsePalette then
        FPalette := TheImage.Palette
      else
        FPalette := TFPPalette.Create(0);
      c.Alpha := AlphaOpaque;
      if (aLength mod 3) > 0 then
        raise PNGImageException.Create ('Impossible length for PLTE-chunk');
      r := 0;
      ThePalette.count := 0;
      while r < alength do
        begin
        t := data^[r];
        c.red := t + (t shl 8);
        inc (r);
        t := data^[r];
        c.green := t + (t shl 8);
        inc (r);
        t := data^[r];
        c.blue := t + (t shl 8);
        inc (r);
        ThePalette.Add (c);
        end;
      end;
end;

procedure TBGRAReaderPNG.SetPalettePixel (x,y:integer; const CD : TColordata);
begin  // both PNG and palette have palette
  TheImage.Pixels[x,y] := CD;
end;

procedure TBGRAReaderPNG.SetPalColPixel (x,y:integer; const CD : TColordata);
begin  // PNG with palette, Img without
  TheImage.Colors[x,y] := ThePalette[CD];
end;

procedure TBGRAReaderPNG.SetColorPixel (x,y:integer; const CD : TColordata);
var c : TFPColor;
begin  // both PNG and Img work without palette, and no transparency colordata
  // c := ConvertColor (CD,CFmt);
  c := ConvertColor (CD);
  TheImage.Colors[x,y] := c;
end;

procedure TBGRAReaderPNG.SetColorTrPixel (x,y:integer; const CD : TColordata);
var c : TFPColor;
begin  // both PNG and Img work without palette, and there is a transparency colordata
  //c := ConvertColor (CD,CFmt);
  c := ConvertColor (CD);
  if TransparentDataValue = CD then
    c.alpha := alphaTransparent;
  TheImage.Colors[x,y] := c;
end;

procedure TBGRAReaderPNG.SetBGRAColorPixel(x, y: integer; const CD: TColordata);
var c: TBGRAPixel;
begin
  c := FBGRAConvertColor(CD);
  if c.alpha = 0 then TBGRACustomBitmap(TheImage).SetPixel(x,y,BGRAPixelTransparent)
  else TBGRACustomBitmap(TheImage).SetPixel(x,y,c);
end;

procedure TBGRAReaderPNG.SetBGRAColorTrPixel(x, y: integer; const CD: TColordata);
var c: TBGRAPixel;
begin
  if TransparentDataValue = CD then
    TBGRACustomBitmap(TheImage).SetPixel(x,y,BGRAPixelTransparent) else
  begin
    c := FBGRAConvertColor(CD);
    if c.alpha = 0 then TBGRACustomBitmap(TheImage).SetPixel(x,y,BGRAPixelTransparent)
    else TBGRACustomBitmap(TheImage).SetPixel(x,y,c);
  end;
end;

function TBGRAReaderPNG.DecideSetPixel : TSetPixelProc;
begin
  if Pltte then
    if TheImage.UsePalette then
      result := @SetPalettePixel
    else
      result := @SetPalColPixel
  else
    if UseTransparent then
    begin
      if TheImage is TBGRACustomBitmap then
        result := @SetBGRAColorTrPixel
      else
        result := @SetColorTrPixel
    end
    else
    begin
      if TheImage is TBGRACustomBitmap then
        result := @SetBGRAColorPixel
      else
        result := @SetColorPixel
    end;
end;

function TBGRAReaderPNG.CalcX (relX:integer) : integer;
begin
  result := StartX + (relX * deltaX);
end;

function TBGRAReaderPNG.CalcY (relY:integer) : integer;
begin
  result := StartY + (relY * deltaY);
end;

function TBGRAReaderPNG.CalcColor(const ScanLine : PByteArray): TColorData;
var cd : longword;
    r : word;
    p : pbyte;
begin
  if UsingBitGroup = 0 then
    begin
    Databytes := 0;
    if Header.BitDepth = 16 then
      begin
       p := @Databytes;
       for r:=0 to bytewidth shr 1 - 1 do
       begin
        p^ := ScanLine^[Dataindex+(r shl 1)+1];
        (p+1)^ := ScanLine^[Dataindex+(r shl 1)];
        inc(p,2);
       end;
      end
    else move (ScanLine^[DataIndex], Databytes, bytewidth);
    {$IFDEF ENDIAN_BIG}
    Databytes:=swap(Databytes);
    {$ENDIF}
    inc (DataIndex,bytewidth);
    end;
  if bytewidth = 1 then
    begin
    cd := (Databytes and BitsUsed[UsingBitGroup]);
    result := cd shr ((CountBitsUsed-UsingBitGroup-1) * BitShift);
    inc (UsingBitgroup);
    if UsingBitGroup >= CountBitsUsed then
      UsingBitGroup := 0;
    end
  else
    result := Databytes;
end;

procedure TBGRAReaderPNG.HandleScanLine (const y : integer; const ScanLine : PByteArray);
var x, rx : integer;
    c : TColorData;
begin
  UsingBitGroup := 0;
  DataIndex := 0;
  X := StartX;
  if (UsingBitGroup = 0) and (Header.BitDepth <> 16) then
    case ByteWidth of
      1: if BitsUsed[0] = $ff then
         begin
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             FSetPixel (x,y,ScanLine^[DataIndex]);
             Inc(X, deltaX);
             inc(DataIndex);
           end;
           exit;
         end;
      2: begin
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             {$IFDEF ENDIAN_BIG}
             FSetPixel (x,y,swap(PWord(@ScanLine^[DataIndex])^));
             {$ELSE}
             FSetPixel (x,y,PWord(@ScanLine^[DataIndex])^);
             {$ENDIF}
             Inc(X, deltaX);
             inc(DataIndex,2);
           end;
           exit;
         end;
      4: begin
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             {$IFDEF ENDIAN_BIG}
             FSetPixel (x,y,swap(PDWord(@ScanLine^[DataIndex])^));
             {$ELSE}
             FSetPixel (x,y,PDWord(@ScanLine^[DataIndex])^);
             {$ENDIF}
             Inc(X, deltaX);
             inc(DataIndex,4);
           end;
           exit;
         end;
      8: begin
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             {$IFDEF ENDIAN_BIG}
             FSetPixel (x,y,swap(PQWord(@ScanLine^[DataIndex])^));
             {$ELSE}
             FSetPixel (x,y,PQWord(@ScanLine^[DataIndex])^);
             {$ENDIF}
             Inc(X, deltaX);
             inc(DataIndex,8);
           end;
           exit;
         end;
    end;

  for rx := 0 to ScanlineLength[CurrentPass]-1 do
    begin
    c := CalcColor(ScanLine);
    FSetPixel (x,y,c);
    Inc(X, deltaX);
    end
end;

procedure TBGRAReaderPNG.BGRAHandleScanLine (const y : integer; const ScanLine : PByteArray);
var x, rx : integer;
    c : TColorData;
    pdest: PBGRAPixel;
begin
  UsingBitGroup := 0;
  DataIndex := 0;
  {$PUSH}{$RANGECHECKS OFF} //because PByteArray is limited to 32767
  if (UsingBitGroup = 0) and (Header.BitDepth <> 16) then
    case ByteWidth of
      1: if BitsUsed[0] = $ff then
         begin
           pdest := TBGRACustomBitmap(TheImage).ScanLine[y]+StartX;
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             pdest^ := FBGRAConvertColor(ScanLine^[DataIndex]);
             if pdest^.alpha = 0 then pdest^ := BGRAPixelTransparent;
             Inc(pdest, deltaX);
             inc(DataIndex);
           end;
           exit;
         end;
      2: begin
           pdest := TBGRACustomBitmap(TheImage).ScanLine[y]+StartX;
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             pdest^ := FBGRAConvertColor(
             {$IFDEF ENDIAN_BIG}
             swap(PWord(@ScanLine^[DataIndex])^)
             {$ELSE}
             PWord(@ScanLine^[DataIndex])^
             {$ENDIF} );
             if pdest^.alpha = 0 then pdest^ := BGRAPixelTransparent;
             Inc(pdest, deltaX);
             inc(DataIndex,2);
           end;
           exit;
         end;
      4: begin
           pdest := TBGRACustomBitmap(TheImage).ScanLine[y]+StartX;
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             pdest^ := FBGRAConvertColor(
             {$IFDEF ENDIAN_BIG}
             swap(PDWord(@ScanLine^[DataIndex])^)
             {$ELSE}
             PDWord(@ScanLine^[DataIndex])^
             {$ENDIF}  );
             if pdest^.alpha = 0 then pdest^ := BGRAPixelTransparent;
             Inc(pdest, deltaX);
             inc(DataIndex,4);
           end;
           exit;
         end;
      8: begin
           pdest := TBGRACustomBitmap(TheImage).ScanLine[y]+StartX;
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             pdest^ := FBGRAConvertColor(
             {$IFDEF ENDIAN_BIG}
             swap(PQWord(@ScanLine^[DataIndex])^)
             {$ELSE}
             PQWord(@ScanLine^[DataIndex])^
             {$ENDIF}  );
             if pdest^.alpha = 0 then pdest^ := BGRAPixelTransparent;
             Inc(pdest, deltaX);
             inc(DataIndex,8);
           end;
           exit;
         end;
    end;
  {$POP}

  X := StartX;
  for rx := 0 to ScanlineLength[CurrentPass]-1 do
    begin
    c := CalcColor(ScanLine);
    FSetPixel (x,y,c);
    Inc(X, deltaX);
    end
end;

procedure TBGRAReaderPNG.BGRAHandleScanLineTr(const y: integer;
  const ScanLine: PByteArray);
var x, rx : integer;
    c : TColorData;
    pdest: PBGRAPixel;
begin
  UsingBitGroup := 0;
  DataIndex := 0;
  if (UsingBitGroup = 0) and (Header.BitDepth <> 16) then
    case ByteWidth of
      1: if BitsUsed[0] = $ff then
         begin
           pdest := TBGRACustomBitmap(TheImage).ScanLine[y]+StartX;
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             c := ScanLine^[DataIndex];
             if c = TransparentDataValue then
               pdest^ := BGRAPixelTransparent else
               begin
                 pdest^ := FBGRAConvertColor(c);
                 if pdest^.alpha = 0 then pdest^ := BGRAPixelTransparent;
             end;
             Inc(pdest, deltaX);
             inc(DataIndex);
           end;
           exit;
         end;
      2: begin
           pdest := TBGRACustomBitmap(TheImage).ScanLine[y]+StartX;
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             c :=
             {$IFDEF ENDIAN_BIG}
             swap(PWord(@ScanLine^[DataIndex])^)
             {$ELSE}
             PWord(@ScanLine^[DataIndex])^
             {$ENDIF} ;
             if c = TransparentDataValue then
               pdest^ := BGRAPixelTransparent else
               begin
                 pdest^ := FBGRAConvertColor(c);
                 if pdest^.alpha = 0 then pdest^ := BGRAPixelTransparent;
               end;
             Inc(pdest, deltaX);
             inc(DataIndex,2);
           end;
           exit;
         end;
      4: begin
           pdest := TBGRACustomBitmap(TheImage).ScanLine[y]+StartX;
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             c :=
             {$IFDEF ENDIAN_BIG}
             swap(PDWord(@ScanLine^[DataIndex])^)
             {$ELSE}
             PDWord(@ScanLine^[DataIndex])^
             {$ENDIF}  ;
             if c = TransparentDataValue then
               pdest^ := BGRAPixelTransparent else
               begin
                 pdest^ := FBGRAConvertColor(c);
                 if pdest^.alpha = 0 then pdest^ := BGRAPixelTransparent;
               end;
             Inc(pdest, deltaX);
             inc(DataIndex,4);
           end;
           exit;
         end;
      8: begin
           pdest := TBGRACustomBitmap(TheImage).ScanLine[y]+StartX;
           for rx := 0 to ScanlineLength[CurrentPass]-1 do
           begin
             c :=
             {$IFDEF ENDIAN_BIG}
             swap(PQWord(@ScanLine^[DataIndex])^)
             {$ELSE}
             PQWord(@ScanLine^[DataIndex])^
             {$ENDIF}  ;
             if c = TransparentDataValue then
               pdest^ := BGRAPixelTransparent else
               begin
                 pdest^ := FBGRAConvertColor(c);
                 if pdest^.alpha = 0 then pdest^ := BGRAPixelTransparent;
               end;
             Inc(pdest, deltaX);
             inc(DataIndex,8);
           end;
           exit;
         end;
    end;

  X := StartX;
  for rx := 0 to ScanlineLength[CurrentPass]-1 do
    begin
    c := CalcColor(ScanLine);
    FSetPixel (x,y,c);
    Inc(X, deltaX);
    end
end;

function TBGRAReaderPNG.ColorGray1(const CD: TColorData): TFPColor;
begin
  if CD = 0 then
    result := colBlack
  else
    result := colWhite;
end;

function TBGRAReaderPNG.ColorGray2(const CD: TColorData): TFPColor;
var c : NativeUint;
begin
  c := CD and 3;
  c := c + (c shl 2);
  c := c + (c shl 4);
  c := c + (c shl 8);
  with result do
    begin
    red := c;
    green := c;
    blue := c;
    alpha := alphaOpaque;
    end;
end;

function TBGRAReaderPNG.ColorGray4(const CD: TColorData): TFPColor;
var c : NativeUint;
begin
  c := CD and $F;
  c := c + (c shl 4);
  c := c + (c shl 8);
  with result do
    begin
    red := c;
    green := c;
    blue := c;
    alpha := alphaOpaque;
    end;
end;

function TBGRAReaderPNG.ColorGray8(const CD: TColorData): TFPColor;
var c : NativeUint;
begin
  c := CD and $FF;
  c := c + (c shl 8);
  with result do
    begin
    red := c;
    green := c;
    blue := c;
    alpha := alphaOpaque;
    end;
end;

function TBGRAReaderPNG.ColorGray16(const CD: TColorData): TFPColor;
var c : NativeUint;
begin
  c := CD and $FFFF;
  with result do
    begin
    red := c;
    green := c;
    blue := c;
    alpha := alphaOpaque;
    end;
end;

function TBGRAReaderPNG.ColorGrayAlpha8 (const CD:TColorData) : TFPColor;
var c : NativeUint;
begin
  c := CD and $00FF;
  c := c + (c shl 8);
  with result do
    begin
    red := c;
    green := c;
    blue := c;
    c := CD and $FF00;
    alpha := c + (c shr 8);
    end;
end;

function TBGRAReaderPNG.ColorGrayAlpha16 (const CD:TColorData) : TFPColor;
var c : NativeUint;
begin
  c := CD and $FFFF;
  with result do
    begin
    red := c;
    green := c;
    blue := c;
    alpha := (CD shr 16) and $FFFF;
    end;
end;

function TBGRAReaderPNG.ColorColor8 (const CD:TColorData) : TFPColor;
var c : NativeUint;
begin
  with result do
    begin
    c := CD and $FF;
    red := c + (c shl 8);
    c := (CD shr 8) and $FF;
    green := c + (c shl 8);
    c := (CD shr 16) and $FF;
    blue := c + (c shl 8);
    alpha := alphaOpaque;
    end;
end;

function TBGRAReaderPNG.ColorColor16 (const CD:TColorData) : TFPColor;
begin
  with result do
    begin
    red := CD and $FFFF;
    green := (CD shr 16) and $FFFF;
    blue := (CD shr 32) and $FFFF;
    alpha := alphaOpaque;
    end;
end;

function TBGRAReaderPNG.ColorColorAlpha8 (const CD:TColorData) : TFPColor;
var c : NativeUint;
begin
  with result do
    begin
    c := CD and $FF;
    red := c + (c shl 8);
    c := (CD shr 8) and $FF;
    green := c + (c shl 8);
    c := (CD shr 16) and $FF;
    blue := c + (c shl 8);
    c := (CD shr 24) and $FF;
    alpha := c + (c shl 8);
    end;
end;

function TBGRAReaderPNG.ColorColorAlpha16 (const CD:TColorData) : TFPColor;
begin
  with result do
    begin
    red := CD and $FFFF;
    green := (CD shr 16) and $FFFF;
    blue := (CD shr 32) and $FFFF;
    alpha := (CD shr 48) and $FFFF;
    end;
end;

function TBGRAReaderPNG.BGRAColorGray1(const CD: TColorData): TBGRAPixel;
begin
  if CD = 0 then
    result := BGRABlack
  else
    result := BGRAWhite;
end;

function TBGRAReaderPNG.BGRAColorGray2(const CD: TColorData): TBGRAPixel;
var c : NativeUint;
begin
  c := CD and 3;
  c := c + (c shl 2);
  c := c + (c shl 4);
  result := BGRA(c,c,c);
end;

function TBGRAReaderPNG.BGRAColorGray4(const CD: TColorData): TBGRAPixel;
var c : NativeUint;
begin
  c := CD and $F;
  c := c + (c shl 4);
  result := BGRA(c,c,c);
end;

function TBGRAReaderPNG.BGRAColorGray8(const CD: TColorData): TBGRAPixel;
var c : NativeUint;
begin
  c := CD and $FF;
  result := BGRA(c,c,c);
end;

function TBGRAReaderPNG.BGRAColorGray16(const CD: TColorData): TBGRAPixel;
var c : NativeUint;
begin
  c := (CD shr 8) and $FF;
  result := BGRA(c,c,c);
end;

function TBGRAReaderPNG.BGRAColorGrayAlpha8(const CD: TColorData): TBGRAPixel;
var c : NativeUint;
begin
  c := CD and $00FF;
  result := BGRA(c,c,c,(CD shr 8) and $FF);
end;

function TBGRAReaderPNG.BGRAColorGrayAlpha16(const CD: TColorData): TBGRAPixel;
var c : NativeUint;
begin
  c := (CD shr 8) and $FF;
  result := BGRA(c,c,c,(CD shr 24) and $FF);
end;

function TBGRAReaderPNG.BGRAColorColor8(const CD: TColorData): TBGRAPixel;
var temp: DWord;
begin
  temp := CD;
  result := BGRA(temp and $ff, (temp shr 8) and $ff, (temp shr 16) and $ff);
end;

function TBGRAReaderPNG.BGRAColorColor16(const CD: TColorData): TBGRAPixel;
begin
  result := BGRA(CD shr 8 and $FF,(CD shr 24) and $FF,(CD shr 40) and $FF);
end;

function TBGRAReaderPNG.BGRAColorColorAlpha8(const CD: TColorData): TBGRAPixel;
var temp: DWord;
begin
  temp := CD;
  result := BGRA(temp and $ff, (temp shr 8) and $ff, (temp shr 16) and $ff, temp shr 24);
end;

function TBGRAReaderPNG.BGRAColorColorAlpha16(const CD: TColorData): TBGRAPixel;
begin
  result := BGRA(CD shr 8 and $FF,(CD shr 24) and $FF,(CD shr 40) and $FF, CD shr 56);
end;

procedure TBGRAReaderPNG.DoDecompress;

  procedure initVars;
  var r,d : integer;
  begin
    with Header do
      begin
      if interlace=0 then
        begin
        StartPass := 0;
        EndPass := 0;
        FCountScanlines[0] := Height;
        FScanLineLength[0] := Width;
        end
      else
        begin
        StartPass := 1;
        EndPass := 7;
        for r := 1 to 7 do
          begin
          d := Height div delta[r,1];
          if (height mod delta[r,1]) > startpoints[r,1] then
            inc (d);
          FCountScanlines[r] := d;
          d := width div delta[r,0];
          if (width mod delta[r,0]) > startpoints[r,0] then
            inc (d);
          FScanLineLength[r] := d;
          end;
        end;
      Fpltte := (ColorType = 3);
      case colortype of
        0 : case Bitdepth of
              1  : begin
                   FConvertColor := @ColorGray1; //CFmt := cfMono;
                   FBGRAConvertColor := @BGRAColorGray1; //CFmt := cfMono;
                   ByteWidth := 1;
                   end;
              2  : begin
                   FConvertColor := @ColorGray2; //CFmt := cfGray2;
                   FBGRAConvertColor := @BGRAColorGray2; //CFmt := cfGray2;
                   ByteWidth := 1;
                   end;
              4  : begin
                   FConvertColor := @ColorGray4; //CFmt := cfGray4;
                   FBGRAConvertColor := @BGRAColorGray4; //CFmt := cfGray4;
                   ByteWidth := 1;
                   end;
              8  : begin
                   FConvertColor := @ColorGray8; //CFmt := cfGray8;
                   FBGRAConvertColor := @BGRAColorGray8; //CFmt := cfGray8;
                   ByteWidth := 1;
                   end;
              16 : begin
                   FConvertColor := @ColorGray16; //CFmt := cfGray16;
                   FBGRAConvertColor := @BGRAColorGray16; //CFmt := cfGray16;
                   ByteWidth := 2;
                   end;
            end;
        2 : if BitDepth = 8 then
              begin
              FConvertColor := @ColorColor8; //CFmt := cfBGR24
              FBGRAConvertColor := @BGRAColorColor8; //CFmt := cfBGR24
              ByteWidth := 3;
              end
            else
              begin
              FConvertColor := @ColorColor16; //CFmt := cfBGR48;
              FBGRAConvertColor := @BGRAColorColor16; //CFmt := cfBGR48;
              ByteWidth := 6;
              end;
        3 : if BitDepth = 16 then
              ByteWidth := 2
            else
              ByteWidth := 1;
        4 : if BitDepth = 8 then
              begin
              FConvertColor := @ColorGrayAlpha8; //CFmt := cfGrayA16
              FBGRAConvertColor := @BGRAColorGrayAlpha8; //CFmt := cfGrayA16
              ByteWidth := 2;
              end
            else
              begin
              FConvertColor := @ColorGrayAlpha16; //CFmt := cfGrayA32;
              FBGRAConvertColor := @BGRAColorGrayAlpha16; //CFmt := cfGrayA32;
              ByteWidth := 4;
              end;
        6 : if BitDepth = 8 then
              begin
              FConvertColor := @ColorColorAlpha8; //CFmt := cfABGR32
              FBGRAConvertColor := @BGRAColorColorAlpha8; //CFmt := cfABGR32
              ByteWidth := 4;
              end
            else
              begin
              FConvertColor := @ColorColorAlpha16; //CFmt := cfABGR64;
              FBGRAConvertColor := @BGRAColorColorAlpha16; //CFmt := cfABGR64;
              ByteWidth := 8;
              end;
      end;
      //ByteWidth := BytesNeeded[CFmt];
      case BitDepth of
        1 : begin
            CountBitsUsed := 8;
            BitShift := 1;
            BitsUsed := BitsUsed1Depth;
            end;
        2 : begin
            CountBitsUsed := 4;
            BitShift := 2;
            BitsUsed := BitsUsed2Depth;
            end;
        4 : begin
            CountBitsUsed := 2;
            BitShift := 4;
            BitsUsed := BitsUsed4Depth;
            end;
        8 : begin
            CountBitsUsed := 1;
            BitShift := 0;
            BitsUsed[0] := $FF;
            end;
        end;
      end;
  end;

  procedure FilterSub(p: PByte; Count: NativeInt; bw: NativeInt);
  begin
    inc(p,bw);
    dec(Count,bw);
    while Count > 0 do
    begin
      {$push}{$r-}
      p^ += (p-bw)^;
      {$pop}
      inc(p);
      dec(Count);
    end;
  end;

  procedure FilterUp(p,pPrev: PByte; Count: NativeUInt);
  var Count4: NativeInt;
  begin
    Count4 := Count shr 2;
    dec(Count, Count4 shl 2);
    while Count4 > 0 do
    begin
      {$push}{$r-}{$q-}
      PDWord(p)^ := (((PDWord(pPrev)^ and $00FF00FF) + (PDWord(p)^ and $00FF00FF)) and $00FF00FF)
        or (((PDWord(pPrev)^ and $FF00FF00) + (PDWord(p)^ and $FF00FF00)) and $FF00FF00);
      {$pop}
      inc(p,4);
      inc(pPrev,4);
      dec(Count4);
    end;
    while Count > 0 do
    begin
      {$push}{$r-}
      p^ += pPrev^;
      {$pop}

      inc(p);
      inc(pPrev);
      dec(Count);
    end;
  end;

  procedure FilterAverage(p,pPrev: PByte; Count: NativeUInt; bw: NativeInt);
  var CountBW: NativeInt;
  begin
    CountBW := bw;
    dec(Count,CountBW);
    while CountBW > 0 do
    begin
      {$push}{$r-}
      p^ += pPrev^ shr 1;
      {$pop}
      inc(p);
      inc(pPrev);
      dec(CountBW);
    end;

    while Count > 0 do
    begin
      {$push}{$r-}
      p^ += (pPrev^+(p-bw)^) shr 1;
      {$pop}
      inc(p);
      inc(pPrev);
      dec(Count);
    end;
  end;

  procedure FilterPaeth(p,pPrev: PByte; Count: NativeUInt; bw: NativeInt);
  var
    rx, dl, dp, dlp : NativeInt;
    diag,left: NativeUInt;
  begin
    for rx := 0 to bw-1 do
    begin
      {$push}{$r-}
      p^ += pPrev^;
      {$pop}
      inc(p);
      inc(pPrev);
    end;
    dec(Count,bw);
    while Count > 0 do
    begin
      diag := (pPrev-bw)^;
      left := (p - bw)^;
      dl := pPrev^ - NativeInt(diag);
      dp := NativeInt(left) - NativeInt(diag);
      dlp := abs(dl+dp);
      if dl < 0 then dl := -dl;
      if dp < 0 then dp := -dp;
      {$push}{$r-}
      if dp <= dlp then
      begin
        if dl <= dp then
          p^ += left
        else
          p^ += pPrev^
      end
      else
      if dl <= dlp then
        p^ += left
      else
        p^ += diag;
      {$pop}
      inc(p);
      inc(pPrev);
      dec(Count);
     end;
  end;

  procedure Decode;
  var y, rp, ry, l : NativeInt;
      lf : byte;
      switchLine, currentLine, previousLine : pByteArray;
  begin
    FSetPixel := DecideSetPixel;
    if not Pltte and (TheImage is TBGRACustomBitmap) then
    begin
      if UseTransparent then
        FHandleScanLine := @BGRAHandleScanLineTr
      else
        FHandleScanLine := @BGRAHandleScanLine;
    end else
      FHandleScanLine := @HandleScanLine;
    for rp := StartPass to EndPass do
      begin
      FCurrentPass := rp;
      StartX := StartPoints[rp,0];
      StartY := StartPoints[rp,1];
      DeltaX := Delta[rp,0];
      DeltaY := Delta[rp,1];
      if bytewidth = 1 then
        begin
        l := (ScanLineLength[rp] div CountBitsUsed);
        if (ScanLineLength[rp] mod CountBitsUsed) > 0 then
          inc (l);
        end
      else
        l := ScanLineLength[rp]*ByteWidth;
      if (l>0) then
        begin
        GetMem (previousLine, l);
        GetMem (currentLine, l);
        fillchar (currentLine^,l,0);
        try
          for ry := 0 to CountScanlines[rp]-1 do
            begin
            switchLine := currentLine;
            currentLine := previousLine;
            previousLine := switchLine;
            Y := StartY + (ry * deltaY);
            lf := 0;
            Decompress.Read (lf, sizeof(lf));
            Decompress.Read (currentLine^, l);

            case lf of
              1: FilterSub(PByte(currentLine), l, ByteWidth);
              2: FilterUp(PByte(currentLine), PByte(previousLine), l);
              3: FilterAverage(PByte(currentLine), PByte(previousLine), l, ByteWidth);
              4: FilterPaeth(PByte(currentLine), PByte(previousLine), l, ByteWidth);
            end;

            if FVerticalShrinkShr <> 0 then
              begin
                if (y and FVerticalShrinkMask) = 0 then
                  FHandleScanLine (y shr FVerticalShrinkShr, currentLine);
              end else
                FHandleScanLine (y, currentLine);
            end;
        finally
          freemem (previousLine);
          freemem (currentLine);
        end;
        end;
      end;
  end;

begin
  InitVars;
  DeCode;
end;

procedure TBGRAReaderPNG.HandleChunk;
begin
  case chunk.AType of
    ctIHDR : raise PNGImageException.Create ('Second IHDR chunk found');
    ctPLTE : HandlePalette;
    ctIDAT : HandleData;
    ctIEND : EndOfFile := True;
    cttRNS : HandleAlpha;
    else HandleUnknown;
  end;
end;

procedure TBGRAReaderPNG.HandleUnknown;
begin
  if (chunk.readtype[0] in ['A'..'Z']) then
    raise PNGImageException.Create('Critical chunk '+chunk.readtype+' not recognized');
end;

procedure TBGRAReaderPNG.InternalRead (Str:TStream; Img:TFPCustomImage);
var outputHeight: integer;
begin
  {$ifdef FPC_Debug_Image}
  if Str<>TheStream then
    writeln('WARNING: TBGRAReaderPNG.InternalRead Str<>TheStream');
  {$endif}
  with Header do
  begin
    FVerticalShrinkShr := 0;
    FVerticalShrinkMask := 0;
    outputHeight := Height;
    if MinifyHeight <> 0 then
      begin
        while (outputHeight shr 1 >= MinifyHeight) and (FVerticalShrinkShr < 8) do
          begin
            outputHeight:= outputHeight shr 1;
            Inc(FVerticalShrinkShr);
          end;
        FVerticalShrinkMask:= (1 shl FVerticalShrinkShr)-1;
        outputHeight := (Height+FVerticalShrinkMask) shr FVerticalShrinkShr;
      end;
    Img.SetSize (Width, outputHeight);
  end;
  ZData := TMemoryStream.Create;
  try
    EndOfFile := false;
    while not EndOfFile do
      begin
      ReadChunk;
      HandleChunk;
      end;
    ZData.position:=0;
    Decompress := TDecompressionStream.Create (ZData);
    try
      DoDecompress;
    finally
      Decompress.Free;
    end;
  finally
    ZData.Free;
    if not img.UsePalette and assigned(FPalette) then
      begin
      FPalette.Free;
      end;
  end;
end;

function  TBGRAReaderPNG.InternalCheck (Str:TStream) : boolean;
var {%H-}SigCheck : array[0..7] of byte;
    r : integer;
begin
  try
    // Check Signature
    if Str.Read({%H-}SigCheck, SizeOf(SigCheck)) <> SizeOf(SigCheck) then
      raise PNGImageException.Create('This is not PNG-data');
    for r := 0 to 7 do
    begin
      If SigCheck[r] <> Signature[r] then
        raise PNGImageException.Create('This is not PNG-data');
    end;
    // Check IHDR
    ReadChunk;
    fillchar(FHeader, sizeof(FHeader), 0);
    move (chunk.data^, FHeader, min(sizeof(Header), chunk.alength));
    with header do
      begin
      {$IFDEF ENDIAN_LITTLE}
      Width := swap(width);
      height := swap (height);
      {$ENDIF}
      result := (width > 0) and (height > 0) and (compression = 0)
                and (filter = 0) and (Interlace in [0,1]);
      end;
  except
    result := false;
  end;
end;

initialization

  DefaultBGRAImageReader[ifPng] := TBGRAReaderPNG;

end.

