fpreadpng.pp 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854
  1. {
  2. $Id: fpreadpng.pp,v 1.10 2003/10/19 21:09:51 luk Exp $
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 2003 by the Free Pascal development team
  5. PNG reader 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. {$mode objfpc}{$h+}
  13. unit FPReadPNG;
  14. interface
  15. uses
  16. SysUtils,Classes, FPImage, FPImgCmn, PNGComn, ZStream;
  17. Type
  18. TSetPixelProc = procedure (x,y:integer; CD : TColordata) of object;
  19. TConvertColorProc = function (CD:TColorData) : TFPColor of object;
  20. TFPReaderPNG = class (TFPCustomImageReader)
  21. private
  22. Chunk : TChunk;
  23. FHeader : THeaderChunk;
  24. ZData : TMemoryStream; // holds compressed data until all blocks are read
  25. Decompress : TDeCompressionStream; // decompresses the data
  26. FPltte : boolean; // if palette is used
  27. FCountScanlines : EightLong; //Number of scanlines to process for each pass
  28. FScanLineLength : EightLong; //Length of scanline for each pass
  29. FCurrentPass : byte;
  30. ByteWidth : byte; // number of bytes to read for pixel information
  31. BitsUsed : EightLong; // bitmasks to use to split a byte into smaller parts
  32. BitShift : byte; // shift right to do of the bits extracted with BitsUsed for 1 element
  33. CountBitsUsed : byte; // number of bit groups (1 pixel) per byte (when bytewidth = 1)
  34. //CFmt : TColorFormat; // format of the colors to convert from
  35. StartX,StartY, DeltaX,DeltaY, StartPass,EndPass : integer; // number and format of passes
  36. FSwitchLine, FCurrentLine, FPreviousLine : pByteArray;
  37. FPalette : TFPPalette;
  38. FSetPixel : TSetPixelProc;
  39. FConvertColor : TConvertColorProc;
  40. procedure ReadChunk;
  41. procedure HandleData;
  42. procedure HandleUnknown;
  43. function ColorGray1 (CD:TColorData) : TFPColor;
  44. function ColorGray2 (CD:TColorData) : TFPColor;
  45. function ColorGray4 (CD:TColorData) : TFPColor;
  46. function ColorGray8 (CD:TColorData) : TFPColor;
  47. function ColorGray16 (CD:TColorData) : TFPColor;
  48. function ColorGrayAlpha8 (CD:TColorData) : TFPColor;
  49. function ColorGrayAlpha16 (CD:TColorData) : TFPColor;
  50. function ColorColor8 (CD:TColorData) : TFPColor;
  51. function ColorColor16 (CD:TColorData) : TFPColor;
  52. function ColorColorAlpha8 (CD:TColorData) : TFPColor;
  53. function ColorColorAlpha16 (CD:TColorData) : TFPColor;
  54. protected
  55. UseTransparent, EndOfFile : boolean;
  56. TransparentDataValue : TColorData;
  57. UsingBitGroup : byte;
  58. DataIndex : longword;
  59. DataBytes : TColorData;
  60. function CurrentLine(x:longword) : byte;
  61. function PrevSample (x:longword): byte;
  62. function PreviousLine (x:longword) : byte;
  63. function PrevLinePrevSample (x:longword): byte;
  64. procedure HandleChunk; virtual;
  65. procedure HandlePalette; virtual;
  66. procedure HandleAlpha; virtual;
  67. function CalcX (relX:integer) : integer;
  68. function CalcY (relY:integer) : integer;
  69. function CalcColor: TColorData;
  70. procedure HandleScanLine (const y : integer; const ScanLine : PByteArray); virtual;
  71. procedure DoDecompress; virtual;
  72. function DoFilter(LineFilter:byte;index:longword; b:byte) : byte; virtual;
  73. procedure SetPalettePixel (x,y:integer; CD : TColordata);
  74. procedure SetPalColPixel (x,y:integer; CD : TColordata);
  75. procedure SetColorPixel (x,y:integer; CD : TColordata);
  76. procedure SetColorTrPixel (x,y:integer; CD : TColordata);
  77. function DecideSetPixel : TSetPixelProc; virtual;
  78. procedure InternalRead (Str:TStream; Img:TFPCustomImage); override;
  79. function InternalCheck (Str:TStream) : boolean; override;
  80. //property ColorFormat : TColorformat read CFmt;
  81. property ConvertColor : TConvertColorProc read FConvertColor;
  82. property CurrentPass : byte read FCurrentPass;
  83. property Pltte : boolean read FPltte;
  84. property ThePalette : TFPPalette read FPalette;
  85. property Header : THeaderChunk read FHeader;
  86. property CountScanlines : EightLong read FCountScanlines;
  87. property ScanLineLength : EightLong read FScanLineLength;
  88. public
  89. constructor create; override;
  90. destructor destroy; override;
  91. end;
  92. implementation
  93. const StartPoints : array[0..7, 0..1] of word =
  94. ((0,0),(0,0),(4,0),(0,4),(2,0),(0,2),(1,0),(0,1));
  95. Delta : array[0..7,0..1] of word =
  96. ((1,1),(8,8),(8,8),(4,8),(4,4),(2,4),(2,2),(1,2));
  97. BitsUsed1Depth : EightLong = ($80,$40,$20,$10,$08,$04,$02,$01);
  98. BitsUsed2Depth : EightLong = ($C0,$30,$0C,$03,0,0,0,0);
  99. BitsUsed4Depth : EightLong = ($F0,$0F,0,0,0,0,0,0);
  100. constructor TFPReaderPNG.create;
  101. begin
  102. inherited;
  103. chunk.acapacity := 0;
  104. chunk.data := nil;
  105. UseTransparent := False;
  106. end;
  107. destructor TFPReaderPNG.destroy;
  108. begin
  109. with chunk do
  110. if acapacity > 0 then
  111. freemem (data);
  112. inherited;
  113. end;
  114. procedure TFPReaderPNG.ReadChunk;
  115. var ChunkHeader : TChunkHeader;
  116. readCRC : longword;
  117. l : longword;
  118. begin
  119. TheStream.Read (ChunkHeader,sizeof(ChunkHeader));
  120. with chunk do
  121. begin
  122. // chunk header
  123. with ChunkHeader do
  124. begin
  125. {$IFDEF ENDIAN_LITTLE}
  126. alength := swap(CLength);
  127. {$ELSE}
  128. alength := CLength;
  129. {$ENDIF}
  130. ReadType := CType;
  131. end;
  132. aType := low(TChunkTypes);
  133. while (aType < high(TChunkTypes)) and (ChunkTypes[aType] <> ReadType) do
  134. inc (aType);
  135. if alength > MaxChunkLength then
  136. raise PNGImageException.Create ('Invalid chunklength');
  137. if alength > acapacity then
  138. begin
  139. if acapacity > 0 then
  140. freemem (data);
  141. GetMem (data, alength);
  142. acapacity := alength;
  143. end;
  144. l := TheStream.read (data^, alength);
  145. if l <> alength then
  146. raise PNGImageException.Create ('Chunk length exceeds stream length');
  147. TheStream.Read (readCRC, sizeof(ReadCRC));
  148. l := CalculateCRC (All1Bits, ReadType, sizeOf(ReadType));
  149. l := CalculateCRC (l, data^, alength);
  150. {$IFDEF ENDIAN_LITTLE}
  151. l := swap(l xor All1Bits);
  152. {$ELSE}
  153. l := l xor All1Bits;
  154. {$ENDIF}
  155. if ReadCRC <> l then
  156. raise PNGImageException.Create ('CRC check failed');
  157. end;
  158. end;
  159. procedure TFPReaderPNG.HandleData;
  160. var OldSize : longword;
  161. begin
  162. OldSize := ZData.size;
  163. ZData.Size := OldSize + Chunk.aLength;
  164. ZData.Write (chunk.Data^, chunk.aLength);
  165. end;
  166. procedure TFPReaderPNG.HandleAlpha;
  167. procedure PaletteAlpha;
  168. var r : integer;
  169. a : word;
  170. c : TFPColor;
  171. begin
  172. with chunk do
  173. begin
  174. if alength > longword(ThePalette.count) then
  175. raise PNGImageException.create ('To much alpha values for palette');
  176. for r := 0 to alength-1 do
  177. begin
  178. c := ThePalette[r];
  179. a := data^[r];
  180. c.alpha := (a shl 16) + a;
  181. ThePalette[r] := c;
  182. end;
  183. end;
  184. end;
  185. procedure TransparentGray;
  186. var a : word;
  187. begin
  188. move (chunk.data^[0], a, 2);
  189. {$IFDEF ENDIAN_LITTLE}
  190. a := swap (a);
  191. {$ENDIF}
  192. TransparentDataValue := a;
  193. UseTransparent := True;
  194. end;
  195. procedure TransparentColor;
  196. var d : byte;
  197. r,g,b : word;
  198. a : TColorData;
  199. begin
  200. with chunk do
  201. begin
  202. move (data^[0], r, 2);
  203. move (data^[2], g, 2);
  204. move (data^[4], b, 2);
  205. end;
  206. {$IFDEF ENDIAN_LITTLE}
  207. r := swap (r);
  208. g := swap (g);
  209. b := swap (b);
  210. {$ENDIF}
  211. d := header.bitdepth;
  212. a := (TColorData(b) shl d) shl d;
  213. a := a + (TColorData(g) shl d) + r;
  214. TransparentDataValue := a;
  215. UseTransparent := True;
  216. end;
  217. begin
  218. case header.ColorType of
  219. 3 : PaletteAlpha;
  220. 0 : TransparentGray;
  221. 2 : TransparentColor;
  222. end;
  223. end;
  224. procedure TFPReaderPNG.HandlePalette;
  225. var r : longword;
  226. c : TFPColor;
  227. t : word;
  228. begin
  229. if header.colortype = 3 then
  230. with chunk do
  231. begin
  232. if TheImage.UsePalette then
  233. FPalette := TheImage.Palette
  234. else
  235. FPalette := TFPPalette.Create(0);
  236. c.Alpha := AlphaOpaque;
  237. if (aLength mod 3) > 0 then
  238. raise PNGImageException.Create ('Impossible length for PLTE-chunk');
  239. r := 0;
  240. ThePalette.count := 0;
  241. while r < alength do
  242. begin
  243. t := data^[r];
  244. c.red := t + (t shl 8);
  245. inc (r);
  246. t := data^[r];
  247. c.green := t + (t shl 8);
  248. inc (r);
  249. t := data^[r];
  250. c.blue := t + (t shl 8);
  251. inc (r);
  252. ThePalette.Add (c);
  253. end;
  254. end;
  255. end;
  256. procedure TFPReaderPNG.SetPalettePixel (x,y:integer; CD : TColordata);
  257. begin // both PNG and palette have palette
  258. TheImage.Pixels[x,y] := CD;
  259. end;
  260. procedure TFPReaderPNG.SetPalColPixel (x,y:integer; CD : TColordata);
  261. begin // PNG with palette, Img without
  262. TheImage.Colors[x,y] := ThePalette[CD];
  263. end;
  264. procedure TFPReaderPNG.SetColorPixel (x,y:integer; CD : TColordata);
  265. var c : TFPColor;
  266. begin // both PNG and Img work without palette, and no transparency colordata
  267. // c := ConvertColor (CD,CFmt);
  268. c := ConvertColor (CD);
  269. TheImage.Colors[x,y] := c;
  270. end;
  271. procedure TFPReaderPNG.SetColorTrPixel (x,y:integer; CD : TColordata);
  272. var c : TFPColor;
  273. begin // both PNG and Img work without palette, and there is a transparency colordata
  274. //c := ConvertColor (CD,CFmt);
  275. c := ConvertColor (CD);
  276. if TransparentDataValue = CD then
  277. c.alpha := alphaTransparent;
  278. TheImage.Colors[x,y] := c;
  279. end;
  280. function TFPReaderPNG.CurrentLine(x:longword):byte;
  281. begin
  282. result := FCurrentLine^[x];
  283. end;
  284. function TFPReaderPNG.PrevSample (x:longword): byte;
  285. begin
  286. if x < byteWidth then
  287. result := 0
  288. else
  289. result := FCurrentLine^[x - bytewidth];
  290. end;
  291. function TFPReaderPNG.PreviousLine (x:longword) : byte;
  292. begin
  293. result := FPreviousline^[x];
  294. end;
  295. function TFPReaderPNG.PrevLinePrevSample (x:longword): byte;
  296. begin
  297. if x < byteWidth then
  298. result := 0
  299. else
  300. result := FPreviousLine^[x - bytewidth];
  301. end;
  302. function TFPReaderPNG.DoFilter(LineFilter:byte;index:longword; b:byte) : byte;
  303. var diff : byte;
  304. procedure FilterSub;
  305. begin
  306. diff := PrevSample(index);
  307. end;
  308. procedure FilterUp;
  309. begin
  310. diff := PreviousLine(index);
  311. end;
  312. procedure FilterAverage;
  313. var l, p : word;
  314. begin
  315. l := PrevSample(index);
  316. p := PreviousLine(index);
  317. diff := (l + p) div 2;
  318. end;
  319. procedure FilterPaeth;
  320. var dl, dp, dlp : word; // index for previous and distances for:
  321. l, p, lp : byte; // r:predictor, Left, Previous, LeftPrevious
  322. r : integer;
  323. begin
  324. l := PrevSample(index);
  325. lp := PrevLinePrevSample(index);
  326. p := PreviousLine(index);
  327. r := l + p - lp;
  328. dl := abs (r - l);
  329. dlp := abs (r - lp);
  330. dp := abs (r - p);
  331. if (dl <= dp) and (dl <= dlp) then
  332. diff := l
  333. else if dp <= dlp then
  334. diff := p
  335. else
  336. diff := lp;
  337. end;
  338. begin
  339. case LineFilter of
  340. 0 : diff := 0;
  341. 1 : FilterSub;
  342. 2 : FilterUp;
  343. 3 : FilterAverage;
  344. 4 : FilterPaeth;
  345. end;
  346. result := (b + diff) mod $100;
  347. end;
  348. function TFPReaderPNG.DecideSetPixel : TSetPixelProc;
  349. begin
  350. if Pltte then
  351. if TheImage.UsePalette then
  352. result := @SetPalettePixel
  353. else
  354. result := @SetPalColPixel
  355. else
  356. if UseTransparent then
  357. result := @SetColorTrPixel
  358. else
  359. result := @SetColorPixel;
  360. end;
  361. function TFPReaderPNG.CalcX (relX:integer) : integer;
  362. begin
  363. result := StartX + (relX * deltaX);
  364. end;
  365. function TFPReaderPNG.CalcY (relY:integer) : integer;
  366. begin
  367. result := StartY + (relY * deltaY);
  368. end;
  369. function TFPReaderPNG.CalcColor: TColorData;
  370. var cd : longword;
  371. r : word;
  372. b : byte;
  373. begin
  374. if UsingBitGroup = 0 then
  375. begin
  376. Databytes := 0;
  377. if Header.BitDepth = 16 then
  378. begin
  379. r := 1;
  380. while (r < ByteWidth) do
  381. begin
  382. b := FCurrentLine^[Dataindex+r];
  383. FCurrentLine^[Dataindex+r] := FCurrentLine^[Dataindex+r-1];
  384. FCurrentLine^[Dataindex+r-1] := b;
  385. inc (r,2);
  386. end;
  387. end;
  388. move (FCurrentLine^[DataIndex], Databytes, bytewidth);
  389. {$IFDEF ENDIAN_BIG}
  390. Databytes:=swap(Databytes);
  391. {$ENDIF}
  392. inc (DataIndex,bytewidth);
  393. end;
  394. if bytewidth = 1 then
  395. begin
  396. cd := (Databytes and BitsUsed[UsingBitGroup]);
  397. result := cd shr ((CountBitsUsed-UsingBitGroup-1) * BitShift);
  398. inc (UsingBitgroup);
  399. if UsingBitGroup >= CountBitsUsed then
  400. UsingBitGroup := 0;
  401. end
  402. else
  403. result := Databytes;
  404. end;
  405. procedure TFPReaderPNG.HandleScanLine (const y : integer; const ScanLine : PByteArray);
  406. var x, rx : integer;
  407. c : TColorData;
  408. begin
  409. UsingBitGroup := 0;
  410. DataIndex := 0;
  411. for rx := 0 to ScanlineLength[CurrentPass]-1 do
  412. begin
  413. X := CalcX(rx);
  414. c := CalcColor;
  415. FSetPixel (x,y,c);
  416. end
  417. end;
  418. function TFPReaderPNG.ColorGray1 (CD:TColorDAta) : TFPColor;
  419. begin
  420. if CD = 0 then
  421. result := colBlack
  422. else
  423. result := colWhite;
  424. end;
  425. function TFPReaderPNG.ColorGray2 (CD:TColorDAta) : TFPColor;
  426. var c : word;
  427. begin
  428. c := CD and 3;
  429. c := c + (c shl 2);
  430. c := c + (c shl 4);
  431. c := c + (c shl 8);
  432. with result do
  433. begin
  434. red := c;
  435. green := c;
  436. blue := c;
  437. alpha := alphaOpaque;
  438. end;
  439. end;
  440. function TFPReaderPNG.ColorGray4 (CD:TColorDAta) : TFPColor;
  441. var c : word;
  442. begin
  443. c := CD and $F;
  444. c := c + (c shl 4);
  445. c := c + (c shl 8);
  446. with result do
  447. begin
  448. red := c;
  449. green := c;
  450. blue := c;
  451. alpha := alphaOpaque;
  452. end;
  453. end;
  454. function TFPReaderPNG.ColorGray8 (CD:TColorDAta) : TFPColor;
  455. var c : word;
  456. begin
  457. c := CD and $FF;
  458. c := c + (c shl 8);
  459. with result do
  460. begin
  461. red := c;
  462. green := c;
  463. blue := c;
  464. alpha := alphaOpaque;
  465. end;
  466. end;
  467. function TFPReaderPNG.ColorGray16 (CD:TColorDAta) : TFPColor;
  468. var c : word;
  469. begin
  470. c := CD and $FFFF;
  471. with result do
  472. begin
  473. red := c;
  474. green := c;
  475. blue := c;
  476. alpha := alphaOpaque;
  477. end;
  478. end;
  479. function TFPReaderPNG.ColorGrayAlpha8 (CD:TColorData) : TFPColor;
  480. var c : word;
  481. begin
  482. c := CD and $FF00;
  483. c := c + (c shr 8);
  484. with result do
  485. begin
  486. red := c;
  487. green := c;
  488. blue := c;
  489. c := CD and $FF;
  490. alpha := c + (c shl 8);
  491. end;
  492. end;
  493. function TFPReaderPNG.ColorGrayAlpha16 (CD:TColorData) : TFPColor;
  494. var c : word;
  495. begin
  496. c := (CD shr 16) and $FFFF;
  497. with result do
  498. begin
  499. red := c;
  500. green := c;
  501. blue := c;
  502. alpha := CD and $FFFF;
  503. end;
  504. end;
  505. function TFPReaderPNG.ColorColor8 (CD:TColorData) : TFPColor;
  506. var c : word;
  507. begin
  508. with result do
  509. begin
  510. c := CD and $FF;
  511. red := c + (c shl 8);
  512. CD:=CD shr 8;
  513. c := CD and $FF;
  514. green := c + (c shl 8);
  515. CD:=CD shr 8;
  516. c := CD and $FF;
  517. blue := c + (c shl 8);
  518. alpha := alphaOpaque;
  519. end;
  520. end;
  521. function TFPReaderPNG.ColorColor16 (CD:TColorData) : TFPColor;
  522. begin
  523. with result do
  524. begin
  525. red := CD and $FFFF;
  526. CD:=CD shr 16;
  527. green := CD and $FFFF;
  528. CD:=CD shr 16;
  529. blue := CD and $FFFF;
  530. alpha := alphaOpaque;
  531. end;
  532. end;
  533. function TFPReaderPNG.ColorColorAlpha8 (CD:TColorData) : TFPColor;
  534. var c : word;
  535. begin
  536. with result do
  537. begin
  538. c := CD and $FF;
  539. red := c + (c shl 8);
  540. CD:=CD shr 8;
  541. c := CD and $FF;
  542. green := c + (c shl 8);
  543. CD:=CD shr 8;
  544. c := CD and $FF;
  545. blue := c + (c shl 8);
  546. CD:=CD shr 8;
  547. c := CD and $FF;
  548. alpha := c + (c shl 8);
  549. end;
  550. end;
  551. function TFPReaderPNG.ColorColorAlpha16 (CD:TColorData) : TFPColor;
  552. begin
  553. with result do
  554. begin
  555. red := CD and $FFFF;
  556. CD:=CD shr 16;
  557. green := CD and $FFFF;
  558. CD:=CD shr 16;
  559. blue := CD and $FFFF;
  560. CD:=CD shr 16;
  561. alpha := CD and $FFFF;
  562. end;
  563. end;
  564. procedure TFPReaderPNG.DoDecompress;
  565. procedure initVars;
  566. var r,d : integer;
  567. begin
  568. with Header do
  569. begin
  570. if interlace=0 then
  571. begin
  572. StartPass := 0;
  573. EndPass := 0;
  574. CountScanlines[0] := Height;
  575. ScanLineLength[0] := Width;
  576. end
  577. else
  578. begin
  579. StartPass := 1;
  580. EndPass := 7;
  581. for r := 1 to 7 do
  582. begin
  583. d := Height div delta[r,1];
  584. if (height mod delta[r,1]) > startpoints[r,1] then
  585. inc (d);
  586. CountScanLines[r] := d;
  587. d := width div delta[r,0];
  588. if (width mod delta[r,0]) > startpoints[r,0] then
  589. inc (d);
  590. ScanLineLength[r] := d;
  591. end;
  592. end;
  593. Fpltte := (ColorType = 3);
  594. case colortype of
  595. 0 : case Bitdepth of
  596. 1 : begin
  597. FConvertColor := @ColorGray1; //CFmt := cfMono;
  598. ByteWidth := 1;
  599. end;
  600. 2 : begin
  601. FConvertColor := @ColorGray2; //CFmt := cfGray2;
  602. ByteWidth := 1;
  603. end;
  604. 4 : begin
  605. FConvertColor := @ColorGray4; //CFmt := cfGray4;
  606. ByteWidth := 1;
  607. end;
  608. 8 : begin
  609. FConvertColor := @ColorGray8; //CFmt := cfGray8;
  610. ByteWidth := 1;
  611. end;
  612. 16 : begin
  613. FConvertColor := @ColorGray16; //CFmt := cfGray16;
  614. ByteWidth := 2;
  615. end;
  616. end;
  617. 2 : if BitDepth = 8 then
  618. begin
  619. FConvertColor := @ColorColor8; //CFmt := cfBGR24
  620. ByteWidth := 3;
  621. end
  622. else
  623. begin
  624. FConvertColor := @ColorColor16; //CFmt := cfBGR48;
  625. ByteWidth := 6;
  626. end;
  627. 3 : if BitDepth = 16 then
  628. ByteWidth := 2
  629. else
  630. ByteWidth := 1;
  631. 4 : if BitDepth = 8 then
  632. begin
  633. FConvertColor := @ColorGrayAlpha8; //CFmt := cfGrayA16
  634. ByteWidth := 2;
  635. end
  636. else
  637. begin
  638. FConvertColor := @ColorGrayAlpha16; //CFmt := cfGrayA32;
  639. ByteWidth := 4;
  640. end;
  641. 6 : if BitDepth = 8 then
  642. begin
  643. FConvertColor := @ColorColorAlpha8; //CFmt := cfABGR32
  644. ByteWidth := 4;
  645. end
  646. else
  647. begin
  648. FConvertColor := @ColorColorAlpha16; //CFmt := cfABGR64;
  649. ByteWidth := 8;
  650. end;
  651. end;
  652. //ByteWidth := BytesNeeded[CFmt];
  653. case BitDepth of
  654. 1 : begin
  655. CountBitsUsed := 8;
  656. BitShift := 1;
  657. BitsUsed := BitsUsed1Depth;
  658. end;
  659. 2 : begin
  660. CountBitsUsed := 4;
  661. BitShift := 2;
  662. BitsUsed := BitsUsed2Depth;
  663. end;
  664. 4 : begin
  665. CountBitsUsed := 2;
  666. BitShift := 4;
  667. BitsUsed := BitsUsed4Depth;
  668. end;
  669. 8 : begin
  670. CountBitsUsed := 1;
  671. BitShift := 0;
  672. BitsUsed[0] := $FF;
  673. end;
  674. end;
  675. end;
  676. end;
  677. procedure Decode;
  678. var y, rp, ry, rx, l : integer;
  679. lf : byte;
  680. begin
  681. FSetPixel := DecideSetPixel;
  682. for rp := StartPass to EndPass do
  683. begin
  684. FCurrentPass := rp;
  685. StartX := StartPoints[rp,0];
  686. StartY := StartPoints[rp,1];
  687. DeltaX := Delta[rp,0];
  688. DeltaY := Delta[rp,1];
  689. if bytewidth = 1 then
  690. begin
  691. l := (ScanLineLength[rp] div CountBitsUsed);
  692. if (ScanLineLength[rp] mod CountBitsUsed) > 0 then
  693. inc (l);
  694. end
  695. else
  696. l := ScanLineLength[rp]*ByteWidth;
  697. GetMem (FPreviousLine, l);
  698. GetMem (FCurrentLine, l);
  699. fillchar (FCurrentLine^,l,0);
  700. try
  701. for ry := 0 to CountScanlines[rp]-1 do
  702. begin
  703. FSwitchLine := FCurrentLine;
  704. FCurrentLine := FPreviousLine;
  705. FPreviousLine := FSwitchLine;
  706. Y := CalcY(ry);
  707. Decompress.Read (lf, sizeof(lf));
  708. Decompress.Read (FCurrentLine^, l);
  709. if lf <> 0 then // Do nothing when there is no filter used
  710. for rx := 0 to l-1 do
  711. FCurrentLine^[rx] := DoFilter (lf, rx, FCurrentLine^[rx]);
  712. HandleScanLine (y, FCurrentLine);
  713. end;
  714. finally
  715. freemem (FPreviousLine);
  716. freemem (FCurrentLine);
  717. end;
  718. end;
  719. end;
  720. begin
  721. InitVars;
  722. DeCode;
  723. end;
  724. procedure TFPReaderPNG.HandleChunk;
  725. begin
  726. case chunk.AType of
  727. ctIHDR : raise PNGImageException.Create ('Second IHDR chunk found');
  728. ctPLTE : HandlePalette;
  729. ctIDAT : HandleData;
  730. ctIEND : EndOfFile := True;
  731. cttRNS : HandleAlpha;
  732. else HandleUnknown;
  733. end;
  734. end;
  735. procedure TFPReaderPNG.HandleUnknown;
  736. begin
  737. if (chunk.readtype[0] in ['A'..'Z']) then
  738. raise PNGImageException.Create('Critical chunk '+chunk.readtype+' not recognized');
  739. end;
  740. procedure TFPReaderPNG.InternalRead (Str:TStream; Img:TFPCustomImage);
  741. begin
  742. if Str<>TheStream then
  743. writeln('WARNING: TFPReaderPNG.InternalRead Str<>TheStream');
  744. with Header do
  745. Img.SetSize (Width, Height);
  746. ZData := TMemoryStream.Create;
  747. try
  748. EndOfFile := false;
  749. while not EndOfFile do
  750. begin
  751. ReadChunk;
  752. HandleChunk;
  753. end;
  754. ZData.position:=0;
  755. Decompress := TDecompressionStream.Create (ZData);
  756. try
  757. DoDecompress;
  758. finally
  759. Decompress.Free;
  760. end;
  761. finally
  762. ZData.Free;
  763. if not img.UsePalette and assigned(FPalette) then
  764. begin
  765. FPalette.Free;
  766. end;
  767. end;
  768. end;
  769. function TFPReaderPNG.InternalCheck (Str:TStream) : boolean;
  770. var SigCheck : array[0..7] of byte;
  771. r : integer;
  772. begin
  773. try
  774. // Check Signature
  775. Str.Read(SigCheck, SizeOf(SigCheck));
  776. for r := 0 to 7 do
  777. begin
  778. If SigCheck[r] <> Signature[r] then
  779. raise PNGImageException.Create('This is not PNG-data');
  780. end;
  781. // Check IHDR
  782. ReadChunk;
  783. move (chunk.data^, FHeader, sizeof(Header));
  784. with header do
  785. begin
  786. {$IFDEF ENDIAN_LITTLE}
  787. Width := swap(width);
  788. height := swap (height);
  789. {$ENDIF}
  790. result := (width > 0) and (height > 0) and (compression = 0)
  791. and (filter = 0) and (Interlace in [0,1]);
  792. end;
  793. except
  794. result := false;
  795. end;
  796. end;
  797. initialization
  798. ImageHandlers.RegisterImageReader ('Portable Network Graphics', 'png', TFPReaderPNG);
  799. end.