1 { Copyright (C) 2007 Laurent Jacques
2 
3   This library is free software; you can redistribute it and/or modify it
4   under the terms of the GNU Library General Public License as published by
5   the Free Software Foundation; either version 2 of the License, or (at your
6   option) any later version.
7 
8   This program is distributed in the hope that it will be useful, but WITHOUT
9   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
10   FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
11   for more details.
12 
13   You should have received a copy of the GNU Library General Public License
14   along with this library; if not, write to the Free Software Foundation,
15   Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
16 
17   Load all format compressed or not
18 }
19 
20 unit FPReadPCX;
21 
22 {$mode objfpc}{$H+}
23 
24 interface
25 
26 uses FPImage, Classes, SysUtils, pcxcomn;
27 
28 type
29 
30   { TFPReaderPCX }
31 
32   TFPReaderPCX = class(TFPCustomImageReader)
33   private
34     FCompressed: boolean;
35   protected
36     Header:     TPCXHeader;
37     BytesPerPixel: byte;
38     FScanLine:  PByte;
39     FLineSize:  integer;
40     TotalWrite: longint;
41     procedure CreateGrayPalette(Img: TFPCustomImage);
42     procedure CreateBWPalette(Img: TFPCustomImage);
43     procedure CreatePalette16(Img: TFPCustomImage);
44     procedure ReadPalette(Stream: TStream; Img: TFPCustomImage);
45     procedure AnalyzeHeader(Img: TFPCustomImage);
InternalChecknull46     function InternalCheck(Stream: TStream): boolean; override;
47     procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
48     procedure ReadScanLine(Row: integer; Stream: TStream); virtual;
49     procedure UpdateProgress(percent: longint);
50     procedure WriteScanLine(Row: integer; Img: TFPCustomImage); virtual;
51   public
52     property Compressed: boolean Read FCompressed;
53   end;
54 
55 implementation
56 
57 
58 procedure TFPReaderPCX.CreatePalette16(Img: TFPCustomImage);
59 var
60   I: integer;
61   c: TFPColor;
62 begin
63   Img.UsePalette := True;
64   Img.Palette.Clear;
65   for I := 0 to 15 do
66   begin
67     with c, header do
68     begin
69       Red   := ColorMap[I].red shl 8;
70       Green := ColorMap[I].Green shl 8;
71       Blue  := ColorMap[I].Blue shl 8;
72       Alpha := alphaOpaque;
73     end;
74     Img.Palette.Add(c);
75   end;
76 end;
77 
78 procedure TFPReaderPCX.CreateGrayPalette(Img: TFPCustomImage);
79 var
80   I: integer;
81   c: TFPColor;
82 begin
83   Img.UsePalette := True;
84   Img.Palette.Clear;
85   for I := 0 to 255 do
86   begin
87     with c do
88     begin
89       Red   := I * 255;
90       Green := I * 255;
91       Blue  := I * 255;
92       Alpha := alphaOpaque;
93     end;
94     Img.Palette.Add(c);
95   end;
96 end;
97 
98 procedure TFPReaderPCX.CreateBWPalette(Img: TFPCustomImage);
99 begin
100   Img.UsePalette := True;
101   Img.Palette.Clear;
102   Img.Palette.Add(colBlack);
103   Img.Palette.Add(colWhite);
104 end;
105 
106 procedure TFPReaderPCX.ReadPalette(Stream: TStream; Img: TFPCustomImage);
107 var
108   RGBEntry: TRGB;
109   I:      integer;
110   c:      TFPColor;
111   OldPos: integer;
112 begin
113   Img.UsePalette := True;
114   Img.Palette.Clear;
115   OldPos := Stream.Position;
116   Stream.Position := Stream.Size - 768;
117   for I := 0 to 255 do
118   begin
119     Stream.Read(RGBEntry, SizeOf(RGBEntry));
120     with c do
121     begin
122       Red   := RGBEntry.Red shl 8;
123       Green := RGBEntry.Green shl 8;
124       Blue  := RGBEntry.Blue shl 8;
125       Alpha := alphaOpaque;
126     end;
127     Img.Palette.Add(C);
128   end;
129   Stream.Position := OldPos;
130 end;
131 
132 procedure TFPReaderPCX.AnalyzeHeader(Img: TFPCustomImage);
133 begin
134   with Header do
135   begin
136     if not ((FileID in [$0A, $0C]) and (ColorPlanes in [1, 3, 4]) and
137       (Version in [0, 2, 3, 5]) and (PaletteType in [1, 2])) then
138       raise Exception.Create('Unknown/Unsupported PCX image type');
139     BytesPerPixel := BitsPerPixel * ColorPlanes;
140     FCompressed   := Encoding = 1;
141     Img.Width     := XMax - XMin + 1;
142     Img.Height    := YMax - YMin + 1;
143     FLineSize     := (BytesPerLine * ColorPlanes);
144     GetMem(FScanLine, FLineSize);
145   end;
146 end;
147 
148 procedure TFPReaderPCX.ReadScanLine(Row: integer; Stream: TStream);
149 var
150   P: PByte;
151   B: byte;
152   bytes, Count: integer;
153 begin
154   P     := FScanLine;
155   bytes := FLineSize;
156   Count := 0;
157   if Compressed then
158   begin
159     while bytes > 0 do
160     begin
161       if (Count = 0) then
162       begin
163         Stream.ReadBuffer(B, 1);
164         if (B < $c0) then
165           Count := 1
166         else
167         begin
168           Count := B - $c0;
169           Stream.ReadBuffer(B, 1);
170         end;
171       end;
172       Dec(Count);
173       P[0] := B;
174       Inc(P);
175       Dec(bytes);
176     end;
177   end
178   else
179     Stream.ReadBuffer(FScanLine^, FLineSize);
180 end;
181 
182 procedure TFPReaderPCX.UpdateProgress(percent: longint);
183 var
184   continue: boolean;
185   Rect:     TRect;
186 begin
187   Rect.Left   := 0;
188   Rect.Top    := 0;
189   Rect.Right  := 0;
190   Rect.Bottom := 0;
191   continue    := True;
192   Progress(psRunning, 0, False, Rect, '', continue);
193 end;
194 
195 procedure TFPReaderPCX.InternalRead(Stream: TStream; Img: TFPCustomImage);
196 var
197   H, Row:   integer;
198   continue: boolean;
199   Rect:     TRect;
200 begin
201   TotalWrite  := 0;
202   Rect.Left   := 0;
203   Rect.Top    := 0;
204   Rect.Right  := 0;
205   Rect.Bottom := 0;
206   continue    := True;
207   Progress(psStarting, 0, False, Rect, '', continue);
208   Stream.Read(Header, SizeOf(Header));
209   AnalyzeHeader(Img);
210   case BytesPerPixel of
211     1: CreateBWPalette(Img);
212     4: CreatePalette16(Img);
213     8: ReadPalette(stream, Img);
214     else
215       if (Header.PaletteType = 2) then
216         CreateGrayPalette(Img);
217   end;
218   H := Img.Height;
219   TotalWrite := Img.Height * Img.Width;
220   for Row := 0 to H - 1 do
221   begin
222     ReadScanLine(Row, Stream);
223     WriteScanLine(Row, Img);
224   end;
225   Progress(psEnding, 100, False, Rect, '', continue);
226   freemem(FScanLine);
227 end;
228 
229 procedure TFPReaderPCX.WriteScanLine(Row: integer; Img: TFPCustomImage);
230 var
231   Col:   integer;
232   C:     TFPColor;
233   P, P1, P2, P3: PByte;
234   Z2:    word;
235   color: byte;
236 begin
237   C.Alpha := AlphaOpaque;
238   P  := FScanLine;
239   Z2 := Header.BytesPerLine;
240   begin
241     case BytesPerPixel of
242       1:
243       begin
244         for Col := 0 to Img.Width - 1 do
245         begin
246           if (P[col div 8] and (128 shr (col mod 8))) <> 0 then
247             Img.Colors[Col, Row] := Img.Palette[1]
248           else
249             Img.Colors[Col, Row] := Img.Palette[0];
250           UpdateProgress(trunc(100.0 * (Row * Col / TotalWrite)));
251         end;
252       end;
253       4:
254       begin
255         P1 := P;
256         Inc(P1, Z2);
257         P2 := P;
258         Inc(P2, Z2 * 2);
259         P3 := P;
260         Inc(P3, Z2 * 3);
261         for Col := 0 to Img.Width - 1 do
262         begin
263           color := 0;
264           if (P[col div 8] and (128 shr (col mod 8))) <> 0 then
265             Inc(color, 1);
266           if (P1[col div 8] and (128 shr (col mod 8))) <> 0 then
267             Inc(color, 1 shl 1);
268           if (P2[col div 8] and (128 shr (col mod 8))) <> 0 then
269             Inc(color, 1 shl 2);
270           if (P3[col div 8] and (128 shr (col mod 8))) <> 0 then
271             Inc(color, 1 shl 3);
272           Img.Colors[Col, Row] := Img.Palette[color];
273           UpdateProgress(trunc(100.0 * (Row * Col / TotalWrite)));
274         end;
275       end;
276       8:
277       begin
278         for Col := 0 to Img.Width - 1 do
279         begin
280           Img.Colors[Col, Row] := Img.Palette[P[Col]];
281           UpdateProgress(trunc(100.0 * (Row * Col / TotalWrite)));
282         end;
283       end;
284       24:
285       begin
286         for Col := 0 to Img.Width - 1 do
287         begin
288           with C do
289           begin
290             Red   := P[col] or (P[col] shl 8);
291             Blue  := P[col + Z2 * 2] or (P[col + Z2 * 2] shl 8);
292             Green := P[col + Z2] or (P[col + Z2] shl 8);
293             Alpha := alphaOpaque;
294           end;
295           Img[col, row] := C;
296           UpdateProgress(trunc(100.0 * (Row * Col / TotalWrite)));
297         end;
298       end;
299     end;
300   end;
301 end;
302 
TFPReaderPCX.InternalChecknull303 function TFPReaderPCX.InternalCheck(Stream: TStream): boolean;
304 var
305   hdr: TPcxHeader;
306   n: Integer;
307   oldPos: Int64;
308 begin
309   Result:=False;
310   if Stream = nil then
311     exit;
312   oldPos := Stream.Position;
313   try
314     n:=SizeOf(hdr);
315     Result:=(Stream.Read(hdr, n)=n)
316             and (hdr.FileID in [$0A, $0C])
317             and (hdr.ColorPlanes in [1, 3, 4])
318             and (hdr.Version in [0, 2, 3, 5])
319             and (hdr.PaletteType in [1, 2]);
320   finally
321     Stream.Position := oldPos;
322   end;
323 end;
324 
325 
326 initialization
327   ImageHandlers.RegisterImageReader('PCX Format', 'pcx', TFPReaderPCX);
328 end.
329