* Added PCX support from Laurent Jacques

git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@9319 3ad0048d-3df7-0310-abae-a5850022a9f2

3 files changed, 506 insertions, 0 deletions

diff --git a/packages/fcl-image/src/fpreadpcx.pas b/packages/fcl-image/src/fpreadpcx.pas
new file mode 100644
index 0000000000..f6c5bc19c9
--- /dev/null
+++ b/packages/fcl-image/src/fpreadpcx.pas
@@ -0,0 +1,310 @@
+{ Copyright (C) 2007 Laurent Jacques
+
+  This library is free software; you can redistribute it and/or modify it
+  under the terms of the GNU Library General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or (at your
+  option) any later version.
+
+  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. See the GNU Library General Public License
+  for more details.
+
+  You should have received a copy of the GNU Library General Public License
+  along with this library; if not, write to the Free Software Foundation,
+  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+  Load all format compressed or not
+}
+
+unit FPReadPCX;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses FPImage, Classes, SysUtils, pcxcomn;
+
+type
+
+  { TFPReaderPCX }
+
+  TFPReaderPCX = class(TFPCustomImageReader)
+  private
+    FCompressed: boolean;
+  protected
+    Header:     TPCXHeader;
+    BytesPerPixel: byte;
+    FScanLine:  PByte;
+    FLineSize:  integer;
+    TotalWrite: longint;
+    procedure CreateGrayPalette(Img: TFPCustomImage);
+    procedure CreateBWPalette(Img: TFPCustomImage);
+    procedure CreatePalette16(Img: TFPCustomImage);
+    procedure ReadPalette(Stream: TStream; Img: TFPCustomImage);
+    procedure AnalyzeHeader(Img: TFPCustomImage);
+    function InternalCheck(Stream: TStream): boolean; override;
+    procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
+    procedure ReadScanLine(Row: integer; Stream: TStream); virtual;
+    procedure UpdateProgress(percent: longint);
+    procedure WriteScanLine(Row: integer; Img: TFPCustomImage); virtual;
+  public
+    property Compressed: boolean Read FCompressed;
+  end;
+
+implementation
+
+
+procedure TFPReaderPCX.CreatePalette16(Img: TFPCustomImage);
+var
+  I: integer;
+  c: TFPColor;
+begin
+  Img.UsePalette := True;
+  Img.Palette.Clear;
+  for I := 0 to 15 do
+  begin
+    with c, header do
+    begin
+      Red   := ColorMap[I].red shl 8;
+      Green := ColorMap[I].Green shl 8;
+      Blue  := ColorMap[I].Blue shl 8;
+      Alpha := alphaOpaque;
+    end;
+    Img.Palette.Add(c);
+  end;
+end;
+
+procedure TFPReaderPCX.CreateGrayPalette(Img: TFPCustomImage);
+var
+  I: integer;
+  c: TFPColor;
+begin
+  Img.UsePalette := True;
+  Img.Palette.Clear;
+  for I := 0 to 255 do
+  begin
+    with c do
+    begin
+      Red   := I * 255;
+      Green := I * 255;
+      Blue  := I * 255;
+      Alpha := alphaOpaque;
+    end;
+    Img.Palette.Add(c);
+  end;
+end;
+
+procedure TFPReaderPCX.CreateBWPalette(Img: TFPCustomImage);
+begin
+  Img.UsePalette := True;
+  Img.Palette.Clear;
+  Img.Palette.Add(colBlack);
+  Img.Palette.Add(colWhite);
+end;
+
+procedure TFPReaderPCX.ReadPalette(Stream: TStream; Img: TFPCustomImage);
+var
+  RGBEntry: TRGB;
+  I:      integer;
+  c:      TFPColor;
+  OldPos: integer;
+begin
+  Img.UsePalette := True;
+  Img.Palette.Clear;
+  OldPos := Stream.Position;
+  Stream.Position := Stream.Size - 768;
+  for I := 0 to 255 do
+  begin
+    Stream.Read(RGBEntry, SizeOf(RGBEntry));
+    with c do
+    begin
+      Red   := RGBEntry.Red shl 8;
+      Green := RGBEntry.Green shl 8;
+      Blue  := RGBEntry.Blue shl 8;
+      Alpha := alphaOpaque;
+    end;
+    Img.Palette.Add(C);
+  end;
+  Stream.Position := OldPos;
+end;
+
+procedure TFPReaderPCX.AnalyzeHeader(Img: TFPCustomImage);
+begin
+  with Header do
+  begin
+    if not ((FileID in [$0A, $0C]) and (ColorPlanes in [1, 3, 4]) and
+      (Version in [0, 2, 3, 5]) and (PaletteType in [1, 2])) then
+      raise Exception.Create('Unknown/Unsupported PCX image type');
+    BytesPerPixel := BitsPerPixel * ColorPlanes;
+    FCompressed   := Encoding = 1;
+    Img.Width     := XMax - XMin + 1;
+    Img.Height    := YMax - YMin + 1;
+    FLineSize     := (BytesPerLine * ColorPlanes);
+    GetMem(FScanLine, FLineSize);
+  end;
+end;
+
+procedure TFPReaderPCX.ReadScanLine(Row: integer; Stream: TStream);
+var
+  P: PByte;
+  B: byte;
+  bytes, Count: integer;
+begin
+  P     := FScanLine;
+  bytes := FLineSize;
+  Count := 0;
+  if Compressed then
+  begin
+    while bytes > 0 do
+    begin
+      if (Count = 0) then
+      begin
+        Stream.ReadBuffer(B, 1);
+        if (B < $c0) then
+          Count := 1
+        else
+        begin
+          Count := B - $c0;
+          Stream.ReadBuffer(B, 1);
+        end;
+      end;
+      Dec(Count);
+      P[0] := B;
+      Inc(P);
+      Dec(bytes);
+    end;
+  end
+  else
+    Stream.ReadBuffer(FScanLine^, FLineSize);
+end;
+
+procedure TFPReaderPCX.UpdateProgress(percent: longint);
+var
+  continue: boolean;
+  Rect:     TRect;
+begin
+  Rect.Left   := 0;
+  Rect.Top    := 0;
+  Rect.Right  := 0;
+  Rect.Bottom := 0;
+  continue    := True;
+  Progress(psRunning, 0, False, Rect, '', continue);
+end;
+
+procedure TFPReaderPCX.InternalRead(Stream: TStream; Img: TFPCustomImage);
+var
+  H, Row:   integer;
+  continue: boolean;
+  Rect:     TRect;
+begin
+  TotalWrite  := 0;
+  Rect.Left   := 0;
+  Rect.Top    := 0;
+  Rect.Right  := 0;
+  Rect.Bottom := 0;
+  continue    := True;
+  Progress(psStarting, 0, False, Rect, '', continue);
+  Stream.Read(Header, SizeOf(Header));
+  AnalyzeHeader(Img);
+  case BytesPerPixel of
+    1: CreateBWPalette(Img);
+    4: CreatePalette16(Img);
+    8: ReadPalette(stream, Img);
+    else
+      if (Header.PaletteType = 2) then
+        CreateGrayPalette(Img);
+  end;
+  H := Img.Height;
+  TotalWrite := Img.Height * Img.Width;
+  for Row := 0 to H - 1 do
+  begin
+    ReadScanLine(Row, Stream);
+    WriteScanLine(Row, Img);
+  end;
+  Progress(psEnding, 100, False, Rect, '', continue);
+  freemem(FScanLine);
+end;
+
+procedure TFPReaderPCX.WriteScanLine(Row: integer; Img: TFPCustomImage);
+var
+  Col:   integer;
+  C:     TFPColor;
+  P, P1, P2, P3: PByte;
+  Z2:    word;
+  color: byte;
+begin
+  C.Alpha := AlphaOpaque;
+  P  := FScanLine;
+  Z2 := Header.BytesPerLine;
+  begin
+    case BytesPerPixel of
+      1:
+      begin
+        for Col := 0 to Img.Width - 1 do
+        begin
+          if (P[col div 8] and (128 shr (col mod 8))) <> 0 then
+            Img.Colors[Col, Row] := Img.Palette[1]
+          else
+            Img.Colors[Col, Row] := Img.Palette[0];
+          UpdateProgress(trunc(100.0 * (Row * Col / TotalWrite)));
+        end;
+      end;
+      4:
+      begin
+        P1 := P;
+        Inc(P1, Z2);
+        P2 := P;
+        Inc(P2, Z2 * 2);
+        P3 := P;
+        Inc(P3, Z2 * 3);
+        for Col := 0 to Img.Width - 1 do
+        begin
+          color := 0;
+          if (P[col div 8] and (128 shr (col mod 8))) <> 0 then
+            Inc(color, 1);
+          if (P1[col div 8] and (128 shr (col mod 8))) <> 0 then
+            Inc(color, 1 shl 1);
+          if (P2[col div 8] and (128 shr (col mod 8))) <> 0 then
+            Inc(color, 1 shl 2);
+          if (P3[col div 8] and (128 shr (col mod 8))) <> 0 then
+            Inc(color, 1 shl 3);
+          Img.Colors[Col, Row] := Img.Palette[color];
+          UpdateProgress(trunc(100.0 * (Row * Col / TotalWrite)));
+        end;
+      end;
+      8:
+      begin
+        for Col := 0 to Img.Width - 1 do
+        begin
+          Img.Colors[Col, Row] := Img.Palette[P[Col]];
+          UpdateProgress(trunc(100.0 * (Row * Col / TotalWrite)));
+        end;
+      end;
+      24:
+      begin
+        for Col := 0 to Img.Width - 1 do
+        begin
+          with C do
+          begin
+            Red   := P[col] or (P[col] shl 8);
+            Blue  := P[col + Z2 * 2] or (P[col + Z2 * 2] shl 8);
+            Green := P[col + Z2] or (P[col + Z2] shl 8);
+            Alpha := alphaOpaque;
+          end;
+          Img[col, row] := C;
+          UpdateProgress(trunc(100.0 * (Row * Col / TotalWrite)));
+        end;
+      end;
+    end;
+  end;
+end;
+
+function TFPReaderPCX.InternalCheck(Stream: TStream): boolean;
+begin
+  Result := True;
+end;
+
+initialization
+  ImageHandlers.RegisterImageReader('PCX Format', 'pcx', TFPReaderPCX);
+end.
diff --git a/packages/fcl-image/src/fpwritepcx.pas b/packages/fcl-image/src/fpwritepcx.pas
new file mode 100644
index 0000000000..7d8d38b450
--- /dev/null
+++ b/packages/fcl-image/src/fpwritepcx.pas
@@ -0,0 +1,156 @@
+{ Copyright (C) 2007 Laurent Jacques
+
+  This library is free software; you can redistribute it and/or modify it
+  under the terms of the GNU Library General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or (at your
+  option) any later version.
+
+  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. See the GNU Library General Public License
+  for more details.
+
+  You should have received a copy of the GNU Library General Public License
+  along with this library; if not, write to the Free Software Foundation,
+  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+  Save in format 24 bits compressed or not
+}
+
+unit FPWritePCX;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses FPImage, Classes, SysUtils;
+
+type
+
+  TFPWriterPCX = class(TFPCustomImageWriter)
+  private
+    FCompressed: boolean;
+  protected
+    function SaveHeader(Stream: TStream; Img: TFPCustomImage): boolean; virtual;
+    procedure InternalWrite(Stream: TStream; Img: TFPCustomImage); override;
+    procedure writeline(Stream: TStream; buffer: PByte; bytes: integer);
+  public
+    property Compressed: boolean Read FCompressed Write FCompressed;
+  end;
+
+implementation
+
+uses pcxcomn;
+
+function TFPWriterPCX.SaveHeader(Stream: TStream; Img: TFPCustomImage): boolean;
+var
+  Header: TPCXHeader;
+begin
+  Result := False;
+  FillChar(Header, SizeOf(Header), 0);
+  with Header do
+  begin
+    FileID  := $0a;
+    Version := 5;
+    if Compressed then
+      Encoding := 1
+    else
+      Encoding := 0;
+    BitsPerPixel := 8;
+    XMin := 0;
+    YMin := 0;
+    XMax := Img.Width - 1;
+    YMax := Img.Height - 1;
+    HRes := 300;
+    VRes := 300;
+    ColorPlanes := 3;
+    BytesPerLine := Img.Width;
+    PaletteType := 1;
+  end;
+  Stream.WriteBuffer(Header, SizeOf(Header));
+  Result := True;
+end;
+
+procedure TFPWriterPCX.writeline(Stream: TStream; buffer: PByte; bytes: integer);
+var
+  Value, Count: byte;
+  tmp: byte;
+  P:   PByte;
+begin
+  P := Buffer;
+  while bytes > 0 do
+  begin
+    Value := P[0];
+    Inc(P);
+    Dec(bytes);
+    Count := 1;
+    while (bytes < 0) and (Count < 63) and (P[0] = Value) do
+    begin
+      Inc(Count);
+      Inc(P);
+      Dec(bytes);
+    end;
+    if (Value < $c0) and (Count = 1) then
+    begin
+      Stream.Write(Value, 1);
+    end
+    else
+    begin
+      tmp := $c0 + Count;
+      Stream.Write(tmp, 1);
+      Stream.Write(Value, 1);
+    end;
+  end;
+end;
+
+procedure TFPWriterPCX.InternalWrite(Stream: TStream; Img: TFPCustomImage);
+var
+  Row, Col, WriteSize: integer;
+  Aline, P: PByte;
+  C:    TFPColor;
+  Totalwrite: longint;
+  continue: boolean;
+  Rect: TRect;
+begin
+  Rect.Left   := 0;
+  Rect.Top    := 0;
+  Rect.Right  := 0;
+  Rect.Bottom := 0;
+  continue    := True;
+  TotalWrite  := 0;
+  Progress(psStarting, 0, False, Rect, '', continue);
+  SaveHeader(Stream, Img);
+  WriteSize := (Img.Width * 3);
+  GetMem(aLine, WriteSize);
+  TotalWrite := Img.Height * Img.Width;
+  try
+    for Row := 0 to Img.Height - 1 do
+    begin
+      P := ALine;
+      for Col := 0 to Img.Width - 1 do
+      begin
+        C      := Img.Colors[Col, Row];
+        P[Col + Img.Width * 2] := C.Blue shr 8;
+        P[Col + Img.Width] := C.Green shr 8;
+        P[Col] := C.Red shr 8;
+        Progress(psRunning, trunc(100.0 * (Row * Col / TotalWrite)),
+          False, Rect, '', continue);
+        if not continue then
+          exit;
+      end;
+      if Compressed then
+        writeline(Stream, aLine, WriteSize)
+      else
+        Stream.Write(aLine[0], WriteSize);
+    end;
+    Progress(psEnding, 100, False, Rect, '', continue);
+  finally
+    FreeMem(aLine);
+  end;
+end;
+
+{ end TFPWriterPCX}
+
+initialization
+  ImageHandlers.RegisterImageWriter('PCX Format', 'pcx', TFPWriterPCX);
+end.
diff --git a/packages/fcl-image/src/pcxcomn.pas b/packages/fcl-image/src/pcxcomn.pas
new file mode 100644
index 0000000000..58e5e086fb
--- /dev/null
+++ b/packages/fcl-image/src/pcxcomn.pas
@@ -0,0 +1,40 @@
+unit pcxcomn;
+
+{$mode objfpc}{$H+}
+
+interface
+
+type
+
+  TRGB = packed record
+    Red, Green, Blue: byte;
+  end;
+
+  TPCXHeader = record
+    FileID:   byte;                      // signature $0A fichiers PCX, $CD fichiers SCR
+    Version:  byte;                     // 0: version 2.5
+    // 2: 2.8 avec palette
+    // 3: 2.8 sans palette
+    // 5: version 3
+    Encoding: byte;                    // 0: non compresser
+    // 1: encodage RLE
+    BitsPerPixel: byte;                // nombre de bits par pixel de l'image: 1, 4, 8, 24
+    XMin,                              // abscisse de l'angle supérieur gauche
+    YMin,                              // ordonnée de l'angle supérieur gauche
+    XMax,                              // abscisse de l'angle inférieur droit
+    YMax,                              // ordonnée de l'angle inférieur droit
+    HRes,                              // résolution horizontale en dpi
+    VRes:     word;                        // résolution verticale en dpi
+    ColorMap: array[0..15] of TRGB;    // Palette
+    Reserved,                          // Réservé
+    ColorPlanes: byte;                 // Nombre de plans de couleur
+    BytesPerLine,                      // Nombre de bits par ligne
+    PaletteType: word;                 // Type de palette
+    //      1: couleur ou N/B
+    //      2: dégradé de gris
+    Fill:     array[0..57] of byte;        // Remplissage
+  end;
+
+implementation
+
+end.