+ fppngwriter implemented

* solved some bugs in pngreader and color conversions
* pngreader: HandleScanline virtual method added for optimisations in descendants

fcl/image/Makefile.fpc

@@ -9,8 +9,8 @@ main=fcl
 packages=paszlib
 
 [target]
-units=fpimgcmn fpimage pngcomn fpreadpng  fpreadxpm fpwritexpm clipping \
-      fpcanvas pixtools fppixlcanv fpimgcanv pscanvas
+units=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm \
+      clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas
 examples=imgconv
 
 [compiler]

fcl/image/fpcolcnv.inc

@@ -52,7 +52,7 @@ const
     {cfBGR24} ($00000000, $000000FF, $0000FF00, $00FF0000),
     {cfBGR32} ($00000000, $000000FF, $0000FF00, $00FF0000),
     {cfBGR48} ($00000000, $0000FFFF, $FFFF0000, $FFFF0000),
-    //                                          shl 16
+    //                                           shl 16
     {cfABGR8} ($000000C0, $00000003, $0000000C, $00000030),
     {cfABGR16}($0000F000, $0000000F, $000000F0, $00000F00),
     {cfABGR32}($FF000000, $000000FF, $0000FF00, $00FF0000),
@@ -118,7 +118,7 @@ begin
     cfMono : result := SetGrayScaleA (ShiftAndFill(From,1));
     cfGray2 : result := SetGrayScaleA (ShiftAndFill(From,2));
     cfGray4 : result := SetGrayScaleA (ShiftAndFill(From,4));
-    cdGray8 : result := SetGrayScaleA (ShiftAndFill(From,8));
+    cfGray8 : result := SetGrayScaleA (ShiftAndFill(From,8));
     cfGray16 : result := SetGrayScaleA (From);
     cfGray24 : result := SetGrayScaleA ((From and $00FFFF00) shr 8);
     cfGrayA8 :
@@ -163,6 +163,7 @@ end;
 function CalculateGray (const c : TFPcolor; Bits:byte) : TColorData;
 begin
   // MG: ToDo
+  raise FPImageException.create ('Not yet implemented');
   if (c.alpha=0) or (Bits=0) then ;
   Result:=0;
 end;
@@ -182,12 +183,19 @@ function ConvertColorToData (const From : TFPColor; Fmt : TColorFormat) : TColor
 var sb : TShiftBits;
     cb : TColorBits;
   function MakeSample (Value:word; ToShift:shortint; ToUse:TColorData) : TColorData;
+  var sh : word;
   begin
     result := Value;
-    if ToShift > 0 then
-      result := result shl ToShift
+    if ToShift >= 0 then
+      begin
+      sh := ToShift;            // if not converting first to word, there will be a
+      result := result shl Sh;  // color shift
+      end
     else
-      result := result shr ToShift;
+      begin
+      sh := -ToShift;
+      result := result shr Sh;
+      end;
     result := result and ToUse;
   end;
 begin
@@ -195,7 +203,7 @@ begin
     cfMono : result := CalculateGray (From,1);
     cfGray2 : result := CalculateGray (From,2);
     cfGray4 : result := CalculateGray (From,4);
-    cdGray8 : result := CalculateGray (From,8);
+    cfGray8 : result := CalculateGray (From,8);
     cfGray16 : result := CalculateGray (From,16);
     cfGray24 : result := CalculateGray (From,24);
     cfGrayA8 : result := CalculateGrayA (From, 8);

fcl/image/fpimage.inc

@@ -343,4 +343,4 @@ begin
     Inherited Assign(Source);
 end;
 
-    
+    

fcl/image/fpimage.pp

@@ -33,7 +33,7 @@ type
   end;
   PFPColor = ^TFPColor;
 
-  TColorFormat = (cfMono,cfGray2,cfGray4,cdGray8,cfGray16,cfGray24,
+  TColorFormat = (cfMono,cfGray2,cfGray4,cfGray8,cfGray16,cfGray24,
                   cfGrayA8,cfGrayA16,cfGrayA32,
                   cfRGB15,cfRGB16,cfRGB24,cfRGB32,cfRGB48,
                   cfRGBA8,cfRGBA16,cfRGBA32,cfRGBA64,
@@ -348,12 +348,12 @@ end;
 
 initialization
   ImageHandlers := TImageHandlersManager.Create;
-  ColorBits [cfRGBA64,1] := ColorBits [cfRGBA64,0] shl 32;
-  ColorBits [cfRGBA64,2] := ColorBits [cfRGBA64,1] shl 16;
+  ColorBits [cfRGBA64,1] := ColorBits [cfRGBA64,1] shl 32;
+  ColorBits [cfRGBA64,2] := ColorBits [cfRGBA64,2] shl 16;
   ColorBits [cfRGB48,1] := ColorBits [cfRGB48,1] shl 16;
   ColorBits [cfABGR64,0] := ColorBits [cfABGR64,0] shl 32;
-  ColorBits [cfABGR64,3] := ColorBits [cfABGR64,1] shl 16;
-  ColorBits [cfBGR48,3] := ColorBits [cfBGR48,1] shl 16;
+  ColorBits [cfABGR64,3] := ColorBits [cfABGR64,3] shl 16;
+  ColorBits [cfBGR48,3] := ColorBits [cfBGR48,3] shl 16;
 finalization
   ImageHandlers.Free;
 

fcl/image/fppixlcanv.pp

@@ -38,13 +38,13 @@ type
     procedure DoGetTextSize (text:string; var w,h:integer); override;
     function  DoGetTextHeight (text:string) : integer; override;
     function  DoGetTextWidth (text:string) : integer; override;
-    procedure DoRectangle (Bounds:TRect); override;
-    procedure DoRectangleFill (Bounds:TRect); override;
-    procedure DoEllipseFill (Bounds:TRect); override;
-    procedure DoEllipse (Bounds:TRect); override;
-    procedure DoPolygonFill (points:array of TPoint); override;
-    procedure DoPolygon (points:array of TPoint); override;
-    procedure DoPolyline (points:array of TPoint); override;
+    procedure DoRectangle (const Bounds:TRect); override;
+    procedure DoRectangleFill (const Bounds:TRect); override;
+    procedure DoEllipseFill (const Bounds:TRect); override;
+    procedure DoEllipse (const Bounds:TRect); override;
+    procedure DoPolygonFill (const points:array of TPoint); override;
+    procedure DoPolygon (const points:array of TPoint); override;
+    procedure DoPolyline (const points:array of TPoint); override;
     procedure DoFloodFill (x,y:integer); override;
     procedure DoLine (x1,y1,x2,y2:integer); override;
   end;
@@ -115,11 +115,13 @@ begin
   NotImplemented;
 end;
 
-procedure TFPPixelCanvas.DoRectangle (Bounds:TRect);
+procedure TFPPixelCanvas.DoRectangle (const Bounds:TRect);
+var b : TRect;
 begin
+  b := bounds;
   if clipping then
-    CheckRectClipping (ClipRect, Bounds);
-  with Bounds do
+    CheckRectClipping (ClipRect, B);
+  with B do
     begin
     DoLine (left,top,left,bottom);
     DoLine (left,bottom,right,bottom);
@@ -128,15 +130,14 @@ begin
     end;
 end;
 
-procedure TFPPixelCanvas.DoRectangleFill (Bounds:TRect);
+procedure TFPPixelCanvas.DoRectangleFill (const Bounds:TRect);
+var b : TRect;
 begin
-  writeln ('Rectangle Fill, sorting bounds');
-  SortRect (bounds);
-  writeln ('Checking clipping');
+  b := Bounds;
+  SortRect (b);
   if clipping then
-    CheckRectClipping (ClipRect, Bounds);
-  writeln ('Choosing what to do');
-  with bounds do
+    CheckRectClipping (ClipRect, B);
+  with b do
     case Brush.style of  //TODO: patterns and image
       bsSolid : FillRectangleColor (self, left,top, right,bottom);
       bsPattern : ;
@@ -148,22 +149,21 @@ begin
       bsHorizontal : ;
       bsVertical : ;
     end;
-  writeln ('Rectangle finished');
 end;
 
-procedure TFPPixelCanvas.DoEllipseFill (Bounds:TRect);
+procedure TFPPixelCanvas.DoEllipseFill (const Bounds:TRect);
 begin  //TODO
 end;
 
-procedure TFPPixelCanvas.DoEllipse (Bounds:TRect);
+procedure TFPPixelCanvas.DoEllipse (const Bounds:TRect);
 begin  //TODO
 end;
 
-procedure TFPPixelCanvas.DoPolygonFill (points:array of TPoint);
+procedure TFPPixelCanvas.DoPolygonFill (const points:array of TPoint);
 begin  //TODO: how to find a point inside the polygon ?
 end;
 
-procedure TFPPixelCanvas.DoPolygon (points:array of TPoint);
+procedure TFPPixelCanvas.DoPolygon (const points:array of TPoint);
 var i,a, r : integer;
     p : TPoint;
 begin
@@ -178,7 +178,7 @@ begin
   DoLine (p.x,p.y, points[i].x,points[i].y);
 end;
 
-procedure TFPPixelCanvas.DoPolyline (points:array of TPoint);
+procedure TFPPixelCanvas.DoPolyline (const points:array of TPoint);
 var i,a, r : integer;
     p : TPoint;
 begin

fcl/image/fpreadpng.pp

@@ -32,8 +32,8 @@ Type
       ZData : TMemoryStream;  // holds compressed data until all blocks are read
       Decompress : TDeCompressionStream; // decompresses the data
       FPltte : boolean;     // if palette is used
-      CountScanlines : EightLong; //Number of scanlines to process for each pass
-      ScanLineLength : EightLong; //Length of scanline for each pass
+      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
@@ -50,6 +50,8 @@ Type
     protected
       UseTransparent, EndOfFile : boolean;
       TransparentDataValue : TColorData;
+      UsingBitGroup : byte;
+      DataIndex,DataBytes : longword;
       function CurrentLine(x:longword) : byte;
       function PrevSample (x:longword): byte;
       function PreviousLine (x:longword) : byte;
@@ -57,6 +59,10 @@ Type
       procedure HandleChunk; virtual;
       procedure HandlePalette; virtual;
       procedure HandleAlpha; virtual;
+      function CalcX (relX:integer) : integer;
+      function CalcY (relY:integer) : integer;
+      function CalcColor: TColorData;
+      procedure HandleScanLine (const y : integer; const ScanLine : PByteArray); virtual;
       procedure DoDecompress; virtual;
       function  DoFilter(LineFilter:byte;index:longword; b:byte) : byte; virtual;
       procedure SetPalettePixel (x,y:integer; CD : TColordata);
@@ -71,6 +77,8 @@ Type
       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
       constructor create; override;
       destructor destroy; override;
@@ -218,6 +226,7 @@ begin
       if (aLength mod 3) > 0 then
         raise PNGImageException.Create ('Impossible length for PLTE-chunk');
       r := 0;
+      ThePalette.count := 0;
       while r < alength do
         begin
         c.red := ShiftAndFill(data^[r], 8);
@@ -345,6 +354,55 @@ begin
       result := @SetColorPixel;
 end;
 
+function TFPReaderPNG.CalcX (relX:integer) : integer;
+begin
+  result := StartX + (relX * deltaX);
+end;
+
+function TFPReaderPNG.CalcY (relY:integer) : integer;
+begin
+  result := StartY + (relY * deltaY);
+end;
+
+function TFPReaderPNG.CalcColor: TColorData;
+var cd : longword;
+begin
+  if UsingBitGroup = 0 then
+    begin
+    Databytes := 0;
+    move (FCurrentLine^[DataIndex], Databytes, bytewidth);
+    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 if bytewidth = 2 then
+    result := DataBytes shr 16
+  else if bytewidth = 3 then
+    result := Databytes shr 8}
+  else
+    result := Databytes;
+end;
+
+procedure TFPReaderPNG.HandleScanLine (const y : integer; const ScanLine : PByteArray);
+var x, rx : integer;
+    c : TColorData;
+begin
+  UsingBitGroup := 0;
+  DataIndex := 0;
+  for rx := 0 to ScanlineLength[CurrentPass]-1 do
+    begin
+    X := CalcX(rx);
+    c := CalcColor;
+    FSetPixel (x,y,c);
+    end
+end;
+
 procedure TFPReaderPNG.DoDecompress;
 
   procedure initVars;
@@ -381,7 +439,7 @@ procedure TFPReaderPNG.DoDecompress;
               1  : CFmt := cfMono;
               2  : CFmt := cfGray2;
               4  : CFmt := cfGray4;
-              8  : CFmt := cdGray8;
+              8  : CFmt := cfGray8;
               16 : CFmt := cfGray16;
             end;
         2 : if BitDepth = 8 then
@@ -423,47 +481,9 @@ procedure TFPReaderPNG.DoDecompress;
       end;
   end;
 
-  function CalcX (relX:integer) : integer;
-  begin
-    result := StartX + (relX * deltaX);
-  end;
-
-  function CalcY (relY:integer) : integer;
-  begin
-    result := StartY + (relY * deltaY);
-  end;
-
-  var lf, UsingBitGroup : byte;
-      index,DataBytes : longword;
-
-  function CalcColor: TColorData;
-  var cd : longword;
-  begin
-    if UsingBitGroup = 0 then
-      begin
-      Databytes := 0;
-      move (FCurrentLine^[index], Databytes, bytewidth);
-      inc (index,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 if bytewidth = 2 then
-      result := DataBytes shr 16
-    else if bytewidth = 3 then
-      result := Databytes shr 8}
-    else
-      result := Databytes;
-  end;
-
   procedure Decode;
-  var x, y, rp, ry, rx, l : integer;
-      c : TColorData;
+  var y, rp, ry, rx, l : integer;
+      lf : byte;
   begin
     FSetPixel := DecideSetPixel;
     for rp := StartPass to EndPass do
@@ -495,17 +515,8 @@ procedure TFPReaderPNG.DoDecompress;
           Decompress.Read (FCurrentLine^, l);
           if lf <> 0 then  // Do nothing when there is no filter used
             for rx := 0 to l-1 do
-              begin
               FCurrentLine^[rx] := DoFilter (lf, rx, FCurrentLine^[rx]);
-              end;
-          UsingBitGroup := 0;
-          index := 0;
-          for rx := 0 to ScanlineLength[rp]-1 do
-            begin
-            X := CalcX(rx);
-            c := CalcColor;
-            FSetPixel (x,y,c);
-            end
+          HandleScanLine (y, FCurrentLine);
           end;
       finally
         freemem (FPreviousLine);
@@ -533,7 +544,7 @@ end;
 
 procedure TFPReaderPNG.HandleUnknown;
 begin
-  if (chunk.readtype[1] in ['A'..'Z']) then
+  if (chunk.readtype[0] in ['A'..'Z']) then
     raise PNGImageException.Create('Critical chunk '+chunk.readtype+' not recognized');
   //writeln ('Unhandled chunk ',chunk.readtype);
 end;

fcl/image/fpwritepng.pp

@@ -0,0 +1,648 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    XPM writer class.
+    
+    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.
+
+ **********************************************************************}
+{$mode objfpc}{$h+}
+unit FPWritePNG;
+
+interface
+
+uses classes, FPImage, FPImgCmn, PNGComn, ZStream, sysutils;
+
+type
+
+  TGetPixelFunc = function (x,y : integer) : TColorData of object;
+
+  TFPWriterPNG = class (TFPCustomImageWriter)
+    private
+      FUsetRNS, FCompressedText, FWordSized, FIndexed,
+      FUseAlpha, FGrayScale : boolean;
+      FByteWidth : byte;
+      FChunk : TChunk;
+      CFmt : TColorFormat; // format of the colors to convert from
+      FTransparentColor : TFPColor;
+      FSwitchLine, FCurrentLine, FPreviousLine : pByteArray;
+      FPalette : TFPPalette;
+      FHeader : THeaderChunk;
+      FGetPixel : TGetPixelFunc;
+      FDatalineLength : longword;
+      ZData : TMemoryStream;  // holds uncompressed data until all blocks are written
+      Compressor : TCompressionStream; // compresses the data
+      procedure WriteChunk;
+      function GetColorPixel (x,y:longword) : TColorData;
+      function GetPalettePixel (x,y:longword) : TColorData;
+      function GetColPalPixel (x,y:longword) : TColorData;
+      procedure InitWriteIDAT;
+      procedure Gatherdata;
+      procedure WriteCompressedData;
+      procedure FinalWriteIDAT;
+    protected
+      property Header : THeaderChunk read FHeader;
+      procedure InternalWrite (Str:TStream; Img:TFPCustomImage); override;
+      procedure WriteIHDR; virtual;
+      procedure WritePLTE; virtual;
+      procedure WritetRNS; virtual;
+      procedure WriteIDAT; virtual;
+      procedure WriteTexts; virtual;
+      procedure WriteIEND; virtual;
+      function CurrentLine (x:longword) : byte;
+      function PrevSample (x:longword): byte;
+      function PreviousLine (x:longword) : byte;
+      function PrevLinePrevSample (x:longword): byte;
+      function  DoFilter (LineFilter:byte;index:longword; b:byte) : byte; virtual;
+      procedure SetChunkLength (aValue : longword);
+      procedure SetChunkType (ct : TChunkTypes);
+      procedure SetChunkType (ct : TChunkCode);
+      function DecideGetPixel : TGetPixelFunc; virtual;
+      procedure DetermineHeader (var AHeader : THeaderChunk); virtual;
+      function DetermineFilter (Current, Previous:PByteArray; linelength:longword):byte; virtual;
+      procedure FillScanLine (y : integer; ScanLine : pByteArray); virtual;
+      property ChunkDataBuffer : PByteArray read FChunk.data;
+      property UsetRNS : boolean read FUsetRNS;
+      property SingleTransparentColor : TFPColor read FTransparentColor;
+      property ThePalette : TFPPalette read FPalette;
+      property ColorFormat : TColorformat read CFmt;
+      property byteWidth : byte read FByteWidth;
+      property DatalineLength : longword read FDatalineLength;
+    public
+      constructor create; override;
+      destructor destroy; override;
+      property GrayScale : boolean read FGrayscale write FGrayScale;
+      property Indexed : boolean read FIndexed write FIndexed;
+      property CompressedText : boolean read FCompressedText write FCompressedText;
+      property WordSized : boolean read FWordSized write FWordSized;
+      property UseAlpha : boolean read FUseAlpha write FUseAlpha;
+  end;
+
+implementation
+
+constructor TFPWriterPNG.create;
+begin
+  inherited;
+  Fchunk.acapacity := 0;
+  Fchunk.data := nil;
+  FGrayScale := False;
+  FIndexed := True;
+  FCompressedText := True;
+  FWordSized := True;
+  FUseAlpha := False;
+end;
+
+destructor TFPWriterPNG.destroy;
+begin
+  with Fchunk do
+    if acapacity > 0 then
+      freemem (data);
+  inherited;
+end;
+
+procedure TFPWriterPNG.WriteChunk;
+var chead : TChunkHeader;
+    c : longword;
+begin
+  with FChunk do
+    begin
+    chead.CLength := swap (alength);
+    if (ReadType = '') then
+      if atype <> ctUnknown then
+        chead.CType := ChunkTypes[aType]
+      else
+        raise PNGImageException.create ('Doesn''t have a chunktype to write')
+    else
+      chead.CType := ReadType;
+    writeln ('Writing chunk ',Readtype,' with length ',alength);
+    c := CalculateCRC (All1Bits, ReadType, sizeOf(ReadType));
+    c := CalculateCRC (c, data^, alength);
+    crc := swap(c xor All1Bits);
+    with TheStream do
+      begin
+      Write (chead, sizeof(chead));
+      Write (data^[0], alength);
+      Write (crc, sizeof(crc));
+      end;
+    end;
+end;
+
+procedure TFPWriterPNG.SetChunkLength(aValue : longword);
+begin
+  writeln ('Setting length to ',AValue);
+  with Fchunk do
+    begin
+    alength := aValue;
+    if aValue > acapacity then
+      begin
+      if acapacity > 0 then
+        freemem (data);
+      GetMem (data, alength);
+      acapacity := alength;
+      end;
+    end;
+end;
+
+procedure TFPWriterPNG.SetChunkType (ct : TChunkTypes);
+begin
+  with Fchunk do
+    begin
+    aType := ct;
+    ReadType := ChunkTypes[ct];
+    end;
+end;
+
+procedure TFPWriterPNG.SetChunkType (ct : TChunkCode);
+begin
+  with FChunk do
+    begin
+    ReadType := ct;
+    aType := low(TChunkTypes);
+    while (aType < high(TChunkTypes)) and (ChunkTypes[aType] <> ct) do
+      inc (aType);
+    end;
+end;
+
+function TFPWriterPNG.CurrentLine(x:longword):byte;
+begin
+  result := FCurrentLine^[x];
+end;
+
+function TFPWriterPNG.PrevSample (x:longword): byte;
+begin
+  if x < byteWidth then
+    result := 0
+  else
+    result := FCurrentLine^[x - bytewidth];
+end;
+
+function TFPWriterPNG.PreviousLine (x:longword) : byte;
+begin
+  result := FPreviousline^[x];
+end;
+
+function TFPWriterPNG.PrevLinePrevSample (x:longword): byte;
+begin
+  if x < byteWidth then
+    result := 0
+  else
+    result := FPreviousLine^[x - bytewidth];
+end;
+
+function TFPWriterPNG.DoFilter(LineFilter:byte;index:longword; b:byte) : byte;
+var diff : byte;
+  procedure FilterSub;
+  begin
+    diff := PrevSample(index);
+  end;
+  procedure FilterUp;
+  begin
+    diff := PreviousLine(index);
+  end;
+  procedure FilterAverage;
+  var l, p : word;
+  begin
+    l := PrevSample(index);
+    p := PreviousLine(index);
+    Diff := (l + p) div 2;
+  end;
+  procedure FilterPaeth;
+  var dl, dp, dlp : word; // index for previous and distances for:
+      l, p, lp : byte;  // r:predictor, Left, Previous, LeftPrevious
+      r : integer;
+  begin
+    l := PrevSample(index);
+    lp := PrevLinePrevSample(index);
+    p := PreviousLine(index);
+    r := l + p - lp;
+    dl := abs (r - l);
+    dlp := abs (r - lp);
+    dp := abs (r - p);
+    if (dl <= dp) and (dl <= dlp) then
+      diff := l
+    else if dp <= dlp then
+      diff := p
+    else
+      diff := lp;
+  end;
+begin
+  case LineFilter of
+    0 : diff := 0;
+    1 : FilterSub;
+    2 : FilterUp;
+    3 : FilterAverage;
+    4 : FilterPaeth;
+  end;
+  if diff > b then
+    result := (b + $100 - diff)
+  else
+    result := b - diff;
+end;
+
+procedure TFPWriterPNG.DetermineHeader (var AHeader : THeaderChunk);
+var c : integer;
+  function CountAlphas : integer;
+  var none, half : boolean;
+      x,y : longword;
+      p : integer;
+      c : TFPColor;
+      a : word;
+  begin
+    half := false;
+    none := false;
+    with TheImage do
+      if UsePalette then
+        with Palette do
+          begin
+          p := count-1;
+          FTransparentColor.alpha := alphaOpaque;
+          while (p >= 0) do
+            begin
+            c := color[p];
+            a := c.Alpha;
+            if a = alphaTransparant then
+              begin
+              none := true;
+              FTransparentColor := c;
+              end
+            else if a <> alphaOpaque then
+              begin
+              half := true;
+              if FtransparentColor.alpha < a then
+                FtransparentColor := c;
+              end;
+            dec (p);
+            end;
+          end
+      else
+        begin
+        x := width-1;
+        y := height-1;
+        FTransparentColor.alpha := alphaOpaque;
+        while (y >= 0) and not (half and none) do
+          begin
+          c := colors[x,y];
+          a := c.Alpha;
+          if a = alphaTransparant then
+            begin
+            none := true;
+            FTransparentColor := c;
+            end
+          else if a <> alphaOpaque then
+            begin
+            half := true;
+            if FtransparentColor.alpha < a then
+              FtransparentColor := c;
+            end;
+          dec (x);
+          if (x < 0) then
+            begin
+            dec (y);
+            x := width-1;
+            end;
+          end;
+        end;
+      result := 1;
+      if none then
+        inc (result);
+      if half then
+        inc (result);
+  end;
+  procedure DetermineColorFormat;
+  begin
+    with AHeader do
+      case colortype of
+        0 : if FWordSized then
+              CFmt := cfGray16
+            else
+              CFmt := cfGray8;
+        2 : if FWordSized then
+              CFmt := cfBGR48
+            else
+              CFmt := cfBGR24;
+        4 : if FWordSized then
+              CFmt := cfGrayA32
+            else
+              CFmt := cfGrayA16;
+        6 : if FWordSized then
+              CFmt := cfABGR64
+            else
+              CFmt := cfABGR32;
+      end;
+  end;
+begin
+  with AHeader do
+    begin
+    // problem: TheImage has integer width, PNG header longword width.
+    //          Integer Swap can give negative value
+    writeln ('Using header, swapping width ',Theimage.Width);
+    Width := swap (longword(TheImage.Width));
+    writeln ('Swapping height ',TheImage.height);
+    height := swap (longword(TheImage.Height));
+    writeln (' - Width ',Width, '(',TheImage.Width,')');
+    writeln (' - height ', Height, '(',TheImage.Height,')');
+    writeln ('- Alpha');
+    if FUseAlpha then
+      c := CountAlphas
+    else
+      c := 0;
+    writeln ('- Colortype');
+    if FIndexed then
+      begin
+      if TheImage.UsePalette then
+        FPalette := TheImage.Palette
+      else
+        begin
+        FPalette := TFPPalette.Create (16);
+        FPalette.Build (TheImage);
+        end;
+      if ThePalette.count > 256 then
+        raise PNGImageException.Create ('To many colors to use indexed PNG color type');
+      ColorType := 3;
+      FUsetRNS := C > 1;
+      BitDepth := 8;
+      FByteWidth := 1;
+      end
+    else
+      begin
+      if c = 3 then
+        ColorType := 4;
+      FUsetRNS := (c = 2);
+      if not FGrayScale then
+        ColorType := ColorType + 2;
+      if FWordSized then
+        BitDepth := 16
+      else
+        BitDepth := 8;
+      DetermineColorFormat;
+      FByteWidth := BytesNeeded[CFmt];
+      writeln ('Color format ', ord(CFmt), ' bytes needed:',FByteWidth);
+      end;
+    writeln ('- Fixed values');
+    Compression := 0;
+    Filter := 0;
+    Interlace := 0;
+    end;
+end;
+
+procedure TFPWriterPNG.WriteIHDR;
+begin
+  // signature for PNG
+  writeln ('Signature to stream');
+  TheStream.writeBuffer(Signature,sizeof(Signature));
+  // Determine all settings for filling the header
+  writeln ('Filling header');
+  DetermineHeader (FHeader);
+  // write the header chunk
+  writeln ('Filling chunk');
+  SetChunkLength (13);   // (sizeof(FHeader)); gives 14 and is wrong !!
+  move (FHeader, ChunkDataBuffer^, 13);  // sizeof(FHeader));
+  SetChunkType (ctIHDR);
+  writeln ('writing chunk');
+  WriteChunk;
+  writeln ('Finished header');
+end;
+
+function TFPWriterPNG.GetColorPixel (x,y:longword) : TColorData;
+begin
+  result := ConvertColorToData(TheImage.Colors[x,y],CFmt);
+end;
+
+function TFPWriterPNG.GetPalettePixel (x,y:longword) : TColorData;
+begin
+  result := TheImage.Pixels[x,y];
+end;
+
+function TFPWriterPNG.GetColPalPixel (x,y:longword) : TColorData;
+begin
+  result := ThePalette.IndexOf (TheImage.Colors[x,y]);
+end;
+
+function TFPWriterPNG.DecideGetPixel : TGetPixelFunc;
+begin
+  case Fheader.colortype of
+    3 : if TheImage.UsePalette then
+          begin
+          result := @GetPalettePixel;
+          writeln ('GetPalettePixel');
+          end
+        else
+          begin
+          result := @GetColPalPixel;
+          writeln ('GetColPalPixel');
+          end;
+    else  begin
+          result := @GetColorPixel;
+          writeln ('GetColorPixel');
+          end
+  end;
+end;
+
+procedure TFPWriterPNG.WritePLTE;
+var r,t : integer;
+    c : TFPColor;
+begin
+  with ThePalette do
+    begin
+    SetChunkLength (count*3);
+    SetChunkType (ctPLTE);
+    t := 0;
+    For r := 0 to count-1 do
+      begin
+      c := Color[r];
+      ChunkdataBuffer^[t] := c.red div 256;
+      inc (t);
+      ChunkdataBuffer^[t] := c.green div 256;
+      inc (t);
+      ChunkdataBuffer^[t] := c.blue div 256;
+      inc (t);
+      end;
+    end;
+  WriteChunk;
+end;
+
+procedure TFPWriterPNG.InitWriteIDAT;
+begin
+  FDatalineLength := TheImage.Width*ByteWidth;
+  GetMem (FPreviousLine, FDatalineLength);
+  GetMem (FCurrentLine, FDatalineLength);
+  fillchar (FCurrentLine^,FDatalineLength,0);
+  ZData := TMemoryStream.Create;
+  Compressor := TCompressionStream.Create (clMax,ZData);
+  FGetPixel := DecideGetPixel;
+end;
+
+procedure TFPWriterPNG.FinalWriteIDAT;
+begin
+  ZData.Free;
+  FreeMem (FPreviousLine);
+  FreeMem (FCurrentLine);
+end;
+
+function TFPWriterPNG.DetermineFilter (Current, Previous:PByteArray; linelength:longword) : byte;
+begin
+  result := 0;
+end;
+
+procedure TFPWriterPNG.FillScanLine (y : integer; ScanLine : pByteArray);
+var r, x : integer;
+    cd : TColorData;
+    index : longword;
+begin
+  index := 0;
+  for x := 0 to pred(TheImage.Width) do
+    begin
+    cd := FGetPixel (x,y);
+    move (cd, ScanLine^[index], FBytewidth);
+    inc (index, FByteWidth);
+    end;
+end;
+
+procedure TFPWriterPNG.GatherData;
+var x,y : integer;
+    lf : byte;
+begin
+  for y := 0 to pred(TheImage.height) do
+    begin
+    write ('*');
+    FSwitchLine := FCurrentLine;
+    FCurrentLine := FPreviousLine;
+    FPreviousLine := FSwitchLine;
+    FillScanLine (y, FCurrentLine);
+    lf := DetermineFilter (FCurrentLine, FpreviousLine, FDataLineLength);
+    for x := 0 to FDatalineLength-1 do
+      FCurrentLine^[x] := DoFilter (lf, x, FCurrentLine^[x]);
+    Compressor.Write (lf, sizeof(lf));
+    Compressor.Write (FCurrentLine^, FDataLineLength);
+    end;
+  writeln;
+end;
+
+procedure TFPWriterPNG.WriteCompressedData;
+var l : longword;
+begin
+  Compressor.Free;  // Close compression and finish the writing in ZData
+  writeln (' -- ZData position: ',zdata.position, '  --  size: ',zdata.size);
+  l := ZData.position;
+  ZData.position := 0;
+  SetChunkLength(l);
+  SetChunkType (ctIDAT);
+  ZData.Read (ChunkdataBuffer^, l);
+  WriteChunk;
+end;
+
+procedure TFPWriterPNG.WriteIDAT;
+begin
+  InitWriteIDAT;
+  GatherData;
+  WriteCompressedData;
+  FinalWriteIDAT;
+end;
+
+procedure TFPWriterPNG.WritetRNS;
+  procedure PaletteAlpha;
+  var r : integer;
+  begin
+    with TheImage.palette do
+      begin
+      // search last palette entry with transparency
+      r := count;
+      repeat
+        dec (r);
+      until (r < 0) or (color[r].alpha <> alphaOpaque);
+      if r >= 0 then // there is at least 1 transparant color
+        begin
+        // from this color we go to the first palette entry
+        SetChunkLength (r+1);
+        repeat
+          chunkdatabuffer^[r] := (color[r].alpha shr 8);
+          dec (r);
+        until (r < 0);
+        end;
+      writechunk;
+      end;
+  end;
+  procedure GrayAlpha;
+  var g : word;
+  begin
+    SetChunkLength(2);
+    if WordSized then
+      g := ConvertColorToData (SingleTransparentColor, cfGray16)
+    else
+      g := ConvertColorToData (SingleTransparentColor, cfGray8);
+    g := swap (g);
+    move (g,ChunkDataBuffer^[0],2);
+    WriteChunk;
+  end;
+  procedure ColorAlpha;
+  var g : TFPColor;
+  begin
+    SetChunkLength(6);
+    g := SingleTransparentColor;
+    with g do
+      if WordSized then
+        begin
+        red := swap (red);
+        green := swap (green);
+        blue := swap (blue);
+        move (g, ChunkDatabuffer^[0], 6);
+        end
+      else
+        begin
+        ChunkDataBuffer^[0] := 0;
+        ChunkDataBuffer^[1] := red shr 8;
+        ChunkDataBuffer^[2] := 0;
+        ChunkDataBuffer^[3] := green shr 8;
+        ChunkDataBuffer^[4] := 0;
+        ChunkDataBuffer^[5] := blue shr 8;
+        end;
+    WriteChunk;
+  end;
+begin
+  SetChunkType (cttRNS);
+  case fheader.colortype of
+    6,4 : raise PNGImageException.create ('tRNS chunk forbidden for full alpha channels');
+    3 : PaletteAlpha;
+    2 : ColorAlpha;
+    0 : GrayAlpha;
+  end;
+end;
+
+procedure TFPWriterPNG.WriteTexts;
+begin
+end;
+
+procedure TFPWriterPNG.WriteIEND;
+begin
+  SetChunkLength(0);
+  SetChunkType (ctIEND);
+  WriteChunk;
+end;
+
+procedure TFPWriterPNG.InternalWrite (Str:TStream; Img:TFPCustomImage);
+begin
+  writeln ('PNG Writing');
+  WriteIHDR;
+  writeln ('Header finished');
+  if Fheader.colorType = 3 then
+    WritePLTE;
+  writeln ('Palette finished');
+  if FUsetRNS then
+    WritetRNS;
+  writeln ('Finished transparency');
+  WriteIDAT;
+  writeln ('Finished data');
+  WriteTexts;
+  writeln ('Finished Texts');
+  WriteIEND;
+  writeln ('Finished texts');
+end;
+
+end.

fcl/image/imgconv.pp

@@ -16,7 +16,7 @@
 {$mode objfpc}{$h+}
 program ImgConv;
 
-uses FPImage, FPWriteXPM, {FPWritePNG,} FPReadXPM, FPReadPNG, sysutils;
+uses FPImage, FPWriteXPM, FPWritePNG, FPReadXPM, FPReadPNG, sysutils;
 
 var img : TFPMemoryImage;
     reader : TFPCustomImageReader;
@@ -34,7 +34,7 @@ begin
   if T = 'X' then
     Writer := TFPWriterXPM.Create
   else
-    Writer := TFPWriterXPM.Create;
+    Writer := TFPWriterPNG.Create;
   img := TFPMemoryImage.Create(1,1);
 end;
 
@@ -44,7 +44,19 @@ begin
 end;
 
 procedure WriteImage;
+var t : string;
 begin
+  t := UpperCase(paramstr(3));
+  if (t[1] = 'P') then
+    with (Writer as TFPWriterPNG) do
+      begin
+      Grayscale := pos ('G', t) > 0;
+      Indexed := pos ('I', t) > 0;
+      WordSized := pos('W', t) > 0;
+      UseAlpha := pos ('A', t) > 0;
+      writeln ('Grayscale ',Grayscale, ' - Indexed ',Indexed,
+               ' - WordSized ',WordSized,' - UseAlpha ',UseAlpha);
+      end;
   img.SaveToFile (paramstr(4), Writer);
 end;
 
@@ -60,6 +72,9 @@ begin
     begin
     writeln ('Give filename to read and to write, preceded by filetype:');
     writeln ('X for XPM, P for PNG');
+    writeln ('imgconv X hello.xpm P hello.png');
+    writeln ('  The P has settings when writing:  G : grayscale,');
+    writeln ('    A : use alpha, I : Indexed in palette, W : Word sized.');
     end
   else
     try