+ Initial import into CVS

fcl/image/fpcolcnv.inc

@@ -0,0 +1,226 @@
+function FillOtherBits (initial:word;CorrectBits:byte):word;
+var r,c : byte;
+begin
+  c := 16 div CorrectBits;
+  result := initial;
+  for r := 1 to c do
+    result := (result shr CorrectBits) or result;
+end;
+
+function ShiftAndFill (initial:word; CorrectBits:byte):word;
+begin
+  result := FillOtherBits (initial shl (16-correctbits), correctbits);
+end;
+
+type
+  TColorBits = array [0..3] of TColorData;
+     // 0:alpha, 1:red, 2:green, 3:blue
+  TShiftBits = array [0..3] of shortint;
+
+const
+  ColorBits : array[cfRGB15..cfABGR64] of TColorBits = (
+    //          alpha       red        green      blue
+    {cfRGB15} ($00000000, $00007C00, $000003E0, $0000001F),
+    {cfRGB16} ($00000000, $00007C00, $000003E0, $0000001F),
+    {cfRGB24} ($00000000, $00FF0000, $0000FF00, $000000FF),
+    {cfRGB32} ($00000000, $00FF0000, $0000FF00, $000000FF),
+    {cfRGB48} ($00000000, $FFFF0000, $FFFF0000, $0000FFFF),
+    //                     shl 16
+    {cfRGBA8} ($00000003, $000000C0, $00000030, $0000000C),
+    {cfRGBA16}($0000000F, $0000F000, $00000F00, $000000F0),
+    {cfRGBA32}($000000FF, $FF000000, $00FF0000, $0000FF00),
+    {cfRGBA64}($0000FFFF, $FFFF0000, $FFFF0000, $FFFF0000),
+    //                    shl 32     shl 16
+    {cfBGR15} ($00000000, $0000001F, $000003E0, $00007C00),
+    {cfBGR16} ($00000000, $0000001F, $000003E0, $00007C00),
+    {cfBGR24} ($00000000, $000000FF, $0000FF00, $00FF0000),
+    {cfBGR32} ($00000000, $000000FF, $0000FF00, $00FF0000),
+    {cfBGR48} ($00000000, $0000FFFF, $FFFF0000, $FFFF0000),
+    //                                          shl 16
+    {cfABGR8} ($000000C0, $00000003, $0000000C, $00000030),
+    {cfABGR16}($0000F000, $0000000F, $000000F0, $00000F00),
+    {cfABGR32}($FF000000, $000000FF, $0000FF00, $00FF0000),
+    {cfABGR64}($FFFF0000, $0000FFFF, $FFFF0000, $FFFF0000)
+    //          shl 32                          shl 16
+  );
+  ShiftBits : array[cfRGB15..cfABGR64] of TShiftBits = (  // <0:shl, >0:shr
+    {cfRGB15} (  0,  -1,  -6, -11),
+    {cfRGB16} (  0,  -1,  -6, -11),
+    {cfRGB24} (  0,   8,   0,  -8),
+    {cfRGB32} (  0,   8,   0,  -8),
+    {cfRGB48} (  0,  32,  16,   0),
+    {cfRGBA8} (-14,  -8, -10, -12),
+    {cfRGBA16}(-12,   0,  -4,  -8),
+    {cfRGBA32}( -8,  16,   8,   0),
+    {cfRGBA64}(  0,  48,  32,  16),
+    {cfBGR15} (  0, -11,  -6,  -1),
+    {cfBGR16} (  0, -11,  -6,  -1),
+    {cfBGR24} (  0,  -8,   0,   8),
+    {cfBGR32} (  0,  -8,   0,   8),
+    {cfBGR48} (  0,   0,  16,  32),
+    {cfBGRA8} ( -8, -14, -12, -10),
+    {cfBGRA16}(  0, -12,  -8,  -4),
+    {cfBGRA32}( 16,  -8,   0,   8),
+    {cfBGRA64}( 48,   0,  16,  32)
+    );
+  Bitdepths : array[cfRGB15..cfABGR64] of byte=
+    (5,5,8,8,16, 2,4,8,16, 5,5,8,8,16, 2,4,8,16);
+
+function EnlargeColor (data:TColorData;CFmt:TColorFormat;component:byte):word;
+var w : word;
+    i : TColorData;
+    s : shortint;
+begin
+  i := data and ColorBits[CFmt,component];
+  s := ShiftBits[CFmt,component];
+  if s = 0 then
+    w := i
+  else if s < 0 then
+    w := i shl -s
+  else
+    w := i shr s;
+  result := FillOtherBits (w ,BitDepths[CFmt]);
+end;
+
+function ConvertColor (From : TColorData; FromFmt:TColorFormat) : TFPColor;
+  function SetGrayScale (value : word) : TFPColor;
+  begin
+    with result do
+      begin
+      red := Value;
+      green := value;
+      blue := Value;
+      end;
+  end;
+  function SetGrayScaleA (value : word) : TFPColor;
+  begin
+    result := SetGrayScale (value);
+    result.alpha := alphaOpaque;
+  end;
+begin
+  case FromFmt of
+    cfMono : result := SetGrayScaleA (ShiftAndFill(From,1));
+    cfGray2 : result := SetGrayScaleA (ShiftAndFill(From,2));
+    cfGray4 : result := SetGrayScaleA (ShiftAndFill(From,4));
+    cdGray8 : result := SetGrayScaleA (ShiftAndFill(From,8));
+    cfGray16 : result := SetGrayScaleA (From);
+    cfGray24 : result := SetGrayScaleA ((From and $00FFFF00) shr 8);
+    cfGrayA8 :
+      begin
+      result := SetGrayScale (FillOtherBits((From and $000000F0) shl 8,4));
+      result.alpha := ShiftAndFill((From and $0000000F),4);
+      end;
+    cfGrayA16 :
+      begin
+      result := SetGrayScale (FillOtherBits((From and $0000FF00),8));
+      result.alpha := ShiftAndFill((From and $000000FF),8);
+      end;
+    cfGrayA32 :
+      begin
+      result := SetGrayScale ((From and $FFFF0000) shr 16);
+      result.alpha := (From and $0000FFFF);
+      end;
+    cfRGB15,cfRGB16,cfRGB24,cfRGB32,cfRGB48,
+    cfBGR15,cfBGR16,cfBGR24,cfBGR32,cfBGR48 :
+      begin
+      result.alpha := AlphaOpaque;
+      result.red := EnlargeColor(From, FromFmt, 1);
+      result.green := EnlargeColor(From, FromFmt, 2);
+      result.blue := EnlargeColor(From, FromFmt, 3);
+      end;
+    cfRGBA8,cfRGBA16,cfRGBA32,cfRGBA64,
+    cfABGR8,cfABGR16,cfABGR32,cfABGR64 :
+      begin
+      result.alpha := EnlargeColor(From, FromFmt, 0);
+      result.red := EnlargeColor(From, FromFmt, 1);
+      result.green := EnlargeColor(From, FromFmt, 2);
+      result.blue := EnlargeColor(From, FromFmt, 3);
+      end;
+  end;
+end;
+
+function ConvertColor (From : TDeviceColor) : TFPColor;
+begin
+  result := ConvertColor (From.data, From.Fmt)
+end;
+
+function CalculateGray (c : TFPcolor; Bits:byte) : TColorData;
+var r : longword;
+begin
+end;
+
+function CalculateGrayA (c : TFPcolor; Bits:byte) : TColorData;
+var r : longword;
+    d : byte;
+begin
+  d := bits div 2;
+  r := CalculateGray (c, d);
+  result := r shl d;
+  r := c.alpha shr (16-d);
+  result := result or r;
+end;
+
+function ConvertColorToData (From : TFPColor; Fmt : TColorFormat) : TColorData;
+var sb : TShiftBits;
+    cb : TColorBits;
+  function MakeSample (Value:word; ToShift:shortint; ToUse:TColorData) : TColorData;
+  begin
+    result := Value;
+    if ToShift > 0 then
+      result := result shl ToShift
+    else
+      result := result shr ToShift;
+    result := result and ToUse;
+  end;
+begin
+  case Fmt of
+    cfMono : result := CalculateGray (From,1);
+    cfGray2 : result := CalculateGray (From,2);
+    cfGray4 : result := CalculateGray (From,4);
+    cdGray8 : result := CalculateGray (From,8);
+    cfGray16 : result := CalculateGray (From,16);
+    cfGray24 : result := CalculateGray (From,24);
+    cfGrayA8 : result := CalculateGrayA (From, 8);
+    cfGrayA16 : result := CalculateGrayA (From, 16);
+    cfGrayA32 : result := CalculateGrayA (From, 32);
+    cfRGB15,cfRGB16,cfRGB24,cfRGB32,cfRGB48,
+    cfBGR15,cfBGR16,cfBGR24,cfBGR32,cfBGR48 :
+      begin
+      sb := ShiftBits[Fmt];
+      cb := ColorBits[Fmt];
+      result := MakeSample(From.blue, sb[3], cb[3]) or
+                MakeSample(From.red, sb[1], cb[1]) or
+                MakeSample(From.green, sb[2], cb[2]);
+      end;
+    cfRGBA8,cfRGBA16,cfRGBA32,cfRGBA64,
+    cfABGR8,cfABGR16,cfABGR32,cfABGR64 :
+      begin
+      sb := ShiftBits[Fmt];
+      cb := ColorBits[Fmt];
+      result := MakeSample(From.alpha, sb[0], cb[0]) or
+                MakeSample(From.red, sb[1], cb[1]) or
+                MakeSample(From.green, sb[2], cb[2]) or
+                MakeSample(From.blue, sb[3], cb[3]);
+      end;
+  end;
+end;
+
+function ConvertColor (From : TFPColor; Fmt : TColorFormat) : TDeviceColor;
+begin
+  result.Fmt := Fmt;
+  result.data := convertColorToData(From, Fmt);
+end;
+
+function ConvertColorToData (From : TDeviceColor; Fmt : TColorFormat) : TColorData;
+var c : TFPColor;
+begin
+  c := ConvertColor (From);
+  result := ConvertColorToData (c, Fmt);
+end;
+
+function ConvertColor (From : TDeviceColor; Fmt : TColorFormat) : TDeviceColor;
+begin
+  result.Fmt := Fmt;
+  result.data := ConvertColorToData (From, Fmt);
+end;
+

fcl/image/fpcolors.inc

@@ -0,0 +1,34 @@
+const
+  BytesNeeded : array[TColorFormat] of byte =
+      (1,1,1,1,2,3,1,2,4,2,2,3,4,6,1,2,4,8,2,2,3,4,6,1,2,4,8);
+
+  alphaTransparant = $0000;
+  alphaOpaque      = $FFFF;
+  clTransparent: TFPColor = (Red: $0000; Green: $0000; Blue: $0000; Alpha: alphaTransparant);
+  clBlack      : TFPColor = (Red: $0000; Green: $0000; Blue: $0000; Alpha: alphaOpaque);
+  clBlue       : TFPColor = (Red: $0000; Green: $0000; Blue: $ffff; Alpha: alphaOpaque);
+  clGreen      : TFPColor = (Red: $0000; Green: $ffff; Blue: $0000; Alpha: alphaOpaque);
+  clCyan       : TFPColor = (Red: $0000; Green: $ffff; Blue: $ffff; Alpha: alphaOpaque);
+  clRed        : TFPColor = (Red: $ffff; Green: $0000; Blue: $0000; Alpha: alphaOpaque);
+  clMagenta    : TFPColor = (Red: $ffff; Green: $0000; Blue: $ffff; Alpha: alphaOpaque);
+  clYellow     : TFPColor = (Red: $ffff; Green: $ffff; Blue: $0000; Alpha: alphaOpaque);
+  clWhite      : TFPColor = (Red: $ffff; Green: $ffff; Blue: $ffff; Alpha: alphaOpaque);
+  clGray       : TFPColor = (Red: $8000; Green: $8000; Blue: $8000; Alpha: alphaOpaque);
+  clLtGray     : TFPColor = (Red: $c000; Green: $c000; Blue: $c000; Alpha: alphaOpaque);
+  clDkBlue     : TFPColor = (Red: $0000; Green: $0000; Blue: $8000; Alpha: alphaOpaque);
+  clDkGreen    : TFPColor = (Red: $0000; Green: $8000; Blue: $0000; Alpha: alphaOpaque);
+  clDkCyan     : TFPColor = (Red: $0000; Green: $8000; Blue: $8000; Alpha: alphaOpaque);
+  clDkRed      : TFPColor = (Red: $8000; Green: $0000; Blue: $0000; Alpha: alphaOpaque);
+  clDkMagenta  : TFPColor = (Red: $8000; Green: $0000; Blue: $8000; Alpha: alphaOpaque);
+  clDkYellow   : TFPColor = (Red: $8000; Green: $8000; Blue: $0000; Alpha: alphaOpaque);
+  clMaroon     : TFPColor = (Red: $8000; Green: $0000; Blue: $0000; Alpha: alphaOpaque);
+  clLtGreen    : TFPColor = (Red: $0000; Green: $8000; Blue: $0000; Alpha: alphaOpaque);
+  clOlive      : TFPColor = (Red: $8000; Green: $8000; Blue: $0000; Alpha: alphaOpaque);
+  clNavy       : TFPColor = (Red: $0000; Green: $0000; Blue: $8000; Alpha: alphaOpaque);
+  clPurple     : TFPColor = (Red: $8000; Green: $0000; Blue: $8000; Alpha: alphaOpaque);
+  clTeal       : TFPColor = (Red: $0000; Green: $8000; Blue: $8000; Alpha: alphaOpaque);
+  clSilver     : TFPColor = (Red: $c000; Green: $c000; Blue: $c000; Alpha: alphaOpaque);
+  clLime       : TFPColor = (Red: $0000; Green: $ffff; Blue: $0000; Alpha: alphaOpaque);
+  clFuchsia    : TFPColor = (Red: $ffff; Green: $0000; Blue: $ffff; Alpha: alphaOpaque);
+  clAqua       : TFPColor = (Red: $0000; Green: $ffff; Blue: $ffff; Alpha: alphaOpaque);
+

fcl/image/fphandler.inc

@@ -0,0 +1,243 @@
+{ TImageHandlersManager }
+
+constructor TImageHandlersManager.Create;
+begin
+  inherited create;
+  FData := Tlist.Create;
+end;
+
+destructor TImageHandlersManager.Destroy;
+var r : integer;
+begin
+  for r := FData.count-1 downto 0 do
+    TIHData(FData[r]).Free;
+  FData.Free;
+  inherited Destroy;
+end;
+
+function CalcDefExt (TheExtentions:string) : string;
+var p : integer;
+begin
+  p := pos (';',TheExtentions);
+  if p = 0 then
+    result := TheExtentions
+  else
+    result := copy(TheExtentions, 1, p-1);
+end;
+
+procedure TImageHandlersManager.RegisterImageHandlers (ATypeName,TheExtentions:string;
+                   AReader:TFPCustomImageReaderClass; AWriter:TFPCustomImageWriterClass);
+var ih : TIHData;
+begin
+  ih := GetData (ATypeName);
+  if assigned (ih) then
+    FPImgError (StrTypeAlreadyExist,[ATypeName]);
+  ih := TIHData.Create;
+  with ih do
+    begin
+    FTypeName := ATypeName;
+    FExtention := TheExtentions;
+    FDefaultExt := CalcDefExt (TheExtentions);
+    FReader := AReader;
+    FWriter := AWriter;
+    end;
+  FData.Add (ih);
+end;
+
+procedure TImageHandlersManager.RegisterImageReader (ATypeName,TheExtentions:string;
+                   AReader:TFPCustomImageReaderClass);
+var ih : TIHData;
+begin
+  ih := GetData (ATypeName);
+  if assigned (ih) then
+    begin
+      if assigned (ih.FReader) then
+        FPImgError (StrTypeReaderAlreadyExist,[ATypeName])
+      else
+        ih.FReader := AReader;
+    end
+  else
+    begin
+    ih := TIHData.Create;
+    with ih do
+      begin
+      FTypeName := ATypeName;
+      FExtention := TheExtentions;
+      FDefaultExt := CalcDefExt (TheExtentions);
+      FReader := AReader;
+      FWriter := nil;
+      end;
+    FData.Add (ih);
+    end;
+end;
+
+procedure TImageHandlersManager.RegisterImageWriter (ATypeName,TheExtentions:string;
+                   AWriter:TFPCustomImageWriterClass);
+var ih : TIHData;
+begin
+  ih := GetData (ATypeName);
+  if assigned (ih) then
+    begin
+    if assigned (ih.FWriter) then
+      FPImgError (StrTypeWriterAlreadyExist,[ATypeName])
+    else
+      ih.FWriter := AWriter;
+    end
+  else
+    begin
+    ih := TIHData.Create;
+    with ih do
+      begin
+      FTypeName := ATypeName;
+      FExtention := TheExtentions;
+      FDefaultExt := CalcDefExt (TheExtentions);
+      FReader := nil;
+      FWriter := AWriter;
+      end;
+    FData.Add (ih);
+    end;
+end;
+
+function TImageHandlersManager.GetCount : integer;
+begin
+  result := FData.Count;
+end;
+
+function TImageHandlersManager.GetData (ATypeName:string) : TIHData;
+var r : integer;
+begin
+  r := FData.count;
+  repeat
+    dec (r);
+  until (r < 0) or (compareText (TIHData(FData[r]).FTypeName, ATypeName) = 0);
+  if r >= 0 then
+    result := TIHData(FData[r])
+  else
+    result := nil;
+end;
+
+function TImageHandlersManager.GetTypeName (index:integer) : string;
+var ih : TIHData;
+begin
+  ih := TIHData (FData[index]);
+  result := ih.FTypeName;
+end;
+
+function TImageHandlersManager.GetReader (TypeName:string) : TFPCustomImageReaderClass;
+var ih : TIHData;
+begin
+  ih := GetData (TypeName);
+  if assigned(ih) then
+    result := ih.FReader
+  else
+    result := nil;
+end;
+
+function TImageHandlersManager.GetWriter (TypeName:string) : TFPCustomImageWriterClass;
+var ih : TIHData;
+begin
+  ih := GetData (TypeName);
+  if assigned(ih) then
+    result := ih.FWriter
+  else
+    result := nil;
+end;
+
+function TImageHandlersManager.GetExt (TypeName:string) : string;
+var ih : TIHData;
+begin
+  ih := GetData (TypeName);
+  if assigned(ih) then
+    result := ih.FExtention
+  else
+    result := '';
+end;
+
+function TImageHandlersManager.GetDefExt (TypeName:string) : string;
+var ih : TIHData;
+begin
+  ih := GetData (TypeName);
+  if assigned(ih) then
+    result := ih.FDefaultExt
+  else
+    result := '';
+end;
+
+{ TFPCustomImageHandler }
+
+constructor TFPCustomImageHandler.create;
+begin
+  inherited create;
+end;
+
+{ TFPCustomImageReader }
+
+constructor TFPCustomImageReader.Create;
+begin
+  inherited create;
+  FDefImageClass := TFPMemoryImage;
+end;
+
+function TFPCustomImageReader.ImageRead (Str:TStream; Img:TFPCustomImage) : TFPCustomImage;
+begin
+  try
+    if not assigned(Str) then
+      raise FPImageException.Create(ErrorText[StrNoStream]);
+    FStream := Str;
+    if not assigned(img) then
+      result := FDefImageClass.Create(0,0)
+    else
+      result := Img;
+    FImage := result;
+    writeln ('Checking contents');
+    if CheckContents (Str) then
+      begin
+      writeln ('Correct header(s), reading image');
+      InternalRead (Str, result)
+      end
+    else
+      raise FPImageException.Create ('Wrong image format');
+  finally
+    writeln ('ImageRead finally');
+    FStream := nil;
+    FImage := nil;
+  end;
+  writeln ('ImageRead end.');
+end;
+
+function TFPCustomImageReader.CheckContents (Str:TStream) : boolean;
+var InRead : boolean;
+begin
+  InRead := assigned(FStream);
+  if not assigned(Str) then
+    raise FPImageException.Create(ErrorText[StrNoStream]);
+  try
+    FSTream := Str;
+    result := InternalCheck (Str);
+  finally
+    if not InRead then
+      FStream := nil;
+  end;
+end;
+
+{ TFPCustomImageWriter }
+
+procedure TFPCustomImageWriter.ImageWrite (Str:TStream; Img:TFPCustomImage);
+begin
+  if not assigned(img) then
+    raise FPImageException.Create(ErrorText[StrNoImageToWrite]);
+  if not assigned(Str) then
+    raise FPImageException.Create(ErrorText[StrNoStream]);
+  try
+    FStream := str;
+    FImage := img;
+    Str.position := 0;
+    Str.Size := 0;
+    InternalWrite(Str, Img);
+  finally
+    FStream := nil;
+    FImage := nil;
+  end;
+end;
+
+

fcl/image/fpimage.inc

@@ -0,0 +1,276 @@
+{ TFPCustomImage }
+
+constructor TFPCustomImage.create (AWidth,AHeight:integer);
+begin
+  inherited create;
+  FExtra := TStringList.Create;
+  FWidth := 0;
+  FHeight := 0;
+  FPalette := nil;
+  SetSize (AWidth,AHeight);
+end;
+
+destructor TFPCustomImage.destroy;
+begin
+  FExtra.Free;
+  if assigned (FPalette) then
+    FPalette.Free;
+  inherited;
+end;
+
+procedure TFPCustomImage.LoadFromStream (Str:TStream; Handler:TFPCustomImagereader);
+begin
+  Handler.ImageRead (Str, self);
+end;
+
+procedure TFPCustomImage.LoadFromFile (filename:String; Handler:TFPCustomImageReader);
+var str : TStream;
+begin
+  if FileExists (filename) then
+    try
+      str := TFileStream.Create (filename, fmOpenRead);
+      LoadFromStream (str, handler);
+    finally
+      str.Free;
+    end
+  else
+    FPImgError (StrNoFile, [filename]);
+end;
+
+procedure TFPCustomImage.SaveToStream (Str:TStream; Handler:TFPCustomImageWriter);
+begin
+  Handler.ImageWrite (Str, Self);
+end;
+
+procedure TFPCustomImage.SaveToFile (filename:String; Handler:TFPCustomImageWriter);
+var str : TStream;
+begin
+  try
+    str := TFileStream.Create (filename, fmCreate);
+    SaveToStream (str, handler);
+  finally
+    str.Free;
+  end
+end;
+
+procedure TFPCustomImage.SetHeight (Value : integer);
+begin
+  if Value <> FHeight then
+    SetSize (FWidth, Value);
+end;
+
+procedure TFPCustomImage.SetWidth (Value : integer);
+begin
+  if Value <> FWidth then
+    SetSize (Value, FHeight);
+end;
+
+procedure TFPCustomImage.SetSize (AWidth, AHeight : integer);
+begin
+  FWidth := AWidth;
+  FHeight := AHeight;
+end;
+
+procedure TFPCustomImage.SetExtraValue (index:integer; AValue:string);
+var s : string;
+    p : integer;
+begin
+  s := FExtra[index];
+  p := pos ('=', s);
+  if p > 0 then
+    FExtra[index] := copy(s, 1, p) + AValue
+  else
+    FPImgError (StrInvalidIndex,[ErrorText[StrImageExtra],index]);
+end;
+
+function TFPCustomImage.GetExtraValue (index:integer) : string;
+var s : string;
+    p : integer;
+begin
+  s := FExtra[index];
+  p := pos ('=', s);
+  if p > 0 then
+    result := copy(s, p+1, maxint)
+  else
+    result := '';
+end;
+
+procedure TFPCustomImage.SetExtraKey (index:integer; AValue:string);
+var s : string;
+    p : integer;
+begin
+  s := FExtra[index];
+  p := pos('=',s);
+  if p > 0 then
+    s := AValue + copy(s,p,maxint)
+  else
+    s := AValue;
+  FExtra[index] := s;
+end;
+
+function TFPCustomImage.GetExtraKey (index:integer) : string;
+begin
+  result := FExtra.Names[index];
+end;
+
+procedure TFPCustomImage.SetExtra (key:String; AValue:string);
+begin
+  FExtra.values[key] := AValue;
+end;
+
+function TFPCustomImage.GetExtra (key:String) : string;
+begin
+  result := FExtra.values[key];
+end;
+
+function  TFPCustomImage.ExtraCount : integer;
+begin
+  result := FExtra.count;
+end;
+
+procedure TFPCustomImage.RemoveExtra (key:string);
+var p : integer;
+begin
+  p := FExtra.indexOfName(key);
+  if p >= 0 then
+    FExtra.Delete (p);
+end;
+
+procedure TFPCustomImage.SetPixel (x,y:integer; Value:integer);
+begin
+  CheckPaletteIndex (Value);
+  CheckIndex (x,y);
+  SetInternalPixel (x,y,Value);
+end;
+
+function TFPCustomImage.GetPixel (x,y:integer) : integer;
+begin
+  CheckIndex (x,y);
+  result := GetInternalPixel(x,y);
+end;
+
+procedure TFPCustomImage.SetColor (x,y:integer; Value:TFPColor);
+begin
+  CheckIndex (x,y);
+  SetInternalColor (x,y,Value);
+end;
+
+function TFPCustomImage.GetColor (x,y:integer) : TFPColor;
+begin
+  CheckIndex (x,y);
+  result := GetInternalColor(x,y);
+end;
+
+procedure TFPCustomImage.SetInternalColor (x,y:integer; Value:TFPColor);
+var i : integer;
+begin
+  i := FPalette.IndexOf (Value);
+  SetInternalPixel (x,y,i);
+end;
+
+function TFPCustomImage.GetInternalColor (x,y:integer) : TFPColor;
+begin
+  result := FPalette.Color[GetInternalPixel(x,y)];
+end;
+
+function TFPCustomImage.GetUsePalette : boolean;
+begin
+  result := assigned(FPalette);
+end;
+
+procedure TFPCustomImage.SetUsePalette (Value : boolean);
+begin
+  if Value <> assigned(FPalette) then
+    if Value then
+      FPalette := TFPPalette.Create (0)
+    else
+      begin
+      FPalette.Free;
+      FPalette := nil;
+      end;
+end;
+
+procedure TFPCustomImage.CheckPaletteIndex (PalIndex:integer);
+begin
+  if UsePalette then
+    begin
+    if (PalIndex < -1) or (PalIndex >= FPalette.Count) then
+      FPImgError (StrInvalidIndex,[ErrorText[StrPalette],PalIndex]);
+    end
+  else
+    FPImgError (StrNoPaletteAvailable);
+end;
+
+procedure TFPCustomImage.CheckIndex (x,y:integer);
+begin
+  if (x < 0) or (x >= FWidth) then
+    FPImgError (StrInvalidIndex,[ErrorText[StrImageX],x]);
+  if (y < 0) or (y >= FHeight) then
+    FPImgError (StrInvalidIndex,[ErrorText[StrImageY],y]);
+end;
+
+
+{ TFPMemoryImage }
+
+constructor TFPMemoryImage.Create (AWidth,AHeight:integer);
+begin
+  inherited create (AWidth,AHeight);
+  UsePalette := True;
+end;
+
+destructor TFPMemoryImage.Destroy;
+begin
+  FreeMem (FData);
+  inherited Destroy;
+end;
+
+function TFPMemoryImage.GetInternalPixel (x,y:integer) : integer;
+begin
+  result := FData^[y*FWidth+x];
+end;
+
+procedure TFPMemoryImage.SetInternalPixel (x,y:integer; Value:integer);
+begin
+  FData^[y*FWidth+x] := Value;
+end;
+
+function Lowest (a,b : integer) : integer;
+begin
+  if a <= b then
+    result := a
+  else
+    result := b;
+end;
+
+procedure TFPMemoryImage.SetSize (AWidth, AHeight : integer);
+var w, h, r, old : integer;
+    NewData : PFPIntegerArray;
+begin
+  if (AWidth <> Width) and (AHeight <> Height) then
+    begin
+    old := Height * Width;
+    r := SizeOf(integer)*AWidth*AHeight;
+    if r = 0 then
+      NewData := nil
+    else
+      begin
+      GetMem (NewData, r);
+      Fillchar (Newdata^[0], r, $FF);
+      end;
+    if (old <> 0) and assigned(FData) then
+      begin
+      if r <> 0 then
+        begin
+        w := Lowest(Width, AWidth);
+        h := Lowest(Height, AHeight);
+        for r := 0 to h do
+          move (FData^[r*Width], NewData^[r*AWidth], w);
+        end;
+      FreeMem (FData);
+      end;
+    FData := NewData;
+    inherited;
+    end;
+end;
+
+

fcl/image/fpimage.pp

@@ -0,0 +1,261 @@
+{$mode objfpc}{$h+}
+unit FPimage;
+
+interface
+
+uses sysutils, classes;
+
+type
+
+  TFPCustomImageReader = class;
+  TFPCustomImageWriter = class;
+  TFPCustomImage = class;
+
+  FPImageException = class (exception);
+
+  TFPColor = record
+    red,green,blue,alpha : word;
+  end;
+  PFPColor = ^TFPColor;
+
+  TColorFormat = (cfMono,cfGray2,cfGray4,cdGray8,cfGray16,cfGray24,
+                  cfGrayA8,cfGrayA16,cfGrayA32,
+                  cfRGB15,cfRGB16,cfRGB24,cfRGB32,cfRGB48,
+                  cfRGBA8,cfRGBA16,cfRGBA32,cfRGBA64,
+                  cfBGR15,cfBGR16,cfBGR24,cfBGR32,cfBGR48,
+                  cfABGR8,cfABGR16,cfABGR32,cfABGR64);
+  TColorData = int64;
+
+  TDeviceColor = record
+    Fmt : TColorFormat;
+    Data : TColorData;
+  end;
+
+  TFPColorArray = array [0..maxint] of TFPColor;
+  PFPColorArray = ^TFPColorArray;
+
+  TFPPalette = class
+    private
+      FData : PFPColorArray;
+      FCount, FCapacity : integer;
+      procedure SetCount (Value:integer);
+      function GetCount : integer;
+      procedure SetColor (index:integer; Value:TFPColor);
+      function GetColor (index:integer) : TFPColor;
+      procedure CheckIndex (index:integer);
+      procedure EnlargeData;
+    public
+      constructor create (ACount : integer);
+      destructor destroy; override;
+      procedure Build (Img : TFPCustomImage);
+      procedure Merge (pal : TFPPalette);
+      function IndexOf (AColor:TFPColor) : integer;
+      function Add (Value:TFPColor) : integer;
+      property Color [Index : integer] : TFPColor read GetColor write SetColor; default;
+      property Count : integer read GetCount write SetCount;
+  end;
+
+  TFPCustomImage = class
+    private
+      FExtra : TStringlist;
+      FPalette : TFPPalette;
+      FHeight, FWidth : integer;
+      procedure SetHeight (Value : integer);
+      procedure SetWidth (Value : integer);
+      procedure SetExtra (key:String; AValue:string);
+      function GetExtra (key:String) : string;
+      procedure SetExtraValue (index:integer; AValue:string);
+      function GetExtraValue (index:integer) : string;
+      procedure SetExtraKey (index:integer; AValue:string);
+      function GetExtraKey (index:integer) : string;
+      procedure CheckIndex (x,y:integer);
+      procedure CheckPaletteIndex (PalIndex:integer);
+      procedure SetColor (x,y:integer; Value:TFPColor);
+      function GetColor (x,y:integer) : TFPColor;
+      procedure SetPixel (x,y:integer; Value:integer);
+      function GetPixel (x,y:integer) : integer;
+      function GetUsePalette : boolean;
+      procedure SetUsePalette (Value:boolean);
+    protected
+      // Procedures to store the data. Implemented in descendants
+      procedure SetInternalColor (x,y:integer; Value:TFPColor); virtual;
+      function GetInternalColor (x,y:integer) : TFPColor; virtual;
+      procedure SetInternalPixel (x,y:integer; Value:integer); virtual; abstract;
+      function GetInternalPixel (x,y:integer) : integer; virtual; abstract;
+    public
+      constructor create (AWidth,AHeight:integer); virtual;
+      destructor destroy; override;
+      // Saving and loading
+      procedure LoadFromStream (Str:TStream; Handler:TFPCustomImageReader);
+      procedure LoadFromFile (filename:String; Handler:TFPCustomImageReader);
+      procedure SaveToStream (Str:TStream; Handler:TFPCustomImageWriter);
+      procedure SaveToFile (filename:String; Handler:TFPCustomImageWriter);
+      // Size and data
+      procedure SetSize (AWidth, AHeight : integer); virtual;
+      property  Height : integer read FHeight write SetHeight;
+      property  Width : integer read FWidth write SetWidth;
+      property  Colors [x,y:integer] : TFPColor read GetColor write SetColor; default;
+      // Use of palette for colors
+      property  UsePalette : boolean read GetUsePalette write SetUsePalette;
+      property  Palette : TFPPalette read FPalette;
+      property  Pixels [x,y:integer] : integer read GetPixel write SetPixel;
+      // Info unrelated with the image representation
+      property  Extra [key:string] : string read GetExtra write SetExtra;
+      property  ExtraValue [index:integer] : string read GetExtraValue write SetExtraValue;
+      property  ExtraKey [index:integer] : string read GetExtraKey write SetExtraKey;
+      procedure RemoveExtra (key:string);
+      function  ExtraCount : integer;
+  end;
+  TFPCustomImageClass = class of TFPCustomImage;
+
+  TFPIntegerArray = array [0..maxint] of integer;
+  PFPIntegerArray = ^TFPIntegerArray;
+
+  TFPMemoryImage = class (TFPCustomImage)
+    private
+      FData : PFPIntegerArray;
+    protected
+      procedure SetInternalPixel (x,y:integer; Value:integer); override;
+      function GetInternalPixel (x,y:integer) : integer; override;
+    public
+      constructor create (AWidth,AHeight:integer); override;
+      destructor destroy; override;
+      procedure SetSize (AWidth, AHeight : integer); override;
+  end;
+
+  TFPCustomImageHandler = class
+    private
+      FStream : TStream;
+      FImage : TFPCustomImage;
+    protected
+      property TheStream : TStream read FStream;
+      property TheImage : TFPCustomImage read FImage;
+    public
+      constructor Create; virtual;
+  end;
+
+  TFPCustomImageReader = class (TFPCustomImageHandler)
+    private
+      FDefImageClass:TFPCustomImageClass;
+    protected
+      procedure InternalRead  (Str:TStream; Img:TFPCustomImage); virtual; abstract;
+      function  InternalCheck (Str:TStream) : boolean; virtual; abstract;
+    public
+      constructor create; override;
+      function ImageRead (Str:TStream; Img:TFPCustomImage) : TFPCustomImage;
+      // reads image
+      function CheckContents (Str:TStream) : boolean;
+      // Gives True if contents is readable
+      property DefaultImageClass : TFPCustomImageClass read FDefImageClass write FDefImageClass;
+      // Image Class to create when no img is given for reading
+  end;
+  TFPCustomImageReaderClass = class of TFPCustomImageReader;
+
+  TFPCustomImageWriter = class (TFPCustomImageHandler)
+    protected
+      procedure InternalWrite (Str:TStream; Img:TFPCustomImage); virtual; abstract;
+    public
+      procedure ImageWrite (Str:TStream; Img:TFPCustomImage);
+      // writes given image to stream
+  end;
+  TFPCustomImageWriterClass = class of TFPCustomImageWriter;
+
+  TIHData = class
+    private
+      FExtention, FTypeName, FDefaultExt : string;
+      FReader : TFPCustomImageReaderClass;
+      FWriter : TFPCustomImageWriterClass;
+  end;
+
+  TImageHandlersManager = class
+    private
+      FData : TList;
+      function Getreader (TypeName:string) : TFPCustomImageReaderClass;
+      function GetWriter (TypeName:string) : TFPCustomImageWriterClass;
+      function GetExt (TypeName:string) : string;
+      function GetDefExt (TypeName:string) : string;
+      function GetTypeName (index:integer) : string;
+      function GetData (ATypeName:string) : TIHData;
+      function GetCount : integer;
+    public
+      constructor Create;
+      destructor Destroy; override;
+      procedure RegisterImageHandlers (ATypeName,TheExtentions:string;
+                   AReader:TFPCustomImageReaderClass; AWriter:TFPCustomImageWriterClass);
+      procedure RegisterImageReader (ATypeName,TheExtentions:string;
+                   AReader:TFPCustomImageReaderClass);
+      procedure RegisterImageWriter (ATypeName,TheExtentions:string;
+                   AWriter:TFPCustomImageWriterClass);
+      property Count : integer read GetCount;
+      property ImageReader [TypeName:string] : TFPCustomImageReaderClass read GetReader;
+      property ImageWriter [TypeName:string] : TFPCustomImageWriterClass read GetWriter;
+      property Extentions [TypeName:string] : string read GetExt;
+      property DefaultExtention [TypeName:string] : string read GetDefExt;
+      property TypeNames [index:integer] : string read GetTypeName;
+    end;
+
+function ShiftAndFill (initial:word; CorrectBits:byte):word;
+function FillOtherBits (initial:word;CorrectBits:byte):word;
+function ConvertColor (From : TDeviceColor) : TFPColor;
+function ConvertColor (From : TColorData; FromFmt:TColorFormat) : TFPColor;
+function ConvertColorToData (From : TFPColor; Fmt : TColorFormat) : TColorData;
+function ConvertColorToData (From : TDeviceColor; Fmt : TColorFormat) : TColorData;
+function ConvertColor (From : TFPColor; Fmt : TColorFormat) : TDeviceColor;
+function ConvertColor (From : TDeviceColor; Fmt : TColorFormat) : TDeviceColor;
+
+operator = (const c,d:TFPColor) : boolean;
+
+var ImageHandlers : TImageHandlersManager;
+
+type
+  TErrorTextIndices = (StrInvalidIndex, StrNoImageToWrite, StrNoFile,
+    StrNoStream, StrPalette, StrImageX, StrImageY, StrImageExtra,
+    StrTypeAlreadyExist,StrTypeReaderAlreadyExist,StrTypeWriterAlreadyExist,
+    StrNoPaletteAvailable);
+
+const
+  ErrorText : array[TErrorTextIndices] of string =
+    ('Invalid %s index %d', 'No image to write', 'File "%s" does not exist',
+     'No stream to write to', 'palette', 'horizontal pixel', 'vertical pixel', 'extra',
+     'Image type "%s" already exists','Image type "%s" already has a reader class',
+     'Image type "%s" already has a writer class', 'No palette available');
+
+{$i FPColors.inc}
+
+implementation
+
+procedure FPImgError (Fmt:TErrorTextIndices; data : array of const);
+begin
+  raise FPImageException.CreateFmt (ErrorText[Fmt],data);
+end;
+
+procedure FPImgError (Fmt:TErrorTextIndices);
+begin
+  raise FPImageException.Create (ErrorText[Fmt]);
+end;
+
+{$i FPPalette.inc}
+{$i FPHandler.inc}
+{$i FPImage.inc}
+{$i FPColCnv.inc}
+
+operator = (const c,d:TFPColor) : boolean;
+begin
+  result := (c.Red = d.Red) and
+            (c.Green = d.Green) and
+            (c.Blue = d.Blue) and
+            (c.Alpha = d.Alpha);
+end;
+
+initialization
+  ImageHandlers := TImageHandlersManager.Create;
+  ColorBits [cfRGBA64,1] := ColorBits [cfRGBA64,0] shl 32;
+  ColorBits [cfRGBA64,2] := ColorBits [cfRGBA64,1] 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;
+finalization
+  ImageHandlers.Free;
+
+end.

fcl/image/fpimgcmn.pp

@@ -0,0 +1,103 @@
+{$mode objfpc}{$h+}
+unit FPImgCmn;
+
+interface
+
+type
+  TByteArray = array[0..maxint] of byte;
+  PByteArray = ^TByteArray;
+
+function Swap(This : Longword): longword;
+function Swap(This : integer): integer;
+function Swap(This : Word): Word;
+function CalculateCRC (var data; alength:integer) : longword;
+function CalculateCRC (CRC:longword; var data; alength:integer) : longword;
+
+implementation
+
+uses sysutils;
+
+function Swap(This : Word): Word;
+var
+  Tmp1, Tmp2 : Byte;
+  AWord      : Word;
+begin
+  Tmp1 := This AND $00FF;
+  Tmp2 := (This AND $FF00) SHR 8;
+  AWord := Tmp1;
+  result := (AWord SHL 8) + Tmp2;
+end;
+
+function Swap(This : integer): integer;
+var r,p : ^longword;
+  res : integer;
+begin
+  p := @This;
+  r := @res;
+  r^ := Swap (p^);
+  result := res;
+end;
+
+function Swap(This : longword): longword;
+var
+  TmpW1 : Word;
+  TmpB1,
+  TmpB2 : Byte;
+  AnInt : longword;
+begin
+  TmpW1 := This AND $0000FFFF;
+  TmpB1 := TmpW1 AND $00FF;
+  TmpB2 := (TmpW1 AND $FF00) SHR 8;
+  AnInt := TmpB1;
+  AnInt := (AnInt SHL 8) + TmpB2;
+  TmpW1 := (This AND $FFFF0000) SHR 16;
+  TmpB1 := TmpW1 AND $00FF;
+  TmpB2 := (TmpW1 AND $FF00) SHR 8;
+  TmpW1 := TmpB1;
+  result := (AnInt SHL 16) + (TmpW1 SHL 8) + TmpB2;
+end;
+
+var CRCtable : array[0..255] of longword;
+
+procedure MakeCRCtable;
+var c : longword;
+    r, t : integer;
+begin
+  for r := 0 to 255 do
+    begin
+    c := r;
+    for t := 0 to 7 do
+      begin
+      if (c and 1) = 1 then
+        c := $EDB88320 xor (c shr 1)
+      else
+        c := c shr 1
+      end;
+    CRCtable[r] := c;
+    end;
+end;
+
+function CalculateCRC (CRC:longword; var data; alength:integer) : longword;
+var d : pbyte;
+    r, t : integer;
+begin
+  d := @data;
+  result := CRC;
+  for r := 0 to alength-1 do
+    begin
+    t := (byte(result) xor d^);
+    result := CRCtable[t] xor (result shr 8);
+    inc (longword(d));
+    end;
+end;
+
+function CalculateCRC (var data; alength:integer) : longword;
+var f : longword;
+begin
+  f := CalculateCRC($FFFFFFFF, data, alength);
+  result := f xor $FFFFFFFF;
+end;
+
+initialization
+  MakeCRCtable;
+end.

fcl/image/fppalette.inc

@@ -0,0 +1,131 @@
+{ TFPPalette }
+
+constructor TFPPalette.create (ACount : integer);
+begin
+  inherited create;
+  if aCount > 0 then
+    getmem (FData, sizeof(TFPColor)*ACount)
+  else
+    FData := nil;
+  FCapacity := ACount;
+  SetCount (ACount);
+end;
+
+destructor TFPPalette.destroy;
+begin
+  if FCapacity > 0 then
+    freemem (FData);
+  inherited;
+end;
+
+procedure TFPPalette.Build (Img : TFPCustomImage);
+var x,y : integer;
+begin
+  if (Img.Palette <> self) then
+    begin
+    Count := 0;
+    for x := 0 to img.width-1 do
+      for y := 0 to img.height-1 do
+        IndexOf(img[x,y]);
+    end;
+end;
+
+procedure TFPPalette.Merge (pal : TFPPalette);
+var r : integer;
+begin
+  for r := 0 to pal.count-1 do
+    IndexOf (pal[r]);
+end;
+
+procedure TFPPalette.CheckIndex (index:integer);
+begin
+  if (index >= FCount) or (index < 0) then
+    FPImgError (StrInvalidIndex,[ErrorText[StrPalette],index]);
+end;
+
+function TFPPalette.Add (Value:TFPColor) : integer;
+begin
+  result := FCount;
+  inc (FCount);
+  if FCount > FCapacity then
+    EnlargeData;
+  FData^[result] := Value;
+end;
+
+procedure TFPPalette.SetColor (index:integer; Value:TFPColor);
+begin
+  if index = FCount then
+    Add (Value)
+  else
+    begin
+    CheckIndex (index);
+    FData^[index] := Value;
+    end;
+end;
+
+function TFPPalette.GetColor (index:integer) : TFPColor;
+begin
+  CheckIndex (index);
+  result := FData^[index];
+end;
+
+function TFPPalette.GetCount : integer;
+begin
+  result := FCount;
+end;
+
+procedure TFPPalette.EnlargeData;
+var old : integer;
+    NewData : PFPColorArray;
+begin
+  old := FCapacity;
+  if FCapacity <= 16 then
+    FCapacity := 32
+  else if FCapacity <= 128 then
+    FCapacity := 256
+  else
+    inc (FCapacity, 256);
+  GetMem (NewData, sizeof(TFPColor)*FCapacity);
+  if old > 0 then
+    begin
+    move (FData^[0], NewData^[0], sizeof(TFPColor)*FCount);
+    FreeMem (FData);
+    end;
+  FData := NewData;
+end;
+
+procedure TFPPalette.SetCount (Value:integer);
+var NewData : PFPColorArray;
+    O : integer;
+begin
+  if Value <> FCount then
+    begin
+    if Value > FCapacity then
+      begin
+      O := FCapacity;
+      FCapacity := Value + 8;
+      if FCapacity > 0 then
+        GetMem (NewData, sizeof(TFPColor)*FCapacity)
+      else
+        FData := nil;
+      move (FData^, NewData^, sizeof(TFPColor)*FCount);
+      if O > 0 then
+        FreeMem (FData);
+      FData := NewData;
+      end;
+    for o := FCount to Value-1 do
+      FData^[o] := clBlack;
+    FCount := Value;
+    end;
+end;
+
+function TFPPalette.IndexOf (AColor:TFPColor) : integer;
+begin
+  result := FCount;
+  repeat
+    dec (result);
+  until (result < 0) or (FData^[result]=AColor);
+  if result < 0 then
+    result := Add (AColor);
+end;
+

fcl/image/fpreadpng.pp

@@ -0,0 +1,593 @@
+{$mode objfpc}{$h+}
+unit FPReadPNG;
+
+interface
+
+uses
+  Classes, FPImage, FPImgCmn, PNGComn, ZStream;
+
+Type
+
+  TSetPixelProc = procedure (x,y:integer; CD : TColordata) of object;
+
+  TFPReaderPNG = class (TFPCustomImageReader)
+    private
+      Chunk : TChunk;
+      FHeader : THeaderChunk;
+      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
+      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
+      FSwitchLine, FCurrentLine, FPreviousLine : pByteArray;
+      FPalette : TFPPalette;
+      FSetPixel : TSetPixelProc;
+      procedure ReadChunk;
+      procedure HandleData;
+      procedure HandleUnknown;
+    protected
+      UseTransparent, EndOfFile : boolean;
+      TransparentDataValue : TColorData;
+      function CurrentLine(x:longword) : byte;
+      function PrevSample (x:longword): byte;
+      function PreviousLine (x:longword) : byte;
+      function PrevLinePrevSample (x:longword): byte;
+      procedure HandleChunk; virtual;
+      procedure HandlePalette; virtual;
+      procedure HandleAlpha; virtual;
+      procedure DoDecompress; virtual;
+      function  DoFilter(LineFilter:byte;index:longword; b:byte) : byte; virtual;
+      procedure SetPalettePixel (x,y:integer; CD : TColordata);
+      procedure SetPalColPixel (x,y:integer; CD : TColordata);
+      procedure SetColorPixel (x,y:integer; CD : TColordata);
+      procedure SetColorTrPixel (x,y:integer; CD : TColordata);
+      function DecideSetPixel : TSetPixelProc; virtual;
+      procedure InternalRead  (Str:TStream; Img:TFPCustomImage); override;
+      function  InternalCheck (Str:TStream) : boolean; override;
+      property ColorFormat : TColorformat read CFmt;
+      property CurrentPass : byte read FCurrentPass;
+      property Pltte : boolean read FPltte;
+      property ThePalette : TFPPalette read FPalette;
+      property Header : THeaderChunk read FHeader;
+    public
+      constructor create; override;
+      destructor destroy; override;
+  end;
+
+implementation
+
+uses sysutils;
+
+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 TFPReaderPNG.create;
+begin
+  inherited;
+  chunk.acapacity := 0;
+  chunk.data := nil;
+  UseTransparent := False;
+end;
+
+destructor TFPReaderPNG.destroy;
+begin
+  with chunk do
+    if acapacity > 0 then
+      freemem (data);
+  inherited;
+end;
+
+procedure TFPReaderPNG.ReadChunk;
+
+var ChunkHeader : TChunkHeader;
+    readCRC : longword;
+    l : longword;
+begin
+  TheStream.Read (ChunkHeader,sizeof(ChunkHeader));
+  with chunk do
+    begin
+    // chunk header
+    with ChunkHeader do
+      begin
+      alength := swap(CLength);
+      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');
+    TheStream.Read (readCRC, sizeof(ReadCRC));
+    l := CalculateCRC (All1Bits, ReadType, sizeOf(ReadType));
+    l := CalculateCRC (l, data^, alength);
+    l := swap(l xor All1Bits);
+    if ReadCRC <> l then
+      raise PNGImageException.Create ('CRC check failed');
+    end;
+end;
+
+procedure TFPReaderPNG.HandleData;
+var OldSize : longword;
+begin
+  OldSize := ZData.size;
+  ZData.Size := OldSize + Chunk.aLength;
+  ZData.Write (chunk.Data^, chunk.aLength);
+end;
+
+procedure TFPReaderPNG.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 16) + a;
+          ThePalette[r] := c;
+          end;
+        end;
+    end;
+  procedure TransparentGray;
+    var a : word;
+    begin
+    move (chunk.data^[0], a, 2);
+    a := swap (a);
+    TransparentDataValue := a;
+    UseTransparent := True;
+    end;
+  procedure TransparentColor;
+    var d : byte;
+        r,g,b : word;
+        a : TColorData;
+    begin
+      with chunk do
+        begin
+        move (data^[0], r, 2);
+        move (data^[2], g, 2);
+        move (data^[4], b, 2);
+        end;
+      d := header.bitdepth;
+      a := (b shl d) shl d;
+      a := a + (g shl d) + r;
+      TransparentDataValue := a;
+      UseTransparent := True;
+    end;
+begin
+  case header.ColorType of
+    3 : PaletteAlpha;
+    0 : TransparentGray;
+    2 : TransparentColor;
+  end;
+end;
+
+procedure TFPReaderPNG.HandlePalette;
+var r : longword;
+    c : TFPColor;
+begin
+  if header.colortype = 3 then
+    with chunk do
+      begin
+      if TheImage.UsePalette then
+        FPalette := TheImage.Palette
+      else
+        FPalette := TFPPalette.Create(1);
+      c.Alpha := AlphaOpaque;
+      if (aLength mod 3) > 0 then
+        raise PNGImageException.Create ('Impossible length for PLTE-chunk');
+      r := 0;
+      while r < alength do
+        begin
+        c.red := ShiftAndFill(data^[r], 8);
+        inc (r);
+        c.green := ShiftAndFill(data^[r], 8);
+        inc (r);
+        c.blue := ShiftAndFill(data^[r], 8);
+        inc (r);
+        ThePalette.Add (c);
+        end;
+      end;
+end;
+
+procedure TFPReaderPNG.SetPalettePixel (x,y:integer; CD : TColordata);
+begin  // both PNG and palette have palette
+  TheImage.Pixels[x,y] := CD
+end;
+
+procedure TFPReaderPNG.SetPalColPixel (x,y:integer; CD : TColordata);
+begin  // PNG with palette, Img without
+  TheImage.Colors[x,y] := ThePalette[CD];
+end;
+
+procedure TFPReaderPNG.SetColorPixel (x,y:integer; CD : TColordata);
+var c : TFPColor;
+begin  // both PNG and Img work without palette, and no transparency colordata
+  c := ConvertColor (CD,CFmt);
+  TheImage.Colors[x,y] := c;
+end;
+
+procedure TFPReaderPNG.SetColorTrPixel (x,y:integer; CD : TColordata);
+var c : TFPColor;
+begin  // both PNG and Img work without palette, and there is a transparency colordata
+  if TransparentDataValue = CD then
+    c := clTransparent
+  else
+    c := ConvertColor (CD,CFmt);
+  TheImage.Colors[x,y] := c;
+end;
+
+function TFPReaderPNG.CurrentLine(x:longword):byte;
+begin
+  result := FCurrentLine^[x];
+end;
+
+function TFPReaderPNG.PrevSample (x:longword): byte;
+begin
+  if x < byteWidth then
+    result := 0
+  else
+    result := FCurrentLine^[x - bytewidth];
+end;
+
+function TFPReaderPNG.PreviousLine (x:longword) : byte;
+begin
+  result := FPreviousline^[x];
+end;
+
+function TFPReaderPNG.PrevLinePrevSample (x:longword): byte;
+begin
+  if x < byteWidth then
+    result := 0
+  else
+    result := FPreviousLine^[x - bytewidth];
+end;
+
+function TFPReaderPNG.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;
+  result := (b + diff) mod $100;
+end;
+
+function TFPReaderPNG.DecideSetPixel : TSetPixelProc;
+begin
+  if Pltte then
+    if TheImage.UsePalette then
+      result := @SetPalettePixel
+    else
+      result := @SetPalColPixel
+  else
+    if UseTransparent then
+      result := @SetColorTrPixel
+    else
+      result := @SetColorPixel;
+end;
+
+procedure TFPReaderPNG.DoDecompress;
+
+  procedure initVars;
+  var r,d : integer;
+  begin
+    with Header do
+      begin
+      if interlace=0 then
+        begin
+        StartPass := 0;
+        EndPass := 0;
+        CountScanlines[0] := Height;
+        ScanLineLength[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);
+          CountScanLines[r] := d;
+          d := width div delta[r,0];
+          if (width mod delta[r,0]) > startpoints[r,0] then
+            inc (d);
+          ScanLineLength[r] := d;
+          end;
+        end;
+      Fpltte := (ColorType = 3);
+      case colortype of
+        0 : case Bitdepth of
+              1  : CFmt := cfMono;
+              2  : CFmt := cfGray2;
+              4  : CFmt := cfGray4;
+              8  : CFmt := cdGray8;
+              16 : CFmt := cfGray16;
+            end;
+        2 : if BitDepth = 8 then
+              CFmt := cfBGR24
+            else
+              CFmt := cfBGR48;
+        4 : if BitDepth = 8 then
+              CFmt := cfGrayA16
+            else
+              CFmt := cfGrayA32;
+        6 : if BitDepth = 8 then
+              CFmt := cfABGR32
+            else
+              CFmt := cfABGR64;
+      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;
+
+  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;
+  begin
+    FSetPixel := DecideSetPixel;
+    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;
+      GetMem (FPreviousLine, l);
+      GetMem (FCurrentLine, l);
+      fillchar (FCurrentLine^,l,0);
+      try
+        for ry := 0 to CountScanlines[rp]-1 do
+          begin
+          FSwitchLine := FCurrentLine;
+          FCurrentLine := FPreviousLine;
+          FPreviousLine := FSwitchLine;
+          Y := CalcY(ry);
+          Decompress.Read (lf, sizeof(lf));
+          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
+          end;
+      finally
+        freemem (FPreviousLine);
+        freemem (FCurrentLine);
+      end;
+      end;
+  end;
+
+begin
+  InitVars;
+  DeCode;
+end;
+
+procedure TFPReaderPNG.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 TFPReaderPNG.HandleUnknown;
+begin
+  if (chunk.readtype[1] in ['A'..'Z']) then
+    raise PNGImageException.Create('Critical chunk '+chunk.readtype+' not recognized');
+  //writeln ('Unhandled chunk ',chunk.readtype);
+end;
+
+procedure TFPReaderPNG.InternalRead (Str:TStream; Img:TFPCustomImage);
+begin
+  with Header do
+    Img.SetSize (Width, Height);
+  ZData := TMemoryStream.Create;
+  try
+    EndOfFile := false;
+    while not EndOfFile do
+      begin
+      ReadChunk;
+      HandleChunk;
+      end;
+    Decompress := TDecompressionStream.Create (ZData);
+    try
+      Decompress.position := 0;
+      DoDecompress;
+    finally
+      Decompress.Free;
+    end;
+  finally
+    ZData.Free;
+    if not img.UsePalette and assigned(FPalette) then
+      begin
+      FPalette.Free;
+      end;
+  end;
+end;
+
+function  TFPReaderPNG.InternalCheck (Str:TStream) : boolean;
+var SigCheck : array[0..7] of byte;
+    r : integer;
+begin
+  try
+    // Check Signature
+    Str.Read(SigCheck, SizeOf(SigCheck));
+    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;
+    move (chunk.data^, FHeader, sizeof(Header));
+    with header do
+      begin
+      Width := swap(width);
+      height := swap (height);
+      result := (width > 0) and (height > 0) and (compression = 0)
+                and (filter = 0) and (Interlace in [0,1]);
+      writeln ('Header:');
+      writeln ('  Width: ',width);
+      writeln ('  Height: ',Height);
+      writeln ('  compression ',compression);
+      writeln ('  filter ',filter);
+      writeln ('  interlace ',interlace);
+      writeln ('  ColorType ',ColorType);
+      writeln ('  BitDepth ',BitDepth);
+      end;
+  except
+    on e : exception do
+      begin
+      result := false;
+      end;
+  end;
+end;
+
+end.
+

fcl/image/fpreadxpm.pp

@@ -0,0 +1,307 @@
+{$mode objfpc}{$h+}
+unit FPReadXPM;
+
+interface
+
+uses FPImage, classes, sysutils;
+
+type
+  TFPReaderXPM = class (TFPCustomImageReader)
+    private
+      width, height, ncols, cpp, xhot, yhot : integer;
+      xpmext : boolean;
+      palette : TStringList;
+      function HexToColor(s : string) : TFPColor;
+      function NameToColor(s : string) : TFPColor;
+      function DiminishWhiteSpace (s : string) : string;
+    protected
+      procedure InternalRead  (Str:TStream; Img:TFPCustomImage); override;
+      function  InternalCheck (Str:TStream) : boolean; override;
+    public
+      constructor Create; override;
+      destructor Destroy; override;
+  end;
+
+implementation
+
+const
+  WhiteSpace = ' '#8#10#13;
+
+constructor TFPReaderXPM.create;
+begin
+  inherited create;
+  palette := TStringList.Create;
+end;
+
+destructor TFPReaderXPM.Destroy;
+begin
+  Palette.Free;
+  inherited destroy;
+end;
+
+function TFPReaderXPM.HexToColor(s : string) : TFPColor;
+var l : integer;
+  function CharConv (c : char) : longword;
+  begin
+    if (c >= 'A') and (c <= 'F') then
+      result := ord (c) - ord('A') + 10
+    else if (c >= '0') and (c <= '9') then
+      result := ord (c) - ord('0')
+    else
+      raise exception.CreateFmt ('Wrong character (%s) in hexadecimal number', [c]);
+  end;
+  function convert (n : string) : word;
+  var t,r, shift : integer;
+  begin
+    shift := 0;
+    result := 0;
+    t := length(n);
+    if t > 4 then
+      raise exception.CreateFmt ('To many bytes for color (%s)',[s]);
+    for r := length(n) downto 1 do
+      begin
+      result := result + (CharConv(n[r]) shl shift);
+      inc (shift,4);
+      end;
+  end;
+begin
+  s := uppercase (s);
+  l := length(s) div 3;
+  result.red   := (Convert(copy(s,1,l)));
+  result.green := (Convert(copy(s,l+1,l)));
+  result.blue  :=  Convert(copy(s,l+l+1,l));
+end;
+
+function TFPReaderXPM.NameToColor(s : string) : TFPColor;
+begin
+  s := lowercase (s);
+  if s = 'transparent' then
+    result := clTransparent
+  else if s = 'none' then
+    result := clTransparent
+  else if s = 'black' then
+    result := clBlack
+  else if s = 'blue' then
+    result := clBlue
+  else if s = 'green' then
+    result := clGreen
+  else if s = 'cyan' then
+    result := clCyan
+  else if s = 'red' then
+    result := clRed
+  else if s = 'magenta' then
+    result := clMagenta
+  else if s = 'yellow' then
+    result := clYellow
+  else if s = 'white' then
+    result := clWhite
+  else if s = 'gray' then
+    result := clGray
+  else if s = 'ltgray' then
+    result := clLtGray
+  else if s = 'dkblue' then
+    result := clDkBlue
+  else if s = 'dkgreen' then
+    result := clDkGreen
+  else if s = 'dkcyan' then
+    result := clDkCyan
+  else if s = 'dkred' then
+    result := clDkRed
+  else if s = 'dkmagenta' then
+    result := clDkMagenta
+  else if s = 'dkyellow' then
+    result := clDkYellow
+  else if s = 'maroon' then
+    result := clMaroon
+  else if s = 'ltgreen' then
+    result := clLtGreen
+  else if s = 'olive' then
+    result := clOlive
+  else if s = 'navy' then
+    result := clNavy
+  else if s = 'purple' then
+    result := clPurple
+  else if s = 'teal' then
+    result := clTeal
+  else if s = 'silver' then
+    result := clSilver
+  else if s = 'lime' then
+    result := clLime
+  else if s = 'fuchsia' then
+    result := clFuchsia
+  else if s = 'aqua' then
+    result := clAqua
+  else
+    result := clTransparent;
+end;
+
+function TFPReaderXPM.DiminishWhiteSpace (s : string) : string;
+var r : integer;
+    Doit : boolean;
+begin
+  Doit := true;
+  result := '';
+  for r := 1 to length(s) do
+    if pos(s[r],WhiteSpace)>0 then
+      begin
+      if DoIt then
+        result := result + ' ';
+      DoIt := false;
+      end
+    else
+      begin
+      DoIt := True;
+      result := result + s[r];
+      end;
+end;
+
+procedure TFPReaderXPM.InternalRead  (Str:TStream; Img:TFPCustomImage);
+var l : TStringList;
+
+  procedure TakeInteger (var s : string; var i : integer);
+  var r : integer;
+  begin
+    r := pos (' ', s);
+    if r = 0 then
+      begin
+      i := StrToInt(s);
+      s := '';
+      end
+    else
+      begin
+      i := StrToInt(copy(s,1,r-1));
+      delete (s, 1, r);
+      end;
+  end;
+
+  procedure ParseFirstLine;
+  var s : string;
+  begin
+    s := l[0];
+    // diminish all whitespace to 1 blank
+    s := DiminishWhiteSpace (trim(s));
+    Takeinteger (s, width);
+    Takeinteger (s, height);
+    Takeinteger (s, ncols);
+    Takeinteger (s, cpp);
+    if s <> '' then
+      begin
+      Takeinteger (s, xhot);
+      Takeinteger (s, yhot);
+      xpmext := (comparetext(s, 'XPMEXT') = 0);
+      if (s <> '') and not xpmext then
+        Raise Exception.Create ('Wrong word for XPMEXT tag');
+      end;
+  end;
+
+  procedure AddPalette (code:string;Acolor:TFPColor);
+  var r : integer;
+  begin
+    r := Palette.Add(code);
+    img.palette.Color[r] := Acolor;
+  end;
+
+  procedure AddToPalette(s : string);
+  var code : string;
+      c : TFPColor;
+       p : integer;
+  begin
+    code := copy(s,1,cpp);
+    s := trim(diminishWhiteSpace (copy(s,cpp+1,maxint)));
+    // Search for c-key in the color values
+    if s[1] = 'c' then
+      delete (s, 1, 2)
+    else
+      begin
+      p := pos (' c ',s);
+      if p = 0 then
+        s := ''
+      else
+        delete (s, 1, p+2);
+      end;
+    // c color value is first word, remove the rest of the line
+    p := pos(' ', s);
+    if p > 0 then
+      delete (s, p, maxint);
+    // check if exists
+    if s = '' then
+      raise exception.Create ('Only c-key is used for colors');
+    // convert #hexadecimal value to integer and place in palette
+    if s[1] = '#' then
+      c := HexToColor(copy(s,2,maxint))
+    else
+      c := NameToColor(s);
+    AddPalette(code,c);
+  end;
+
+  procedure ReadPalette;
+  var r : integer;
+  begin
+    Palette.Clear;
+    Img.Palette.Count := ncols;
+    for r := 1 to ncols do
+      AddToPalette (l[r]);
+  end;
+
+  procedure ReadLine (s : string; imgindex : integer);
+  var color, r, p : integer;
+      code : string;
+  begin
+    p := 1;
+    for r := 1 to width do
+      begin
+      code := copy(s, p, cpp);
+      inc(p,cpp);
+      color := Palette.indexof (code);
+      img.pixels[r-1,imgindex] := color;
+      end;
+  end;
+
+  procedure ReadData;
+  var r : integer;
+  begin
+    for r := 1 to height do
+      ReadLine (l[ncols+r], r-1);
+  end;
+
+var p, r : integer;
+begin
+  l := TStringList.Create;
+  try
+    l.LoadFromStream (Str);
+    for r := l.count-1 downto 0 do
+      begin
+      p := pos ('"', l[r]);
+      if p > 0 then
+        l[r] := copy(l[r], p+1, lastdelimiter('"',l[r])-p-1)
+      else
+        l.delete(r);
+      end;
+    ParseFirstLine;
+    Img.SetSize (width, height);
+    ReadPalette;
+    ReadData;
+  finally
+    l.Free;
+  end;
+end;
+
+function  TFPReaderXPM.InternalCheck (Str:TStream) : boolean;
+var s : string[9];
+    l : integer;
+begin
+  try
+    l := str.Read (s[1],9);
+    s[0] := char(l);
+    if l <> 9 then
+      result := False
+    else
+      result := (s = '/* XPM */');
+  except
+    result := false;
+  end;
+end;
+
+initialization
+  ImageHandlers.RegisterImageReader ('XPM Format', 'xpm', TFPReaderXPM);
+end.

fcl/image/fpwritexpm.pp

@@ -0,0 +1,115 @@
+{$mode objfpc}{$h+}
+unit FPWriteXPM;
+
+interface
+
+uses FPImage, classes, sysutils;
+
+type
+  TFPWriterXPM = class (TFPCustomImageWriter)
+    private
+      FPalChars : string;
+    protected
+      procedure InternalWrite (Str:TStream; Img:TFPCustomImage); override;
+    public
+      constructor Create; override;
+      property PalChars : string read FPalChars write FPalChars;
+  end;
+
+
+implementation
+
+const
+  DefPalChars = '.,-*abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789@#;:=+%$()[]';
+
+constructor TFPWriterXPM.create;
+begin
+  inherited create;
+  PalChars := DefPalChars;
+end;
+
+function ColorToHex (c:TFPColor; size:integer) : string;
+var fmt : string;
+    l : integer;
+begin
+  with c do
+    write ('color=',red,',',green,',',blue,',',alpha);
+  l := size div 3;
+  fmt := inttostr(l);
+  fmt := '%'+fmt+'.'+fmt+'x';
+  fmt := fmt+fmt+fmt;
+  with c do
+    result := format(fmt,[red,green,blue]);
+end;
+
+procedure TFPWriterXPM.InternalWrite (Str:TStream; Img:TFPCustomImage);
+var p, l : TStringList;
+    c, len, r, t : integer;
+  procedure BuildPaletteStrings;
+  var r,c,e : integer;
+    procedure MakeCodes (head:string; charplace:integer);
+    var r : integer;
+    begin
+      r := 1;
+      dec (charplace);
+      while (r <= e) and (c >= 0) do
+        begin
+        if Charplace = 1 then
+          MakeCodes (head+PalChars[r],charplace)
+        else
+          p.Add (head+PalChars[r]);
+        inc (r);
+        dec(c);
+        end;
+    end;
+  begin
+    // Calculate length of codes
+    len := 1;
+    e := length(PalChars);
+    r := e;
+    c := img.palette.count;
+    while (r <= c) do
+      begin
+      inc (len);
+      r := r * e;
+      end;
+    MakeCodes ('',len);
+  end;
+var s : string;
+begin
+  l := TStringList.Create;
+  p := TStringList.Create;
+  try
+    l.Add ('/* XPM */');
+    l.Add ('static char *graphic[] = {');
+    c := img.palette.count;
+    BuildPaletteStrings;
+    l.add (format('"%d %d %d %d",',[img.width,img.height,c,len]));
+    for r := 0 to c-1 do
+      begin
+      if img.palette[r] <> clTransparent then
+        l.Add (format('"%s c #%s",',[p[r],ColorToHex(img.palette.color[r],12)]))
+      else
+        l.Add (format('"%s c None",',[p[r]]));
+      end;
+    for r := 0 to img.Height-1 do
+      begin
+      s := p[img.pixels[0,r]];
+      for t := 1 to img.Width-1 do
+        s := s + p[img.pixels[t,r]];
+      s := '"'+s+'"';
+      if r < img.Height-1 then
+        s := s + ',';
+      l.Add (s);
+      end;
+    l.Add ('};');
+  finally
+    l.SaveToStream (Str);
+    p.Free;
+    l.Free;
+  end;
+end;
+
+initialization
+  ImageHandlers.RegisterImageWriter ('XPM Format', 'xpm', TFPWriterXPM);
+end.

fcl/image/imgconv.pp

@@ -0,0 +1,59 @@
+{$mode objfpc}{$h+}
+program ImgConv;
+
+uses FPImage, FPWriteXPM, FPWritePNG, FPReadXPM, FPReadPNG, sysutils;
+
+var img : TFPMemoryImage;
+    reader : TFPCustomImageReader;
+    Writer : TFPCustomimageWriter;
+
+procedure Init;
+var t : char;
+begin
+  T := upcase (paramstr(1)[1]);
+  if T = 'X' then
+    Reader := TFPReaderXPM.Create
+  else
+    Reader := TFPReaderPNG.Create;
+  T := upcase (paramstr(3)[1]);
+  if T = 'X' then
+    Writer := TFPWriterXPM.Create
+  else
+    Writer := TFPWriterPNG.Create;
+  img := TFPMemoryImage.Create(1,1);
+end;
+
+procedure ReadImage;
+begin
+  img.LoadFromFile (paramstr(2), Reader);
+end;
+
+procedure WriteImage;
+begin
+  img.SaveToFile (paramstr(4), Writer);
+end;
+
+procedure Clean;
+begin
+  Reader.Free;
+  Writer.Free;
+  Img.Free;
+end;
+
+begin
+  if paramcount <> 4 then
+    begin
+    writeln ('Give filename to read and to write, preceded by filetype:');
+    writeln ('X for XPM, P for PNG');
+    end
+  else
+    try
+      Init;
+      ReadImage;
+      WriteImage;
+      Clean;
+    except
+      on e : exception do
+        writeln ('Error: ',e.message);
+    end;
+end.

fcl/image/pngcomn.pp

@@ -0,0 +1,72 @@
+{$mode objfpc}{$h+}
+unit PNGcomn;
+
+interface
+
+uses FPImage, FPImgCmn;
+
+type
+
+  PNGImageException = class (FPImageException);
+
+  TChunkTypes = (
+    ctIHDR,  ctcHRM,  ctgAMA,  ctsBIT,
+    ctPLTE,  ctbKGD,  cthIST,  cttRNS,
+    ctoFFs,  ctpHYs,  ctIDAT,  cttIME,
+    ctsCAL,  cttEXt,  ctzTXt,  ctIEND,
+    ctsRGB,  ctiCCP,  ctiTXt,  ctsPLT,
+    ctUnknown
+    );
+
+  EightLong = array[0..7] of longword;
+  TChunkCode = array[0..3] of char;
+
+  TChunk = record
+    acapacity, alength, CRC : longword;
+    ReadType : TChunkCode;
+    data : PByteArray;
+    aType : TChunkTypes;
+  end;
+
+  TChunkHeader = record
+    CLength : longword;
+    CType : TChunkCode;
+  end;
+
+  THeaderChunk = record
+    Width, height : longword;
+    BitDepth, ColorType, Compression, Filter, Interlace : byte;
+  end;
+
+const
+
+  Signature    : Array[0..7] of Byte = ($89, $50, $4E, $47, $0D, $0A, $1A, $0A);
+
+  MaxChunkLength = $7FFFFFFF;
+  All1Bits : longword = $FFFFFFFF;
+
+  ChunkTypes : array[TChunkTypes] of TChunkCode = (
+    'IHDR',  'cHRM',  'gAMA',  'sBIT',
+    'PLTE',  'bKGD',  'hIST',  'tRNS',
+    'oFFs',  'pHYs',  'IDAT',  'tIME',
+    'sCAL',  'tEXt',  'zTXt',  'IEND',
+    'sRGB',  'iCCP',  'iTXt',  'sPLT',
+    'Unkn'
+    );
+
+  ChunkAncillary = $10000000;
+  ChunkPrivate   = $00100000;
+  ChunkReserved  = $00001000;
+  ChunkSafeCopy  = $00000010;
+
+
+  StartRow     : Array[0..7] of Integer = (0, 0, 0, 4, 0, 2, 0, 1);
+  StartCol     : Array[0..7] of Integer = (0, 0, 4, 0, 2, 0, 1, 0);
+  RowInc       : Array[0..7] of Integer = (1, 8, 8, 8, 4, 4, 2, 2);
+  ColInc       : Array[0..7] of Integer = (1, 8, 8, 4, 4, 2, 2, 1);
+  BlockHght    : Array[0..7] of Integer = (1, 8, 8, 4, 4, 2, 2, 1);
+  BlockWdth    : Array[0..7] of Integer = (1, 8, 4, 4, 2, 2, 1, 1);
+
+implementation
+
+end.