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