/packages/fcl-image/src/fpreadpcx.pas
https://github.com/slibre/freepascal · Pascal · 310 lines · 270 code · 20 blank · 20 comment · 19 complexity · 1e1670ac12ac3e11f54e1eb708eb75c7 MD5 · raw file
- { 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.