/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

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