{
  $Id: ImagingPng.pas,v 1.8 2005/06/22 13:53:21 galfar Exp $
  Vampyre Imaging Library
  by Marek Mauder (pentar@seznam.cz)
  http://imaginglib.sourceforge.net

  The contents of this file are used with permission, subject to the Mozilla
  Public License Version 1.1 (the "License"); you may not use this file except
  in compliance with the License. You may obtain a copy of the License at
  http://www.mozilla.org/MPL/MPL-1.1.html

  Software distributed under the License is distributed on an "AS IS" basis,
  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  the specific language governing rights and limitations under the License.

  Alternatively, the contents of this file may be used under the terms of the
  GNU Lesser General Public License (the  "LGPL License"), in which case the
  provisions of the LGPL License are applicable instead of those above.
  If you wish to allow use of your version of this file only under the terms
  of the LGPL License and not to allow others to use your version of this file
  under the MPL, indicate your decision by deleting  the provisions above and
  replace  them with the notice and other provisions required by the LGPL
  License.  If you do not delete the provisions above, a recipient may use
  your version of this file under either the MPL or the LGPL License.

  For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}

{ This unit contains image format loader/saver for PNG images.}
unit ImagingPng;

{$I ImagingOptions.inc}

interface

uses
  ImagingTypes, Imaging, ImagingUtility, ImagingFormats, {d}zlib;

type
  { Class for loading Portable Network Graphics Images.
    Loads all types of this image format (all images in png test suite)
    and saves all types with bitcount >= 8. Compression level and
    filtering can be set by options interface.}
  TPNGFileFormat = class(TImageFileFormat)
  private
    FPreFilter: LongInt;
    FCompressLevel: LongInt;
  protected
    function GetSupportedFormats: TImageFormats; override;
    procedure LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
      OnlyFirstLevel: Boolean); override;
    procedure SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
      Index: LongInt); override;
    procedure MakeCompatible(const Image: TImageData; var Comp: TImageData);
      override;
    function TestFormat(Handle: TImagingHandle): Boolean; override;
  public
    constructor Create; override;
  end;

const
  sPNGExtensions = 'png';
  sPNGFormatName = 'Portable Network Graphics';
  PNGSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8, ifGray16,
    ifA16Gray16, ifR8G8B8, ifA8R8G8B8, ifR16G16B16, ifA16R16G16B16, ifB16G16R16,
    ifA16B16G16R16];

implementation

uses
  Classes;

resourcestring
  sBadIHDR = 'Invalid PNG IHDR chunk.';
  sErrorLoadingChunk = 'Error when reading %s chunk data.';

type
  TChar4 = array[0..3] of Char;
  TChar8 = array[0..7] of Char;

  { Chunk type identifier }
  TChunkID = packed record
    case Integer of
    0: (Code: LongWord);
    1: (Chars: TChar4);
  end;

  { Chunk header }
  TChunkHeader = packed record
    DataSize: LongWord;
    ChunkID: TChunkID;
  end;

  { IHDR chunk format }
  TIHDR = packed record
    ImgWidth: LongWord;    // Image width
    ImgHeight: LongWord;   // Image height
    BitDepth: Byte;        // Bits per pixel or bits per sample (for truecolor)
    ColorType: Byte;       // 0 = grayscale, 2 = truecolor, 3 = palette,
                           // 4 = gray + alpha, 6 = truecolor + alpha
    Compress: Byte;        // Compression type:  0 = ZLib
    Filter: Byte;          // Used precompress filter
    Interlaced: Byte;      // Used interlacing: 0 = no int, 1 = Adam7
  end;
  PIHDR = ^TIHDR;

const
  { Constants for chunk identifiers and signature identifiers.
    They are in big-endian format.}
  IHDRChunk = $52444849;
  GAMAChunk = $414D4167;
  PLTEChunk = $45544C50;
  BKGDChunk = $44474B62;
  TRNSChunk = $534E5274;
  IDATChunk = $54414449;
  IENDChunk = $444E4549;

  { Interlace start and offsets }
  RowStart: array[0..6] of LongInt = (0, 0, 4, 0, 2, 0, 1);
  ColumnStart: array[0..6] of LongInt = (0, 4, 0, 2, 0, 1, 0);
  RowIncrement: array[0..6] of LongInt = (8, 8, 8, 4, 4, 2, 2);
  ColumnIncrement: array[0..6] of LongInt = (8, 8, 4, 4, 2, 2, 1);

var
  { PNG file identifier }
  PNGSignature: TChar8 = #$89'PNG'#$0D#$0A#$1A#$0A;

function PaethPredictor(A, B, C: Byte): Byte; {$IFDEF USE_INLINE}inline;{$ENDIF}
var
  P, PA, PB, PC: LongInt;
begin
  P := A + B - C;
  PA := Abs(P - A);
  PB := Abs(P - B);
  PC := Abs(P - C);
  if (PA <= PB) and (PA <= PC) then
    Result := A
  else
    if PB <= PC then
      Result := B
    else
      Result := C;
end;

procedure SwapRGB(Line: PByte; Width, SampleDepth, Bpp: LongInt);
var
  J: LongInt;
  Tmp: Word;
begin
  case SampleDepth of
    8:
      for J := 0 to Width - 1 do
      with PColor24Rec(Line)^ do
      begin
        Tmp := R;
        R := B;
        B := Tmp;
        Inc(Line, Bpp);
      end;
    16:
      for J := 0 to Width - 1 do
      with PColor48Rec(Line)^ do
      begin
        Tmp := R;
        R := B;
        B := Tmp;
        Inc(Line, Bpp);
      end;
    end;
 end;

procedure CopyPixel(Src, Dest: Pointer; Bpp: LongInt);
  {$IFDEF USE_INLINE}inline;{$ENDIF}
begin
  case Bpp of
    1: PByte(Dest)^ := PByte(Src)^;
    2: PWord(Dest)^ := PWord(Src)^;
    3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
    4: PLongWord(Dest)^ := PLongWord(Src)^;
    6: PColor48Rec(Dest)^ := PColor48Rec(Src)^;
    8: PInt64(Dest)^ := PInt64(Src)^;
  end;
end;

const
  { Helper constants for 1/2/4 bit to 8 bit conversions.}
  Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
  Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
  Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
  Shift2: array[0..3] of Byte = (6, 4, 2, 0);
  Mask4: array[0..1] of Byte = ($F0, $0F);
  Shift4: array[0..1] of Byte = (4, 0);

function Get1BitPixel(Line: PByteArray; X: LongInt): Byte;
begin
  Result := (Line[X shr 3] and Mask1[X and 7]) shr
    Shift1[X and 7];
end;

function Get2BitPixel(Line: PByteArray; X: LongInt): Byte;
begin
  Result := (Line[X shr 2] and Mask2[X and 3]) shr
    Shift2[X and 3];
end;

function Get4BitPixel(Line: PByteArray; X: LongInt): Byte;
begin
  Result := (Line[X shr 1] and Mask4[X and 1]) shr
    Shift4[X and 1];
end;


{ TPngFileFormat class implementation }

constructor TPNGFileFormat.Create;
begin
  inherited Create;
  FName := sPNGFormatName;
  FCanLoad := True;
  FCanSave := True;
  FIsMultiImageFormat := False;

  FPreFilter := 5;
  FCompressLevel := 5;

  AddExtensions(sPNGExtensions);
  RegisterOption(ImagingPNGPreFilter, @FPreFilter);
  RegisterOption(ImagingPNGCompressLevel, @FCompressLevel);
end;

function TPNGFileFormat.GetSupportedFormats: TImageFormats;
begin
  Result := PNGSupportedFormats;
end;

procedure TPNGFileFormat.LoadData(Handle: TImagingHandle;
  var Images: TDynImageDataArray; OnlyFirstLevel: Boolean);
var
  Sig: TChar8;
  Chunk: TChunkHeader;
  ChunkData: Pointer;
  ChunkCrc: LongWord;
  IHDR: TIHDR;
  BitCount: LongInt;
  Info: PImageFormatInfo;
  MemStream: TMemoryStream;
  Pal: PPalette24;
  PalSize: LongInt;
  Alphas: PByteArray;
  AlphasSize: LongInt;
  ColorKey: TColor48Rec;
  IsColorKeyPresent: Boolean;

  procedure ReadChunk;
  var
    ReadBytes: LongWord;
  begin
    with GetIO do
    begin
      Read(Handle, @Chunk, SizeOf(Chunk));
      Chunk.DataSize := SwapEndian(Chunk.DataSize);
      FreeMemNil(ChunkData);
      GetMem(ChunkData, Chunk.DataSize);
      ReadBytes := Read(Handle, ChunkData, Chunk.DataSize);
      Read(Handle, @ChunkCrc, SizeOf(ChunkCrc));
      if ReadBytes <> Chunk.DataSize then
        raise EImagingError.CreateFmt(sErrorLoadingChunk, [Chunk.ChunkID.Chars]);
    end;
  end;

  procedure LoadIDAT;
  begin
    // write next IDAT chunk to storage for complete IDAT
    MemStream.Write(ChunkData^, Chunk.DataSize);
    FreeMemNil(ChunkData);
  end;

  procedure LoadPLTE;
  begin
    if Pal = nil then
    begin
      GetMem(Pal, Chunk.DataSize);
      Move(ChunkData^, Pal^, Chunk.DataSize);
      PalSize := Chunk.DataSize div 3;
    end;
  end;

  procedure LoadTRNS;
  begin
    if IHDR.ColorType = 3 then
    begin
      if Alphas = nil then
      begin
        GetMem(Alphas, Chunk.DataSize);
        Move(ChunkData^, Alphas^, Chunk.DataSize);
        AlphasSize := Chunk.DataSize;
      end;
    end
    else
    if IHDR.ColorType in [0, 2] then
    begin
      Move(ChunkData^, ColorKey, Min(Chunk.DataSize, SizeOf(ColorKey)));
      Swap(ColorKey.R, ColorKey.B);
      IsColorKeyPresent := True;
    end;
  end;

  procedure ReconstructPalette;
  var
    I: LongInt;
  begin
    with Images[0] do
    begin
      GetMem(Palette, Info.PaletteEntries * SizeOf(TColor32Rec));
      FillChar(Palette^, Info.PaletteEntries * SizeOf(TColor32Rec), $FF);
      // if RGB palette was loaded from file then use it
      if Pal <> nil then
        for I := 0 to Min(PalSize, Info.PaletteEntries) - 1 do
        with Palette[I] do
        begin
          R := Pal[I].B;
          G := Pal[I].G;
          B := Pal[I].R;
        end;
      // if palette alphas were loaded from file then use them
      if Alphas <> nil then
        for I := 0 to Min(AlphasSize, Info.PaletteEntries) - 1 do
          Palette[I].A := Alphas[I];
    end;
  end;

  procedure ApplyColorKey;
  begin

    { TODO -oGalfar: Apply color key after adding color keying support
      to Imaging.}

  end;

  procedure Reconstruct;
  type
    TGetPixelFunc = function(Line: PByteArray; X: LongInt): Byte;
  var
    LineBuffer: array[Boolean] of PByteArray;
    ActLine: Boolean;
    Data, TotalBuffer, ZeroLine: Pointer;
    Offset, TotalSize, TotalPos, Bpp, I, Pass,
      SrcDataSize, BytesPerLine, InterlaceLineBytes, InterlaceWidth: LongInt;

    procedure DecodeAdam7;
    const
      BitTable: array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF);
      StartBit: array[1..8] of Integer = (7, 6, 0, 4, 0, 0, 0, 0);
    var
      Src, Dst, Dst2: PByte;
      CurBit, Col: LongInt;
    begin
      Src := @LineBuffer[ActLine][Offset];
      Col := ColumnStart[Pass];
      with Images[0] do
        case BitCount of
          1, 2, 4:
            begin
              Dst := @PByteArray(Data)[I * BytesPerLine];
              repeat
                CurBit := StartBit[BitCount];
                repeat
                  Dst2 := @PByteArray(Dst)[(BitCount * Col) shr 3];
                  Dst2^ := Dst2^ or ((Src^ shr CurBit) and BitTable[BitCount])
                    shl (StartBit[BitCount] - (Col * BitCount mod 8));
                  Inc(Col, ColumnIncrement[Pass]);
                  Dec(CurBit, BitCount);
                until CurBit < 0;
                Inc(Src);
              until Col >= Width;
            end;
          else
          begin
            Dst := @PByteArray(Data)[I * BytesPerLine + Col * Bpp];
            repeat
              CopyPixel(Src, Dst, Bpp);
              Inc(Dst, Bpp);
              Inc(Src, Bpp);
              Inc(Dst, ColumnIncrement[Pass] * Bpp - Bpp);
              Inc(Col, ColumnIncrement[Pass]);
            until Col >= Width;
          end;
        end;
    end;

    procedure FilterScanline(Filter: Byte; Line, PrevLine, Target: PByteArray;
      BytesPerLine: LongInt);
    var
      I: LongInt;
    begin
      case Filter of
        0:// no filter
          Move(Line^, Target^, BytesPerLine);
        1:// sub filter
          begin
            Move(Line^, Target^, Bpp);
            for I := Bpp to BytesPerLine - 1 do
              Target[I] := (Line[I] + Target[I - Bpp]) and $FF;
          end;
        2:// up filter
          begin
            for I := 0 to BytesPerLine - 1 do
              Target[I] := (Line[I] + PrevLine[I]) and $FF;
          end;
        3: // average filter
          begin
            for I := 0 to Bpp - 1 do
              Target[I] := (Line[I] + PrevLine[I] shr 1) and $FF;
            for I := Bpp to BytesPerLine - 1 do
              Target[I] := (Line[I] + (Target[I - Bpp] + PrevLine[I]) shr 1) and $FF;
          end;
        4:// paeth filter
          begin
            for I := 0 to Bpp - 1 do
              Target[I] := (Line[I] + PaethPredictor(0, PrevLine[I], 0)) and $FF;
            for I := Bpp to BytesPerLine - 1 do
              Target[I] := (Line[I] + PaethPredictor(Target[I - Bpp], PrevLine[I], PrevLine[I - Bpp])) and $FF;
          end;
      end;
    end;

    procedure Convert124To8G(DataIn: Pointer; DataOut: Pointer; Width, Height,
      WidthBytes: LongInt);
    var
      X, Y, Mul: LongInt;
      GetPixel: TGetPixelFunc;
    begin
      GetPixel := Get1BitPixel;
      Mul := 255;
      case IHDR.BitDepth of
        2:
          begin
            Mul := 85;
            GetPixel := Get2BitPixel;
          end;
        4:
          begin
            Mul := 17;
            GetPixel := Get4BitPixel;
          end;
      end;
      for Y := 0 to Height - 1 do
        for X := 0 to Width - 1 do
          PByteArray(DataOut)[Y * Width + X] :=
            GetPixel(@PByteArray(DataIn)[Y * WidthBytes], X) * Mul;
    end;

    procedure Convert124To8I(DataIn: Pointer; DataOut: Pointer; Width, Height,
      WidthBytes: LongInt);
    var
      X, Y: LongInt;
      GetPixel: TGetPixelFunc;
    begin
      GetPixel := Get1BitPixel;
      case IHDR.BitDepth of
        2: GetPixel := Get2BitPixel;
        4: GetPixel := Get4BitPixel;
      end;
      for Y := 0 to Height - 1 do
        for X := 0 to Width - 1 do
          PByteArray(DataOut)[Y * Width + X] :=
            GetPixel(@PByteArray(DataIn)[Y * WidthBytes], X);
    end;

  begin
    LineBuffer[True] := nil;
    LineBuffer[False] := nil;
    TotalBuffer := nil;
    ZeroLine := nil;
    Bpp := (BitCount + 7) shr 3;
    ActLine := True;
    with Images[0] do
    try
      // number of bytes
      BytesPerLine := (Width * BitCount + 7) shr 3;
      SrcDataSize := Height * BytesPerLine;
      GetMem(Data, SrcDataSize);
      FillChar(Data^, SrcDataSize, 0);
      GetMem(ZeroLine, BytesPerLine);
      FillChar(ZeroLine^, BytesPerLine, 0);
      // and this is somewhat weird
      Offset := Iff(IHDR.BitDepth > 8, 0, 1);
      
      // prepare interlaced images
      if IHDR.Interlaced = 1 then
      begin
        TotalPos := 0;
        DecompressBuf(MemStream.Memory, MemStream.Size, 0,
          TotalBuffer, TotalSize);
        GetMem(LineBuffer[True], BytesPerLine + 1);
        GetMem(LineBuffer[False], BytesPerLine + 1);
        for Pass := 0 to 6 do
        begin
          // prepare next interlace run
          if Width <= ColumnStart[Pass] then
            Continue;
          InterlaceWidth := (Width + ColumnIncrement[Pass] - 1 -
            ColumnStart[Pass]) div ColumnIncrement[Pass];
          InterlaceLineBytes := (InterlaceWidth * BitCount + 7) shr 3;
          I := RowStart[Pass];
          FillChar(LineBuffer[True][0], BytesPerLine + 1, 0);
          FillChar(LineBuffer[False][0], BytesPerLine + 1, 0);
          while I < Height do
          begin
            // copy line from decompressed data to working buffer
            Move(PByteArray(TotalBuffer)[TotalPos],
              LineBuffer[ActLine][0], InterlaceLineBytes + 1);
            Inc(TotalPos, InterlaceLineBytes + 1);
            // swap red and blue channels if necessary
            if (IHDR.ColorType in [2, 6]) then
              SwapRGB(@LineBuffer[ActLine][1], InterlaceWidth, IHDR.BitDepth, Bpp);
            // reverse-filter current scanline
            FilterScanline(LineBuffer[ActLine][0],
              @LineBuffer[ActLine][1],
              @LineBuffer[not ActLine][1],
              @LineBuffer[ActLine][1],
              InterlaceLineBytes);
            // decode Adam7 interlacing
            DecodeAdam7;
            ActLine := not ActLine;
            // continue with next row in interlaced order
            Inc(I, RowIncrement[Pass]);
          end;
        end;
      end
      else
      begin
        // decode non-interlaced images
        DecompressBuf(MemStream.Memory, MemStream.Size, SrcDataSize + Height,
          TotalBuffer, TotalSize);
        // decode first scanline
        if IHDR.ColorType in [2, 6] then
          SwapRGB(@PByteArray(TotalBuffer)[1], Width, IHDR.BitDepth, Bpp);
        FilterScanline(PByteArray(TotalBuffer)[0],
          @PByteArray(TotalBuffer)[Offset], ZeroLine, Data, BytesPerLine);
        // decode next scanlines
        for I := 1 to Height - 1 do
        begin
          if IHDR.ColorType in [2, 6] then
            SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], Width,
             IHDR.BitDepth, Bpp);
          FilterScanline(PByteArray(TotalBuffer)[I * (BytesPerLine + 1)],
            @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + Offset],
            @PByteArray(Data)[(I - 1) * BytesPerLine],
            @PByteArray(Data)[I * BytesPerLine], BytesPerLine);
        end;
      end;
      // final image data manipulations
      Size := Width * Height * Bpp;
      if Size <> SrcDataSize then
      begin
        // if source data size is different from size of image in assigned
        // format we must convert it
        GetMem(Bits, Size);
        case IHDR.ColorType of
          0: Convert124To8G(Data, Bits, Width, Height, BytesPerLine);
          3: Convert124To8I(Data, Bits, Width, Height, BytesPerLine);
        end;
        FreeMem(Data);
      end
      else
        // if source data size is the same as size of
        // image Bits in assigned format we simply copy pointer reference
        Bits := Data;

      // reconstruct other image components
      if Format = ifIndex8 then
        ReconstructPalette;
      if IsColorKeyPresent and (IHDR.ColorType in [0, 2]) then
        ApplyColorKey;
    finally
      FreeMem(LineBuffer[True]);
      FreeMem(LineBuffer[False]);
      FreeMem(TotalBuffer);
      FreeMem(ZeroLine);
    end;
  end;

begin
  ChunkData := nil;
  Pal := nil;
  Alphas := nil;
  IsColorKeyPresent := False;
  SetLength(Images, 1);
  with GetIO, Images[0] do
  try
    Read(Handle, @Sig, SizeOf(Sig));
    ReadChunk;
    if (Chunk.ChunkID.Code <> IHDRChunk) then
      raise EImagingError.Create(sBadIHDR);
    IHDR := PIHDR(ChunkData)^;
    SwapEndian(@IHDR, 2);
    if (Chunk.ChunkID.Code <> IHDRChunk) or
      (IHDR.ImgWidth = 0) or (IHDR.ImgHeight = 0) then
      raise EImagingError.Create(sBadIHDR);
    Width := IHDR.ImgWidth;
    Height := IHDR.ImgHeight;
    case IHDR.ColorType of
      0:
        begin
          // gray scale image
          case IHDR.BitDepth of
            1, 2, 4, 8: Format := ifGray8;
            16: Format := ifGray16;
          end;
          BitCount := IHDR.BitDepth;
        end;
      2:
        begin
          // RGB image
          case IHDR.BitDepth of
            8: Format := ifR8G8B8;
            16: Format := ifR16G16B16;
          end;
          BitCount := IHDR.BitDepth * 3;
        end;
      3:
        begin
          // indexed image
          case IHDR.BitDepth of
            1, 2, 4, 8: Format := ifIndex8;
          end;
          BitCount := IHDR.BitDepth;
        end;
      4:
        begin
          // grayscale + alpha image
          case IHDR.BitDepth of
            8: Format := ifA8Gray8;
            16: Format := ifA16Gray16;
          end;
          BitCount := IHDR.BitDepth * 2;
        end;
      6:
        begin
          // ARGB image
          case IHDR.BitDepth of
            8: Format := ifA8R8G8B8;
            16: Format := ifA16R16G16B16;
          end;
          BitCount := IHDR.BitDepth * 4;
        end;
    end;

    Info := GetFormatInfo(Format);
    MemStream := TMemoryStream.Create;
    // read chunks until IEND chunk or EOF is reached
    repeat
      ReadChunk;
      case Chunk.ChunkID.Code of
        IDATChunk: LoadIDAT;
        PLTEChunk: LoadPLTE;
        TRNSChunk: LoadTRNS;
      end;
    until Eof(Handle) or (Chunk.ChunkID.Code = IENDChunk);
    Reconstruct;
  finally
    MemStream.Free;
    FreeMem(ChunkData);
    FreeMem(Alphas);
    FreeMem(Pal);
  end;
end;

procedure TPNGFileFormat.SaveData(Handle: TImagingHandle;
  const Images: TDynImageDataArray; Index: Integer);
var
  Len: LongInt;
  ImageToSave: TImageData;
  Chunk: TChunkHeader;
  IHDR: TIHDR;
  ChunkCrc: LongWord;
  Info: PImageFormatInfo;

  function CalcChunkCrc(const ChunkHdr: TChunkHeader; Data: Pointer;
    Size: LongInt): LongWord;
  begin
    Result := $FFFFFFFF;
    CalcCrc32(Result, @ChunkHdr.ChunkID.Code, SizeOf(ChunkHdr.ChunkID.Code));
    CalcCrc32(Result, Data, Size);
    Result := SwapEndian(Result xor $FFFFFFFF);
  end;

  procedure SaveIDAT;
  var
    TotalBuffer, CompBuffer, ZeroLine: Pointer;
    FilterLines: array[0..4] of PByteArray;
    Offset, TotalSize, CompSize, I, BytesPerLine, Bpp: LongInt;
    Filter: Byte;
    Adaptive: Boolean;

    procedure FilterScanline(Filter: Byte; Line, PrevLine, Target: PByteArray);
    var
      I: LongInt;
    begin
      case Filter of
        0:// no filter
          Move(Line^, Target^, BytesPerLine);
        1:// sub filter
          begin
            Move(Line^, Target^, Bpp);
            for I := Bpp to BytesPerLine - 1 do
              Target[I] := (Line[I] - Line[I - Bpp]) and $FF;
          end;
        2:// up filter
          begin
            for I := 0 to BytesPerLine - 1 do
              Target[I] := (Line[I] - PrevLine[I]) and $FF;
          end;
        3: // average filter
          begin
            for I := 0 to Bpp - 1 do
              Target[I] := (Line[I] - PrevLine[I] shr 1) and $FF;
            for I := Bpp to BytesPerLine - 1 do
              Target[I] := (Line[I] - (Line[I - Bpp] + PrevLine[I]) shr 1) and $FF;
          end;
        4:// paeth filter
          begin
            for I := 0 to Bpp - 1 do
              Target[I] := (Line[I] - PaethPredictor(0, PrevLine[I], 0)) and $FF;
            for I := Bpp to BytesPerLine - 1 do
              Target[I] := (Line[I] - PaethPredictor(Line[I - Bpp], PrevLine[I], PrevLine[I - Bpp])) and $FF;
          end;
      end;
    end;

    procedure AdaptiveFilter(var Filter: Byte; Line, PrevLine, Target: PByteArray);
    var
      I, J, BestTest: LongInt;
      Sums: array[0..4] of LongInt;
    begin
      // compute the output scanline using all five filters,
      // and select the filter that gives the smallest sum of
      // absolute values of outputs
      FillChar(Sums, SizeOf(Sums), 0);
      BestTest := MaxInt;
      for I := 0 to 4 do
      begin
        FilterScanline(I, Line, PrevLine, FilterLines[I]);
        for J := 0 to BytesPerLine - 1 do
          Sums[I] := Sums[I] + Abs(ShortInt(FilterLines[I][J]));
        if Sums[I] < BestTest then
        begin
          Filter := I;
          BestTest := Sums[I];
        end;
      end;
      Move(FilterLines[Filter]^, Target^, BytesPerLine);
    end;

  begin
    TotalBuffer := nil;
    CompBuffer := nil;
    ZeroLine := nil;
    FillChar(FilterLines, SizeOf(FilterLines), 0);
    Adaptive := False;
    Filter := 0;
    Bpp := Info.BytesPerPixel;
    with ImageToSave do
    try
      // select precompression filter and compression level
      case FPreFilter of
        6:
          begin
            if not ((IHDR.BitDepth < 8) or (IHDR.ColorType = 3))
              then Adaptive := True;
          end;
        0..4: Filter := FPreFilter;
        else
          if IHDR.ColorType in [2, 6] then
            Filter := 4
      end;
      if not (FCompressLevel in [0..9]) then
        FCompressLevel := 5;
      // prepare data for compression
      BytesPerLine := Width * Info.BytesperPixel;
      TotalSize := Size + Height;
      GetMem(TotalBuffer, TotalSize);
      GetMem(ZeroLine, BytesPerLine);
      FillChar(ZeroLine^, BytesPerLine, 0);
      if Adaptive then
        for I := 0 to 4 do
          GetMem(FilterLines[I], BytesPerLine);
      // and this is somewhat weird
      Offset := Iff(IHDR.BitDepth > 8, 0, 1);
      // process first scanline
      if Adaptive then
        AdaptiveFilter(Filter, Bits, ZeroLine, @PByteArray(TotalBuffer)[Offset])
      else
        FilterScanline(Filter, Bits, ZeroLine, @PByteArray(TotalBuffer)[Offset]);
      if (IHDR.ColorType in [2, 6]) and (not Info.IsRBSwapped) then
        SwapRGB(@PByteArray(TotalBuffer)[Offset], Width, IHDR.BitDepth,
          Info.BytesPerPixel);
      PByteArray(TotalBuffer)[0] := Filter;
      // process next scanlines
      for I := 1 to Height - 1 do
      begin
        if Adaptive then
          AdaptiveFilter(Filter, @PByteArray(Bits)[I * BytesPerLine],
            @PByteArray(Bits)[(I - 1) * BytesPerLine],
            @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + Offset])
        else
          FilterScanline(Filter, @PByteArray(Bits)[I * BytesPerLine],
            @PByteArray(Bits)[(I - 1) * BytesPerLine],
            @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + Offset]);
        if (IHDR.ColorType in [2, 6]) and (not Info.IsRBSwapped) then
          SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + Offset],
            Width, IHDR.BitDepth, Info.BytesPerPixel);
        PByteArray(TotalBuffer)[I * (BytesPerLine + 1)] := Filter;
      end;
      // compress IDAT data
      CompressBuf(TotalBuffer, TotalSize, CompBuffer, CompSize, FCompressLevel);
      // write IDAT chunk to output
      Chunk.DataSize := SwapEndian(CompSize);
      Chunk.ChunkID.Code := IDATChunk;
      ChunkCrc := CalcChunkCrc(Chunk, CompBuffer, CompSize);
      with GetIO do
      begin
        Write(Handle, @Chunk, SizeOf(Chunk));
        Write(Handle, CompBuffer, CompSize);
        Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
      end;
    finally
      FreeMem(TotalBuffer);
      FreeMem(CompBuffer);
      FreeMem(ZeroLine);
      if Adaptive then
        for I := 0 to 4 do
          FreeMem(FilterLines[I]);
    end;
  end;

  procedure SavePalette;
  var
    Pal: PPalette24;
    Alphas: PByteArray;
    I, PalBytes: LongInt;
  begin
    with ImageToSave do
    begin
      // fill and save RGB part of palette to PLTE chunk
      PalBytes := Info.PaletteEntries * SizeOf(TColor24Rec);
      GetMem(Pal, PalBytes);
      for I := 0 to Info.PaletteEntries - 1 do
      begin
        Pal[I].B := Palette[I].R;
        Pal[I].G := Palette[I].G;
        Pal[I].R := Palette[I].B;
      end;
      Chunk.DataSize := SwapEndian(PalBytes);
      Chunk.ChunkID.Code := PLTEChunk;
      ChunkCrc := CalcChunkCrc(Chunk, Pal, PalBytes);
      with GetIO do
      begin
        Write(Handle, @Chunk, SizeOf(Chunk));
        Write(Handle, Pal, PalBytes);
        Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
      end;
      FreeMem(Pal);
      // fill and save alpha part of palette to tRNS chunk
      PalBytes := Info.PaletteEntries * SizeOf(Byte);
      GetMem(Alphas, PalBytes);
      for I := 0 to Info.PaletteEntries - 1 do
        Alphas[I] := Palette[I].A;
      Chunk.DataSize := SwapEndian(PalBytes);
      Chunk.ChunkID.Code := TRNSChunk;
      ChunkCrc := CalcChunkCrc(Chunk, Pal, PalBytes);
      with GetIO do
      begin
        Write(Handle, @Chunk, SizeOf(Chunk));
        Write(Handle, Pal, PalBytes);
        Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
      end;
      FreeMem(Alphas);
    end;
  end;

begin
  Len := Length(Images);
  if Len = 0 then
    Exit;
  if (Index = MaxInt) or (Len = 1) then
    Index := 0;
  MakeCompatible(Images[Index], ImageToSave);
  with GetIO, ImageToSave do
  try
    Info := GetFormatInfo(ImageToSave.Format);
    // write signature and fill the header
    Write(Handle, @PNGSignature, SizeOf(PNGSignature));
    Chunk.DataSize := SwapEndian(SizeOf(IHDR));
    Chunk.ChunkID.Code := IHDRChunk;
    IHDR.ImgWidth := Width;
    IHDR.ImgHeight := Height;
    SwapEndian(@IHDR, 2);
    IHDR.Compress := 0;
    IHDR.Filter := 0;
    IHDR.Interlaced := 0;
    IHDR.BitDepth := Info.BytesPerPixel * 8;

    // select appropiate PNG color type and modify bitdepth
    if Info.HasGrayChannel then
    begin
      IHDR.ColorType := 0;
      if Info.HasAlphaChannel then
      begin
        IHDR.ColorType := 4;
        IHDR.BitDepth := IHDR.BitDepth div 2;
      end;
    end
    else
      if Info.IsIndexed then
        IHDR.ColorType := 3
      else
        if Info.HasAlphaChannel then
        begin
          IHDR.ColorType := 6;
          IHDR.BitDepth := IHDR.BitDepth div 4;
        end
        else
        begin
          IHDR.ColorType := 2;
          IHDR.BitDepth := IHDR.BitDepth div 3;
        end;
        
    // write IHDR chunk to output
    ChunkCrc := CalcChunkCrc(Chunk, @IHDR, SizeOf(IHDR));
    Write(Handle, @Chunk, SizeOf(Chunk));
    Write(Handle, @IHDR, SizeOf(IHDR));
    Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));

    if Info.IsIndexed then
      SavePalette;
    SaveIDAT;

    // write IEND chunk to output
    Chunk.DataSize := 0;
    Chunk.ChunkID.Code := IENDChunk;
    ChunkCrc := CalcChunkCrc(Chunk, nil, 0);
    Write(Handle, @Chunk, SizeOf(Chunk));
    Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
  finally
    if Images[Index].Bits <> ImageToSave.Bits then
      FreeImage(ImageToSave);
  end;
end;

procedure TPNGFileFormat.MakeCompatible(const Image: TImageData;
  var Comp: TImageData);
var
  Info: PImageFormatInfo;
  ConvFormat: TImageFormat;
begin
  inherited MakeCompatible(Image, Comp);
  if not (Image.Format in GetSupportedFormats) then
  begin
    CloneImage(Image, Comp);
    Info := GetFormatInfo(Image.Format);
    if Info.HasGrayChannel then
    begin
      if Info.HasAlphaChannel then
      begin
        if Info.BytesPerPixel <= 2 then
          // convert <=16bit grayscale images with alpha to ifA8Gray8
          ConvFormat := ifA8Gray8
        else
          // convert >16bit grayscale images with alpha to ifA16Gray16
          ConvFormat := ifA16Gray16
      end
      else
        // convert grayscale images without alpha to ifGray16
        ConvFormat := ifGray16;
    end
    else
      if Info.IsFloatingPoint then
        // convert floating point images to 64 bit ARGB
        ConvFormat := ifA16B16G16R16
      else
        if Info.HasAlphaChannel or Info.IsSpecial then
          // convert all other images with alpha or special images to A8R8G8B8
          ConvFormat := ifA8R8G8B8
        else
          // convert images without alpha to R8G8B8
          ConvFormat := ifR8G8B8;
    ConvertImage(Comp, ConvFormat);
  end;
end;

function TPNGFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
  ReadCount: LongInt;
  Sig: TChar8;
begin
  Result := False;
  if Handle <> nil then
    with GetIO do
    begin
      FillChar(Sig, SizeOf(Sig), 0);
      ReadCount := Read(Handle, @Sig, SizeOf(Sig));
      Seek(Handle, -ReadCount, smFromCurrent);
      Result := (ReadCount = SizeOf(Sig)) and (Sig = PNGSignature);
    end;
end;

initialization
  RegisterImageFileFormat(TPNGFileFormat);

{
  File Notes:

  -- TODOS ----------------------------------------------------
    - do not load chunk data of chunks that are not processed
      in any way
    - apply color key after adding color keying support
      to Imaging

  -- 0.13 Changes/Bug Fixes -----------------------------------
    - adaptive filtering added to PNG saving
    - TPNGFileFormat class added

}

end.

