fpreadpnm.pp 9.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429
  1. {*****************************************************************************}
  2. {
  3. This file is part of the Free Pascal's "Free Components Library".
  4. Copyright (c) 2003 by Mazen NEIFER of the Free Pascal development team
  5. PNM writer implementation.
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. }
  12. {*****************************************************************************}
  13. {
  14. The PNM (Portable aNyMaps) is a generic name for :
  15. PBM : Portable BitMaps,
  16. PGM : Portable GrayMaps,
  17. PPM : Portable PixMaps.
  18. There is normally no file format associated with PNM itself.}
  19. {$mode objfpc}{$h+}
  20. unit FPReadPNM;
  21. interface
  22. uses FPImage, classes, sysutils;
  23. Const
  24. BufSize = 1024;
  25. type
  26. { TFPReaderPNM }
  27. TFPReaderPNM=class (TFPCustomImageReader)
  28. private
  29. FBitMapType : Integer;
  30. FWidth : Integer;
  31. FHeight : Integer;
  32. FBufPos : Integer;
  33. FBufLen : Integer;
  34. FBuffer : Array of char;
  35. function DropWhiteSpaces(Stream: TStream): Char;
  36. function ReadChar(Stream: TStream): Char;
  37. function ReadInteger(Stream: TStream): Integer;
  38. procedure ReadScanlineBuffer(Stream: TStream;p:Pbyte;Len:Integer);
  39. protected
  40. FMaxVal : Cardinal;
  41. FBitPP : Byte;
  42. FScanLineSize : Integer;
  43. FScanLine : PByte;
  44. procedure ReadHeader(Stream : TStream); virtual;
  45. function InternalCheck (Stream:TStream):boolean;override;
  46. procedure InternalRead(Stream:TStream;Img:TFPCustomImage);override;
  47. procedure ReadScanLine(Row : Integer; Stream:TStream);
  48. procedure WriteScanLine(Row : Integer; Img : TFPCustomImage);
  49. end;
  50. implementation
  51. const
  52. WhiteSpaces=[#9,#10,#13,#32];
  53. {Whitespace (TABs, CRs, LFs, blanks) are separators in the PNM Headers}
  54. { The magic number at the beginning of a pnm file is 'P1', 'P2', ..., 'P7'
  55. followed by a WhiteSpace character }
  56. function TFPReaderPNM.InternalCheck(Stream:TStream):boolean;
  57. var
  58. hdr: array[0..2] of char;
  59. oldPos: Int64;
  60. i,n: Integer;
  61. begin
  62. Result:=False;
  63. if Stream = nil then
  64. exit;
  65. oldPos := Stream.Position;
  66. try
  67. n := SizeOf(hdr);
  68. Result:=(Stream.Size-OldPos>=N);
  69. if not Result then exit;
  70. For I:=0 to N-1 do
  71. hdr[i]:=ReadChar(Stream);
  72. Result:=(hdr[0] = 'P')
  73. and (hdr[1] in ['1'..'7'])
  74. and (hdr[2] in WhiteSpaces);
  75. finally
  76. Stream.Position := oldPos;
  77. FBufLen:=0;
  78. end;
  79. end;
  80. function TFPReaderPNM.DropWhiteSpaces(Stream : TStream) :Char;
  81. begin
  82. with Stream do
  83. begin
  84. repeat
  85. Result:=ReadChar(Stream);
  86. {If we encounter comment then eate line}
  87. if DropWhiteSpaces='#' then
  88. repeat
  89. Result:=ReadChar(Stream);
  90. until Result=#10;
  91. until not (Result in WhiteSpaces);
  92. end;
  93. end;
  94. function TFPReaderPNM.ReadInteger(Stream : TStream) :Integer;
  95. var
  96. s:String[7];
  97. begin
  98. s:='';
  99. s[1]:=DropWhiteSpaces(Stream);
  100. repeat
  101. Inc(s[0]);
  102. s[Length(s)+1]:=ReadChar(Stream);
  103. until (s[0]=#7) or (s[Length(s)+1] in WhiteSpaces);
  104. Result:=StrToInt(s);
  105. end;
  106. procedure TFPReaderPNM.ReadScanlineBuffer(Stream: TStream;p:Pbyte;Len:Integer);
  107. // after the header read, there are still bytes in the buffer.
  108. // drain the buffer before going for direct stream reads.
  109. var BytesLeft : integer;
  110. begin
  111. BytesLeft:=FBufLen-FBufPos;
  112. if BytesLeft>0 then
  113. begin
  114. if BytesLeft>Len then
  115. BytesLeft:=Len;
  116. Move (FBuffer[FBufPos],p^,BytesLeft);
  117. Dec(Len,BytesLeft);
  118. Inc(FBufPos,BytesLeft);
  119. Inc(p,BytesLeft);
  120. if Len>0 then
  121. Stream.ReadBuffer(p^,len);
  122. end
  123. else
  124. Stream.ReadBuffer(p^,len);
  125. end;
  126. function TFPReaderPNM.ReadChar(Stream: TStream): Char;
  127. begin
  128. If (FBufPos>=FBufLen) then
  129. begin
  130. if Length(FBuffer)=0 then
  131. SetLength(FBuffer,BufSize);
  132. FBufLen:=Stream.Read(FBuffer[0],Length(FBuffer));
  133. if FBuflen=0 then
  134. Raise EReadError.Create('Failed to read from stream');
  135. FBufPos:=0;
  136. end;
  137. Result:=FBuffer[FBufPos];
  138. Inc(FBufPos);
  139. end;
  140. procedure TFPReaderPNM.ReadHeader(Stream : TStream);
  141. Var
  142. C : Char;
  143. begin
  144. C:=ReadChar(Stream);
  145. If (C<>'P') then
  146. Raise Exception.Create('Not a valid PNM image.');
  147. C:=ReadChar(Stream);
  148. FBitmapType:=Ord(C)-Ord('0');
  149. If Not (FBitmapType in [1..6]) then
  150. Raise Exception.CreateFmt('Unknown PNM subtype : %s',[C]);
  151. FWidth:=ReadInteger(Stream);
  152. FHeight:=ReadInteger(Stream);
  153. if FBitMapType in [1,4]
  154. then
  155. FMaxVal:=1
  156. else
  157. FMaxVal:=ReadInteger(Stream);
  158. If (FWidth<=0) or (FHeight<=0) or (FMaxVal<=0) then
  159. Raise Exception.Create('Invalid PNM header data');
  160. case FBitMapType of
  161. 1: FBitPP := 1; // 1bit PP (text)
  162. 2: FBitPP := 8 * SizeOf(Word); // Grayscale (text)
  163. 3: FBitPP := 8 * SizeOf(Word)*3; // RGB (text)
  164. 4: FBitPP := 1; // 1bit PP (raw)
  165. 5: If (FMaxval>255) then // Grayscale (raw);
  166. FBitPP:= 8 * 2
  167. else
  168. FBitPP:= 8;
  169. 6: if (FMaxVal>255) then // RGB (raw)
  170. FBitPP:= 8 * 6
  171. else
  172. FBitPP:= 8 * 3
  173. end;
  174. // Writeln(FWidth,'x',Fheight,' Maxval: ',FMaxVal,' BitPP: ',FBitPP);
  175. end;
  176. procedure TFPReaderPNM.InternalRead(Stream:TStream;Img:TFPCustomImage);
  177. var
  178. Row:Integer;
  179. begin
  180. ReadHeader(Stream);
  181. Img.SetSize(FWidth,FHeight);
  182. Case FBitmapType of
  183. 5,6 : FScanLineSize:=(FBitPP div 8) * FWidth;
  184. else
  185. FScanLineSize:=FBitPP*((FWidth+7) shr 3);
  186. end;
  187. GetMem(FScanLine,FScanLineSize);
  188. try
  189. for Row:=0 to img.Height-1 do
  190. begin
  191. ReadScanLine(Row,Stream);
  192. WriteScanLine(Row,Img);
  193. // Writeln(Stream.Position,' ',Stream.Size);
  194. end;
  195. finally
  196. FreeMem(FScanLine);
  197. end;
  198. end;
  199. procedure TFPReaderPNM.ReadScanLine(Row : Integer; Stream:TStream);
  200. Var
  201. P : PWord;
  202. I,j,bitsLeft : Integer;
  203. PB: PByte;
  204. begin
  205. Case FBitmapType of
  206. 1 : begin
  207. PB:=FScanLine;
  208. For I:=0 to ((FWidth+7)shr 3)-1 do
  209. begin
  210. PB^:=0;
  211. bitsLeft := FWidth-(I shl 3)-1;
  212. if bitsLeft > 7 then bitsLeft := 7;
  213. for j:=0 to bitsLeft do
  214. PB^:=PB^ or (ReadInteger(Stream) shl (7-j));
  215. Inc(PB);
  216. end;
  217. end;
  218. 2 : begin
  219. P:=PWord(FScanLine);
  220. For I:=0 to FWidth-1 do
  221. begin
  222. P^:=ReadInteger(Stream);
  223. Inc(P);
  224. end;
  225. end;
  226. 3 : begin
  227. P:=PWord(FScanLine);
  228. For I:=0 to FWidth-1 do
  229. begin
  230. P^:=ReadInteger(Stream); // Red
  231. Inc(P);
  232. P^:=ReadInteger(Stream); // Green
  233. Inc(P);
  234. P^:=ReadInteger(Stream); // Blue;
  235. Inc(P)
  236. end;
  237. end;
  238. 4,5,6 : if FBufPos>=FBufLen then // still bytes in buffer?
  239. Stream.ReadBuffer(FScanLine^,FScanLineSize)
  240. else
  241. ReadScanLineBuffer(Stream,FScanLine,FScanLineSize);
  242. end;
  243. end;
  244. procedure TFPReaderPNM.WriteScanLine(Row : Integer; Img : TFPCustomImage);
  245. Var
  246. C : TFPColor;
  247. L : Cardinal;
  248. Scale: Int64;
  249. function ScaleByte(B: Byte):Word;
  250. begin
  251. if FMaxVal = 255 then
  252. Result := (B shl 8) or B { As used for reading .BMP files }
  253. else { Mimic the above with multiplications }
  254. Result := (B*(FMaxVal+1) + B) * 65535 div Scale;
  255. end;
  256. function ScaleWord(W: Word):Word;
  257. begin
  258. if FMaxVal = 65535 then
  259. Result := BEtoN(W)
  260. else { Mimic the above with multiplications }
  261. Result := Int64(W*(FMaxVal+1) + W) * 65535 div Scale;
  262. end;
  263. Procedure ByteBnWScanLine;
  264. Var
  265. P : PByte;
  266. I,j,x,bitsLeft : Integer;
  267. begin
  268. P:=PByte(FScanLine);
  269. For I:=0 to ((FWidth+7)shr 3)-1 do
  270. begin
  271. L:=P^;
  272. x := I shl 3;
  273. bitsLeft := FWidth-x-1;
  274. if bitsLeft > 7 then bitsLeft := 7;
  275. for j:=0 to bitsLeft do
  276. begin
  277. if L and $80 <> 0 then
  278. Img.Colors[x,Row]:=colBlack
  279. else
  280. Img.Colors[x,Row]:=colWhite;
  281. L:=L shl 1;
  282. inc(x);
  283. end;
  284. Inc(P);
  285. end;
  286. end;
  287. Procedure WordGrayScanLine;
  288. Var
  289. P : PWord;
  290. I : Integer;
  291. begin
  292. P:=PWord(FScanLine);
  293. For I:=0 to FWidth-1 do
  294. begin
  295. L:=ScaleWord(P^);
  296. C.Red:=L;
  297. C.Green:=L;
  298. C.Blue:=L;
  299. Img.Colors[I,Row]:=C;
  300. Inc(P);
  301. end;
  302. end;
  303. Procedure WordRGBScanLine;
  304. Var
  305. P : PWord;
  306. I : Integer;
  307. begin
  308. P:=PWord(FScanLine);
  309. For I:=0 to FWidth-1 do
  310. begin
  311. C.Red:=ScaleWord(P^);
  312. Inc(P);
  313. C.Green:=ScaleWord(P^);
  314. Inc(P);
  315. C.Blue:=ScaleWord(P^);
  316. Img.Colors[I,Row]:=C;
  317. Inc(P);
  318. end;
  319. end;
  320. Procedure ByteGrayScanLine;
  321. Var
  322. P : PByte;
  323. I : Integer;
  324. begin
  325. P:=PByte(FScanLine);
  326. For I:=0 to FWidth-1 do
  327. begin
  328. L:=ScaleByte(P^);
  329. C.Red:=L;
  330. C.Green:=L;
  331. C.Blue:=L;
  332. Img.Colors[I,Row]:=C;
  333. Inc(P);
  334. end;
  335. end;
  336. Procedure ByteRGBScanLine;
  337. Var
  338. P : PByte;
  339. I : Integer;
  340. begin
  341. P:=PByte(FScanLine);
  342. For I:=0 to FWidth-1 do
  343. begin
  344. C.Red:=ScaleByte(P^);
  345. Inc(P);
  346. C.Green:=ScaleByte(P^);
  347. Inc(P);
  348. C.Blue:=ScaleByte(P^);
  349. Img.Colors[I,Row]:=C;
  350. Inc(P);
  351. end;
  352. end;
  353. begin
  354. C.Alpha:=AlphaOpaque;
  355. Scale := FMaxVal*(FMaxVal+1) + FMaxVal;
  356. Case FBitmapType of
  357. 1 : ByteBnWScanLine;
  358. 2 : WordGrayScanline;
  359. 3 : WordRGBScanline;
  360. 4 : ByteBnWScanLine;
  361. 5 : If FBitPP=8 then
  362. ByteGrayScanLine
  363. else
  364. WordGrayScanLine;
  365. 6 : If FBitPP=24 then
  366. ByteRGBScanLine
  367. else
  368. WordRGBScanLine;
  369. end;
  370. end;
  371. initialization
  372. ImageHandlers.RegisterImageReader ('Netpbm format', 'PNM;PGM;PBM;PPM', TFPReaderPNM);
  373. end.