2D图形编程

开发平台：

Delphi

pngimage.pas：源码内容

Dest2 := pChar(Longint(Dest) + Col div 2);
{Copy data}
Byte(Dest2^) := Byte(Dest2^) or ((((Byte(Src^) shr CurBit) shl 2) and $F)
shl (4 - (Col*4) mod 8));
{Move to next column}
inc(Col, ColumnIncrement[Pass]);
{Will read next bits}
dec(CurBit, 2);
until CurBit < 0;
{Move to next byte in source}
inc(Src);
until Col >= ImageWidth;
end;
{Copy 韒ages with palette using 2 bytes for each pixel}
procedure TChunkIDAT.CopyInterlacedGrayscale16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col);
repeat
{Copy this row}
Dest^ := Src^; inc(Dest);
{$IFDEF Store16bits}
Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
{$ENDIF}
{Move to next column}
inc(Src, 2);
inc(Dest, ColumnIncrement[Pass] - 1);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Decodes interlaced RGB alpha with 1 byte for each sample}
procedure TChunkIDAT.CopyInterlacedRGBAlpha8(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col * 3);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row and alpha value}
Trans^ := pChar(Longint(Src) + 3)^;
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{Move to next column}
inc(Src, 4);
inc(Dest, ColumnIncrement[Pass] * 3 - 3);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Decodes interlaced RGB alpha with 2 bytes for each sample}
procedure TChunkIDAT.CopyInterlacedRGBAlpha16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col * 3);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row and alpha value}
Trans^ := pChar(Longint(Src) + 6)^;
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{$IFDEF Store16bits}
{Copy extra pixel values}
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
{$ENDIF}
{Move to next column}
inc(Src, 8);
inc(Dest, ColumnIncrement[Pass] * 3 - 3);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Decodes 8 bit grayscale image followed by an alpha sample}
procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha8(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column, pointers to the data and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this grayscale value and alpha}
Dest^ := Src^; inc(Src);
Trans^ := Src^; inc(Src);
{Move to next column}
inc(Dest, ColumnIncrement[Pass]);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Decodes 16 bit grayscale image followed by an alpha sample}
procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column, pointers to the data and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col);
Trans := pChar(Longint(Trans) + Col);
repeat
{$IFDEF Store16bits}
Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
{$ENDIF}
{Copy this grayscale value and alpha, transforming 16 bits into 8}
Dest^ := Src^; inc(Src, 2);
Trans^ := Src^; inc(Src, 2);
{Move to next column}
inc(Dest, ColumnIncrement[Pass]);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Decodes an interlaced image}
procedure TChunkIDAT.DecodeInterlacedAdam7(Stream: TStream;
var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal);
var
CurrentPass: Byte;
PixelsThisRow: Integer;
CurrentRow: Integer;
Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar;
CopyProc: procedure(const Pass: Byte; Src, Dest,
Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object;
begin
CopyProc := nil; {Initialize}
{Determine method to copy the image data}
case Header.ColorType of
{R, G, B values for each pixel}
COLOR_RGB:
case Header.BitDepth of
8: CopyProc := CopyInterlacedRGB8;
16: CopyProc := CopyInterlacedRGB16;
end {case Header.BitDepth};
{Palette}
COLOR_PALETTE, COLOR_GRAYSCALE:
case Header.BitDepth of
1, 4, 8: CopyProc := CopyInterlacedPalette148;
2 : if Header.ColorType = COLOR_PALETTE then
CopyProc := CopyInterlacedPalette2
else
CopyProc := CopyInterlacedGray2;
16 : CopyProc := CopyInterlacedGrayscale16;
end;
{RGB followed by alpha}
COLOR_RGBALPHA:
case Header.BitDepth of
8: CopyProc := CopyInterlacedRGBAlpha8;
16: CopyProc := CopyInterlacedRGBAlpha16;
end;
{Grayscale followed by alpha}
COLOR_GRAYSCALEALPHA:
case Header.BitDepth of
8: CopyProc := CopyInterlacedGrayscaleAlpha8;
16: CopyProc := CopyInterlacedGrayscaleAlpha16;
end;
end {case Header.ColorType};
{Adam7 method has 7 passes to make the final image}
FOR CurrentPass := 0 TO 6 DO
begin
{Calculates the number of pixels and bytes for this pass row}
PixelsThisRow := (ImageWidth - ColumnStart[CurrentPass] +
ColumnIncrement[CurrentPass] - 1) div ColumnIncrement[CurrentPass];
Row_Bytes := BytesForPixels(PixelsThisRow, Header.ColorType,
Header.BitDepth);
{Clear buffer for this pass}
ZeroMemory(Row_Buffer[not RowUsed], Row_Bytes);
{Get current row index}
CurrentRow := RowStart[CurrentPass];
{Get a pointer to the current row image data}
Data := Ptr(Longint(Header.ImageData) + Header.BytesPerRow *
(ImageHeight - 1 - CurrentRow));
Trans := Ptr(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow);
{$IFDEF Store16bits}
Extra := Ptr(Longint(Header.ExtraImageData) + Header.BytesPerRow *
(ImageHeight - 1 - CurrentRow));
{$ENDIF}
if Row_Bytes > 0 then {There must have bytes for this interlaced pass}
while CurrentRow < ImageHeight do
begin
{Reads this line and filter}
if IDATZlibRead(ZLIBStream, @Row_Buffer[RowUsed][0], Row_Bytes + 1,
EndPos, CRCFile) = 0 then break;
FilterRow;
{Copy image data}
CopyProc(CurrentPass, @Row_Buffer[RowUsed][1], Data, Trans
{$IFDEF Store16bits}, Extra{$ENDIF});
{Use the other RowBuffer item}
RowUsed := not RowUsed;
{Move to the next row}
inc(CurrentRow, RowIncrement[CurrentPass]);
{Move pointer to the next line}
dec(Data, RowIncrement[CurrentPass] * Header.BytesPerRow);
inc(Trans, RowIncrement[CurrentPass] * ImageWidth);
{$IFDEF Store16bits}
dec(Extra, RowIncrement[CurrentPass] * Header.BytesPerRow);
{$ENDIF}
end {while CurrentRow < ImageHeight};
end {FOR CurrentPass};
end;
{Copy 8 bits RGB image}
procedure TChunkIDAT.CopyNonInterlacedRGB8(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Copy pixel values}
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{Move to next pixel}
inc(Src, 3);
end {for I}
end;
{Copy 16 bits RGB image}
procedure TChunkIDAT.CopyNonInterlacedRGB16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
//Since windows does not supports 2 bytes for
//each R, G, B value, the method will read only 1 byte from it
{Copy pixel values}
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{$IFDEF Store16bits}
{Copy extra pixel values}
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
{$ENDIF}
{Move to next pixel}
inc(Src, 6);
end {for I}
end;
{Copy types using palettes (1, 4 or 8 bits per pixel)}
procedure TChunkIDAT.CopyNonInterlacedPalette148(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
begin
{It's simple as copying the data}
CopyMemory(Dest, Src, Row_Bytes);
end;
{Copy grayscale types using 2 bits for each pixel}
procedure TChunkIDAT.CopyNonInterlacedGray2(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
i: Integer;
begin
{2 bits is not supported, this routine will converted into 4 bits}
FOR i := 1 TO Row_Bytes do
begin
Byte(Dest^) := ((Byte(Src^) shr 2) and $F) or ((Byte(Src^)) and $F0); inc(Dest);
Byte(Dest^) := ((Byte(Src^) shl 2) and $F) or ((Byte(Src^) shl 4) and $F0); inc(Dest);
inc(Src);
end {FOR i}
end;
{Copy types using palette with 2 bits for each pixel}
procedure TChunkIDAT.CopyNonInterlacedPalette2(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
i: Integer;
begin
{2 bits is not supported, this routine will converted into 4 bits}
FOR i := 1 TO Row_Bytes do
begin
Byte(Dest^) := ((Byte(Src^) shr 4) and $3) or ((Byte(Src^) shr 2) and $30); inc(Dest);
Byte(Dest^) := (Byte(Src^) and $3) or ((Byte(Src^) shl 2) and $30); inc(Dest);
inc(Src);
end {FOR i}
end;
{Copy grayscale images with 16 bits}
procedure TChunkIDAT.CopyNonInterlacedGrayscale16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Windows does not supports 16 bits for each pixel in grayscale}
{mode, so reduce to 8}
Dest^ := Src^; inc(Dest);
{$IFDEF Store16bits}
Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
{$ENDIF}
{Move to next pixel}
inc(Src, 2);
end {for I}
end;
{Copy 8 bits per sample RGB images followed by an alpha byte}
procedure TChunkIDAT.CopyNonInterlacedRGBAlpha8(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
i: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Copy pixel values and transparency}
Trans^ := pChar(Longint(Src) + 3)^;
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{Move to next pixel}
inc(Src, 4); inc(Trans);
end {for I}
end;
{Copy 16 bits RGB image with alpha using 2 bytes for each sample}
procedure TChunkIDAT.CopyNonInterlacedRGBAlpha16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
//Copy rgb and alpha values (transforming from 16 bits to 8 bits)
{Copy pixel values}
Trans^ := pChar(Longint(Src) + 6)^;
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{$IFDEF Store16bits}
{Copy extra pixel values}
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
{$ENDIF}
{Move to next pixel}
inc(Src, 8); inc(Trans);
end {for I}
end;
{Copy 8 bits per sample grayscale followed by alpha}
procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha8(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Copy alpha value and then gray value}
Dest^ := Src^; inc(Src);
Trans^ := Src^; inc(Src);
inc(Dest); inc(Trans);
end;
end;
{Copy 16 bits per sample grayscale followed by alpha}
procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Copy alpha value and then gray value}
{$IFDEF Store16bits}
Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
{$ENDIF}
Dest^ := Src^; inc(Src, 2);
Trans^ := Src^; inc(Src, 2);
inc(Dest); inc(Trans);
end;
end;
{Decode non interlaced image}
procedure TChunkIDAT.DecodeNonInterlaced(Stream: TStream;
var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal);
var
j: Cardinal;
Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar;
CopyProc: procedure(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object;
begin
CopyProc := nil; {Initialize}
{Determines the method to copy the image data}
case Header.ColorType of
{R, G, B values}
COLOR_RGB:
case Header.BitDepth of
8: CopyProc := CopyNonInterlacedRGB8;
16: CopyProc := CopyNonInterlacedRGB16;
end;
{Types using palettes}
COLOR_PALETTE, COLOR_GRAYSCALE:
case Header.BitDepth of
1, 4, 8: CopyProc := CopyNonInterlacedPalette148;
2 : if Header.ColorType = COLOR_PALETTE then
CopyProc := CopyNonInterlacedPalette2
else
CopyProc := CopyNonInterlacedGray2;
16 : CopyProc := CopyNonInterlacedGrayscale16;
end;
{R, G, B followed by alpha}
COLOR_RGBALPHA:
case Header.BitDepth of
8 : CopyProc := CopyNonInterlacedRGBAlpha8;
16 : CopyProc := CopyNonInterlacedRGBAlpha16;
end;
{Grayscale followed by alpha}
COLOR_GRAYSCALEALPHA:
case Header.BitDepth of
8 : CopyProc := CopyNonInterlacedGrayscaleAlpha8;
16 : CopyProc := CopyNonInterlacedGrayscaleAlpha16;
end;
end;
{Get the image data pointer}
Longint(Data) := Longint(Header.ImageData) +
Header.BytesPerRow * (ImageHeight - 1);
Trans := Header.ImageAlpha;
{$IFDEF Store16bits}
Longint(Extra) := Longint(Header.ExtraImageData) +
Header.BytesPerRow * (ImageHeight - 1);
{$ENDIF}
{Reads each line}
FOR j := 0 to ImageHeight - 1 do
begin
{Read this line Row_Buffer[RowUsed][0] if the filter type for this line}
if IDATZlibRead(ZLIBStream, @Row_Buffer[RowUsed][0], Row_Bytes + 1, EndPos,
CRCFile) = 0 then break;
{Filter the current row}
FilterRow;
{Copies non interlaced row to image}
CopyProc(@Row_Buffer[RowUsed][1], Data, Trans{$IFDEF Store16bits}, Extra
{$ENDIF});
{Invert line used}
RowUsed := not RowUsed;
dec(Data, Header.BytesPerRow);
{$IFDEF Store16bits}dec(Extra, Header.BytesPerRow);{$ENDIF}
inc(Trans, ImageWidth);
end {for I};
end;
{Filter the current line}
procedure TChunkIDAT.FilterRow;
var
pp: Byte;
vv, left, above, aboveleft: Integer;
Col: Cardinal;
begin
{Test the filter}
case Row_Buffer[RowUsed]^[0] of
{No filtering for this line}
FILTER_NONE: begin end;
{AND 255 serves only to never let the result be larger than one byte}
{Sub filter}
FILTER_SUB:
FOR Col := Offset + 1 to Row_Bytes DO
Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] +
Row_Buffer[RowUsed][Col - Offset]) and 255;
{Up filter}
FILTER_UP:
FOR Col := 1 to Row_Bytes DO
Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] +
Row_Buffer[not RowUsed][Col]) and 255;
{Average filter}
FILTER_AVERAGE:
FOR Col := 1 to Row_Bytes DO
begin
{Obtains up and left pixels}
above := Row_Buffer[not RowUsed][Col];
if col - 1 < Offset then
left := 0
else
Left := Row_Buffer[RowUsed][Col - Offset];
{Calculates}
Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] +
(left + above) div 2) and 255;
end;
{Paeth filter}
FILTER_PAETH:
begin
{Initialize}
left := 0;
aboveleft := 0;
{Test each byte}
FOR Col := 1 to Row_Bytes DO
begin
{Obtains above pixel}
above := Row_Buffer[not RowUsed][Col];
{Obtains left and top-left pixels}
if (col - 1 >= offset) Then
begin
left := row_buffer[RowUsed][col - offset];
aboveleft := row_buffer[not RowUsed][col - offset];
end;
{Obtains current pixel and paeth predictor}
vv := row_buffer[RowUsed][Col];
pp := PaethPredictor(left, above, aboveleft);
{Calculates}
Row_Buffer[RowUsed][Col] := (pp + vv) and $FF;
end {for};
end;
end {case};
end;
{Reads the image data from the stream}
function TChunkIDAT.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
Size: Integer): Boolean;
var
ZLIBStream: TZStreamRec2;
CRCCheck,
CRCFile : Cardinal;
begin
{Get pointer to the header chunk}
Header := Owner.Chunks.Item[0] as TChunkIHDR;
{Build palette if necessary}
if Header.HasPalette then PreparePalette();
{Copy image width and height}
ImageWidth := Header.Width;
ImageHeight := Header.Height;
{Initialize to calculate CRC}
{$IFDEF CheckCRC}
CRCFile := update_crc($ffffffff, @ChunkName[0], 4);
{$ENDIF}
Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information}
ZLIBStream := ZLIBInitInflate(Stream); {Initializes decompression}
{Calculate ending position for the current IDAT chunk}
EndPos := Stream.Position + Size;
{Allocate memory}
GetMem(Row_Buffer[false], Row_Bytes + 1);
GetMem(Row_Buffer[true], Row_Bytes + 1);
ZeroMemory(Row_Buffer[false], Row_bytes + 1);
{Set the variable to alternate the Row_Buffer item to use}
RowUsed := TRUE;
{Call special methods for the different interlace methods}
case Owner.InterlaceMethod of
imNone: DecodeNonInterlaced(stream, ZLIBStream, Size, crcfile);
imAdam7: DecodeInterlacedAdam7(stream, ZLIBStream, size, crcfile);
end;
{Free memory}
ZLIBTerminateInflate(ZLIBStream); {Terminates decompression}
FreeMem(Row_Buffer[False], Row_Bytes + 1);
FreeMem(Row_Buffer[True], Row_Bytes + 1);
{Now checks CRC}
Stream.Read(CRCCheck, 4);
{$IFDEF CheckCRC}
CRCFile := CRCFile xor $ffffffff;
CRCCheck := ByteSwap(CRCCheck);
Result := CRCCheck = CRCFile;
{Handle CRC error}
if not Result then
begin
{In case it coult not load chunk}
Owner.RaiseError(EPngInvalidCRC, EPngInvalidCRCText);
exit;
end;
{$ELSE}Result := TRUE; {$ENDIF}
end;
const
IDATHeader: Array[0..3] of char = ('I', 'D', 'A', 'T');
BUFFER = 5;
{Saves the IDAT chunk to a stream}
function TChunkIDAT.SaveToStream(Stream: TStream): Boolean;
var
ZLIBStream : TZStreamRec2;
begin
{Get pointer to the header chunk}
Header := Owner.Chunks.Item[0] as TChunkIHDR;
{Copy image width and height}
ImageWidth := Header.Width;
ImageHeight := Header.Height;
Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information}
{Allocate memory}
GetMem(Encode_Buffer[BUFFER], Row_Bytes);
ZeroMemory(Encode_Buffer[BUFFER], Row_Bytes);
{Allocate buffers for the filters selected}
{Filter none will always be calculated to the other filters to work}
GetMem(Encode_Buffer[FILTER_NONE], Row_Bytes);
ZeroMemory(Encode_Buffer[FILTER_NONE], Row_Bytes);
if pfSub in Owner.Filters then
GetMem(Encode_Buffer[FILTER_SUB], Row_Bytes);
if pfUp in Owner.Filters then
GetMem(Encode_Buffer[FILTER_UP], Row_Bytes);
if pfAverage in Owner.Filters then
GetMem(Encode_Buffer[FILTER_AVERAGE], Row_Bytes);
if pfPaeth in Owner.Filters then
GetMem(Encode_Buffer[FILTER_PAETH], Row_Bytes);
{Initialize ZLIB}
ZLIBStream := ZLIBInitDeflate(Stream, Owner.fCompressionLevel,
Owner.MaxIdatSize);
{Write data depending on the interlace method}
case Owner.InterlaceMethod of
imNone: EncodeNonInterlaced(stream, ZLIBStream);
imAdam7: EncodeInterlacedAdam7(stream, ZLIBStream);
end;
{Terminates ZLIB}
ZLIBTerminateDeflate(ZLIBStream);
{Release allocated memory}
FreeMem(Encode_Buffer[BUFFER], Row_Bytes);
FreeMem(Encode_Buffer[FILTER_NONE], Row_Bytes);
if pfSub in Owner.Filters then
FreeMem(Encode_Buffer[FILTER_SUB], Row_Bytes);
if pfUp in Owner.Filters then
FreeMem(Encode_Buffer[FILTER_UP], Row_Bytes);
if pfAverage in Owner.Filters then
FreeMem(Encode_Buffer[FILTER_AVERAGE], Row_Bytes);
if pfPaeth in Owner.Filters then
FreeMem(Encode_Buffer[FILTER_PAETH], Row_Bytes);
{Everything went ok}
Result := True;
end;
{Writes the IDAT using the settings}
procedure WriteIDAT(Stream: TStream; Data: Pointer; const Length: Cardinal);
var
ChunkLen, CRC: Cardinal;
begin
{Writes IDAT header}
ChunkLen := ByteSwap(Length);
Stream.Write(ChunkLen, 4); {Chunk length}
Stream.Write(IDATHeader[0], 4); {Idat header}
CRC := update_crc($ffffffff, @IDATHeader[0], 4); {Crc part for header}
{Writes IDAT data and calculates CRC for data}
Stream.Write(Data^, Length);
CRC := Byteswap(update_crc(CRC, Data, Length) xor $ffffffff);
{Writes final CRC}
Stream.Write(CRC, 4);
end;
{Compress and writes IDAT chunk data}
procedure TChunkIDAT.IDATZlibWrite(var ZLIBStream: TZStreamRec2;
Buffer: Pointer; const Length: Cardinal);
begin
with ZLIBStream, ZLIBStream.ZLIB do
begin
{Set data to be compressed}
next_in := Buffer;
avail_in := Length;
{Compress all the data avaliable to compress}
while avail_in > 0 do
begin
deflate(ZLIB, Z_NO_FLUSH);
{The whole buffer was used, save data to stream and restore buffer}
if avail_out = 0 then
begin
{Writes this IDAT chunk}
WriteIDAT(fStream, Data, Owner.MaxIdatSize);
{Restore buffer}
next_out := Data;
avail_out := Owner.MaxIdatSize;
end {if avail_out = 0};
end {while avail_in};
end {with ZLIBStream, ZLIBStream.ZLIB}
end;
{Finishes compressing data to write IDAT chunk}
procedure TChunkIDAT.FinishIDATZlib(var ZLIBStream: TZStreamRec2);
begin
with ZLIBStream, ZLIBStream.ZLIB do
begin
{Set data to be compressed}
next_in := nil;
avail_in := 0;
while deflate(ZLIB,Z_FINISH) <> Z_STREAM_END do
begin
{Writes this IDAT chunk}
WriteIDAT(fStream, Data, Owner.MaxIdatSize - avail_out);
{Re-update buffer}
next_out := Data;
avail_out := Owner.MaxIdatSize;
end;
if avail_out < Owner.MaxIdatSize then
{Writes final IDAT}
WriteIDAT(fStream, Data, Owner.MaxIdatSize - avail_out);
end {with ZLIBStream, ZLIBStream.ZLIB};
end;
{Copy memory to encode RGB image with 1 byte for each color sample}
procedure TChunkIDAT.EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Copy pixel values}
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest);
{Move to next pixel}
inc(Src, 3);
end {for I}
end;
{Copy memory to encode RGB images with 16 bits for each color sample}
procedure TChunkIDAT.EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
//Now we copy from 1 byte for each sample stored to a 2 bytes (or 1 word)
//for sample
{Copy pixel values}
pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2);
pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest, 2);
pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest, 2);
{Move to next pixel}
inc(Src, 3);
end {for I}
end;
{Copy memory to encode types using palettes (1, 4 or 8 bits per pixel)}
procedure TChunkIDAT.EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar);
begin
{It's simple as copying the data}
CopyMemory(Dest, Src, Row_Bytes);
end;
{Copy memory to encode grayscale images with 2 bytes for each sample}
procedure TChunkIDAT.EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
//Now we copy from 1 byte for each sample stored to a 2 bytes (or 1 word)
//for sample
pWORD(Dest)^ := pByte(Longint(Src))^; inc(Dest, 2);
{Move to next pixel}
inc(Src);
end {for I}
end;
{Encode images using RGB followed by an alpha value using 1 byte for each}
procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar);
var
i: Integer;
begin
{Copy the data to the destination, including data from Trans pointer}
FOR i := 1 TO ImageWidth do
begin
Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest);
Dest^ := Trans^; inc(Dest);
inc(Src, 3); inc(Trans);
end {for i};
end;
{Encode images using RGB followed by an alpha value using 2 byte for each}
procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar);
var
i: Integer;
begin
{Copy the data to the destination, including data from Trans pointer}
FOR i := 1 TO ImageWidth do
begin
pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest, 2);
pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest, 2);
pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest, 2);
pWord(Dest)^ := PByte(Longint(Trans) )^; inc(Dest, 2);
inc(Src, 3); inc(Trans);
end {for i};
end;
{Encode grayscale images followed by an alpha value using 1 byte for each}
procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha8(
Src, Dest, Trans: pChar);
var
i: Integer;
begin
{Copy the data to the destination, including data from Trans pointer}
FOR i := 1 TO ImageWidth do
begin
Dest^ := Src^; inc(Dest);
Dest^ := Trans^; inc(Dest);
inc(Src); inc(Trans);
end {for i};
end;
{Encode grayscale images followed by an alpha value using 2 byte for each}
procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha16(
Src, Dest, Trans: pChar);
var
i: Integer;
begin
{Copy the data to the destination, including data from Trans pointer}
FOR i := 1 TO ImageWidth do
begin
pWord(Dest)^ := pByte(Src)^; inc(Dest, 2);
pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2);
inc(Src); inc(Trans);
end {for i};
end;
{Encode non interlaced images}
procedure TChunkIDAT.EncodeNonInterlaced(Stream: TStream;
var ZLIBStream: TZStreamRec2);
var
{Current line}
j: Cardinal;
{Pointers to image data}
Data, Trans: PChar;
{Filter used for this line}
Filter: Byte;
{Method which will copy the data into the buffer}
CopyProc: procedure(Src, Dest, Trans: pChar) of object;
begin
CopyProc := nil; {Initialize to avoid warnings}
{Defines the method to copy the data to the buffer depending on}
{the image parameters}
case Header.ColorType of
{R, G, B values}
COLOR_RGB:
case Header.BitDepth of
8: CopyProc := EncodeNonInterlacedRGB8;
16: CopyProc := EncodeNonInterlacedRGB16;
end;
{Palette and grayscale values}
COLOR_GRAYSCALE, COLOR_PALETTE:
case Header.BitDepth of
1, 4, 8: CopyProc := EncodeNonInterlacedPalette148;
16: CopyProc := EncodeNonInterlacedGrayscale16;
end;
{RGB with a following alpha value}
COLOR_RGBALPHA:
case Header.BitDepth of
8: CopyProc := EncodeNonInterlacedRGBAlpha8;
16: CopyProc := EncodeNonInterlacedRGBAlpha16;
end;
{Grayscale images followed by an alpha}
COLOR_GRAYSCALEALPHA:
case Header.BitDepth of
8: CopyProc := EncodeNonInterlacedGrayscaleAlpha8;
16: CopyProc := EncodeNonInterlacedGrayscaleAlpha16;
end;
end {case Header.ColorType};
{Get the image data pointer}
Longint(Data) := Longint(Header.ImageData) +
Header.BytesPerRow * (ImageHeight - 1);
Trans := Header.ImageAlpha;
{Writes each line}
FOR j := 0 to ImageHeight - 1 do
begin
{Copy data into buffer}
CopyProc(Data, @Encode_Buffer[BUFFER][0], Trans);
{Filter data}
Filter := FilterToEncode;
{Compress data}
IDATZlibWrite(ZLIBStream, @Filter, 1);
IDATZlibWrite(ZLIBStream, @Encode_Buffer[Filter][0], Row_Bytes);
{Adjust pointers to the actual image data}
dec(Data, Header.BytesPerRow);
inc(Trans, ImageWidth);
end;
{Compress and finishes copying the remaining data}
FinishIDATZlib(ZLIBStream);
end;
{Copy memory to encode interlaced images using RGB value with 1 byte for}
{each color sample}
procedure TChunkIDAT.EncodeInterlacedRGB8(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col * 3);
repeat
{Copy this row}
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest);
{Move to next column}
inc(Src, ColumnIncrement[Pass] * 3);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy memory to encode interlaced RGB images with 2 bytes each color sample}
procedure TChunkIDAT.EncodeInterlacedRGB16(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col * 3);
repeat
{Copy this row}
pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2);
pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest, 2);
pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest, 2);
{Move to next column}
inc(Src, ColumnIncrement[Pass] * 3);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy memory to encode interlaced images using palettes using bit depths}
{1, 4, 8 (each pixel in the image)}
procedure TChunkIDAT.EncodeInterlacedPalette148(const Pass: Byte;
Src, Dest, Trans: pChar);
const
BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF);
StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0);
var
CurBit, Col: Integer;
Src2: PChar;
begin
{Clean the line}
fillchar(Dest^, Row_Bytes, #0);
{Get first column and enter in loop}
Col := ColumnStart[Pass];
with Header.BitmapInfo.bmiHeader do
repeat
{Copy data}
CurBit := StartBit[biBitCount];
repeat
{Adjust pointer to pixel byte bounds}
Src2 := pChar(Longint(Src) + (biBitCount * Col) div 8);
{Copy data}
Byte(Dest^) := Byte(Dest^) or
(((Byte(Src2^) shr (StartBit[Header.BitDepth] - (biBitCount * Col)
mod 8))) and (BitTable[biBitCount])) shl CurBit;
{Move to next column}
inc(Col, ColumnIncrement[Pass]);
{Will read next bits}
dec(CurBit, biBitCount);
until CurBit < 0;
{Move to next byte in source}
inc(Dest);
until Col >= ImageWidth;
end;
{Copy to encode interlaced grayscale images using 16 bits for each sample}
procedure TChunkIDAT.EncodeInterlacedGrayscale16(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col);
repeat
{Copy this row}
pWord(Dest)^ := Byte(Src^); inc(Dest, 2);
{Move to next column}
inc(Src, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy to encode interlaced rgb images followed by an alpha value, all using}
{one byte for each sample}
procedure TChunkIDAT.EncodeInterlacedRGBAlpha8(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col * 3);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row}
Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest);
Dest^ := Trans^; inc(Dest);
{Move to next column}
inc(Src, ColumnIncrement[Pass] * 3);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy to encode interlaced rgb images followed by an alpha value, all using}
{two byte for each sample}
procedure TChunkIDAT.EncodeInterlacedRGBAlpha16(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col * 3);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row}
pWord(Dest)^ := pByte(Longint(Src) + 2)^; inc(Dest, 2);
pWord(Dest)^ := pByte(Longint(Src) + 1)^; inc(Dest, 2);
pWord(Dest)^ := pByte(Longint(Src) )^; inc(Dest, 2);
pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2);
{Move to next column}
inc(Src, ColumnIncrement[Pass] * 3);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy to encode grayscale interlaced images followed by an alpha value, all}
{using 1 byte for each sample}
procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha8(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row}
Dest^ := Src^; inc(Dest);
Dest^ := Trans^; inc(Dest);
{Move to next column}
inc(Src, ColumnIncrement[Pass]);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy to encode grayscale interlaced images followed by an alpha value, all}
{using 2 bytes for each sample}
procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha16(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row}
pWord(Dest)^ := pByte(Src)^; inc(Dest, 2);
pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2);
{Move to next column}
inc(Src, ColumnIncrement[Pass]);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Encode interlaced images}
procedure TChunkIDAT.EncodeInterlacedAdam7(Stream: TStream;
var ZLIBStream: TZStreamRec2);
var
CurrentPass, Filter: Byte;
PixelsThisRow: Integer;
CurrentRow : Integer;
Trans, Data: pChar;
CopyProc: procedure(const Pass: Byte;
Src, Dest, Trans: pChar) of object;
begin
CopyProc := nil; {Initialize to avoid warnings}
{Defines the method to copy the data to the buffer depending on}
{the image parameters}
case Header.ColorType of
{R, G, B values}
COLOR_RGB:
case Header.BitDepth of
8: CopyProc := EncodeInterlacedRGB8;
16: CopyProc := EncodeInterlacedRGB16;
end;
{Grayscale and palette}
COLOR_PALETTE, COLOR_GRAYSCALE:
case Header.BitDepth of
1, 4, 8: CopyProc := EncodeInterlacedPalette148;
16: CopyProc := EncodeInterlacedGrayscale16;
end;
{RGB followed by alpha}
COLOR_RGBALPHA:
case Header.BitDepth of
8: CopyProc := EncodeInterlacedRGBAlpha8;
16: CopyProc := EncodeInterlacedRGBAlpha16;
end;
COLOR_GRAYSCALEALPHA:
{Grayscale followed by alpha}
case Header.BitDepth of
8: CopyProc := EncodeInterlacedGrayscaleAlpha8;
16: CopyProc := EncodeInterlacedGrayscaleAlpha16;
end;
end {case Header.ColorType};
{Compress the image using the seven passes for ADAM 7}
FOR CurrentPass := 0 TO 6 DO
begin
{Calculates the number of pixels and bytes for this pass row}
PixelsThisRow := (ImageWidth - ColumnStart[CurrentPass] +
ColumnIncrement[CurrentPass] - 1) div ColumnIncrement[CurrentPass];
Row_Bytes := BytesForPixels(PixelsThisRow, Header.ColorType,
Header.BitDepth);
ZeroMemory(Encode_Buffer[FILTER_NONE], Row_Bytes);
{Get current row index}
CurrentRow := RowStart[CurrentPass];
{Get a pointer to the current row image data}
Data := Ptr(Longint(Header.ImageData) + Header.BytesPerRow *
(ImageHeight - 1 - CurrentRow));
Trans := Ptr(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow);
{Process all the image rows}
if Row_Bytes > 0 then
while CurrentRow < ImageHeight do
begin
{Copy data into buffer}
CopyProc(CurrentPass, Data, @Encode_Buffer[BUFFER][0], Trans);
{Filter data}
Filter := FilterToEncode;
{Compress data}
IDATZlibWrite(ZLIBStream, @Filter, 1);
IDATZlibWrite(ZLIBStream, @Encode_Buffer[Filter][0], Row_Bytes);
{Move to the next row}
inc(CurrentRow, RowIncrement[CurrentPass]);
{Move pointer to the next line}
dec(Data, RowIncrement[CurrentPass] * Header.BytesPerRow);
inc(Trans, RowIncrement[CurrentPass] * ImageWidth);
end {while CurrentRow < ImageHeight}
end {CurrentPass};
{Compress and finishes copying the remaining data}
FinishIDATZlib(ZLIBStream);
end;
{Filters the row to be encoded and returns the best filter}
function TChunkIDAT.FilterToEncode: Byte;
var
Run, LongestRun, ii, jj: Cardinal;
Last, Above, LastAbove: Byte;
begin
{Selecting more filters using the Filters property from TPngObject}
{increases the chances to the file be much smaller, but decreases}
{the performace}
{This method will creates the same line data using the different}
{filter methods and select the best}
{Sub-filter}
if pfSub in Owner.Filters then
for ii := 0 to Row_Bytes - 1 do
begin
{There is no previous pixel when it's on the first pixel, so}
{set last as zero when in the first}
if (ii >= Offset) then
last := Encode_Buffer[BUFFER]^[ii - Offset]
else
last := 0;
Encode_Buffer[FILTER_SUB]^[ii] := Encode_Buffer[BUFFER]^[ii] - last;
end;
{Up filter}
if pfUp in Owner.Filters then
for ii := 0 to Row_Bytes - 1 do
Encode_Buffer[FILTER_UP]^[ii] := Encode_Buffer[BUFFER]^[ii] -
Encode_Buffer[FILTER_NONE]^[ii];
{Average filter}
if pfAverage in Owner.Filters then
for ii := 0 to Row_Bytes - 1 do
begin
{Get the previous pixel, if the current pixel is the first, the}
{previous is considered to be 0}
if (ii >= Offset) then
last := Encode_Buffer[BUFFER]^[ii - Offset]
else
last := 0;
{Get the pixel above}
above := Encode_Buffer[FILTER_NONE]^[ii];
{Calculates formula to the average pixel}
Encode_Buffer[FILTER_AVERAGE]^[ii] := Encode_Buffer[BUFFER]^[ii] -
(above + last) div 2 ;
end;
{Paeth filter (the slower)}
if pfPaeth in Owner.Filters then
begin
{Initialize}
last := 0;
lastabove := 0;
for ii := 0 to Row_Bytes - 1 do
begin
{In case this pixel is not the first in the line obtains the}
{previous one and the one above the previous}
if (ii >= Offset) then
begin
last := Encode_Buffer[BUFFER]^[ii - Offset];
lastabove := Encode_Buffer[FILTER_NONE]^[ii - Offset];
end;
{Obtains the pixel above}
above := Encode_Buffer[FILTER_NONE]^[ii];
{Calculate paeth filter for this byte}
Encode_Buffer[FILTER_PAETH]^[ii] := Encode_Buffer[BUFFER]^[ii] -
PaethPredictor(last, above, lastabove);
end;
end;
{Now calculates the same line using no filter, which is necessary}
{in order to have data to the filters when the next line comes}
CopyMemory(@Encode_Buffer[FILTER_NONE]^[0],
@Encode_Buffer[BUFFER]^[0], Row_Bytes);
{If only filter none is selected in the filter list, we don't need}
{to proceed and further}
if (Owner.Filters = [pfNone]) or (Owner.Filters = []) then
begin
Result := FILTER_NONE;
exit;
end {if (Owner.Filters = [pfNone...};
{Check which filter is the best by checking which has the larger}
{sequence of the same byte, since they are best compressed}
LongestRun := 0; Result := FILTER_NONE;
for ii := FILTER_NONE TO FILTER_PAETH do
{Check if this filter was selected}
if TFilter(ii) in Owner.Filters then
begin
Run := 0;
{Check if it's the only filter}
if Owner.Filters = [TFilter(ii)] then
begin
Result := ii;
exit;
end;
{Check using a sequence of four bytes}
for jj := 2 to Row_Bytes - 1 do
if (Encode_Buffer[ii]^[jj] = Encode_Buffer [ii]^[jj-1]) or
(Encode_Buffer[ii]^[jj] = Encode_Buffer [ii]^[jj-2]) then
inc(Run); {Count the number of sequences}
{Check if this one is the best so far}
if (Run > LongestRun) then
begin
Result := ii;
LongestRun := Run;
end {if (Run > LongestRun)};
end {if TFilter(ii) in Owner.Filters};
end;
{TChunkPLTE implementation}
{Returns an item in the palette}
function TChunkPLTE.GetPaletteItem(Index: Byte): TRGBQuad;
begin
{Test if item is valid, if not raise error}
if Index > Count - 1 then
Owner.RaiseError(EPNGError, EPNGUnknownPalEntryText)
else
{Returns the item}
Result := Header.BitmapInfo.bmiColors[Index];
end;
{Loads the palette chunk from a stream}
function TChunkPLTE.LoadFromStream(Stream: TStream;
const ChunkName: TChunkName; Size: Integer): Boolean;
type
pPalEntry = ^PalEntry;
PalEntry = record
r, g, b: Byte;
end;
var
j : Integer; {For the FOR}
PalColor : pPalEntry;
begin
{Let ancestor load data and check CRC}
Result := inherited LoadFromStream(Stream, ChunkName, Size);
if not Result then exit;
{This chunk must be divisible by 3 in order to be valid}
if (Size mod 3 <> 0) or (Size div 3 > 256) then
begin
{Raise error}
Result := FALSE;
Owner.RaiseError(EPNGInvalidPalette, EPNGInvalidPaletteText);
exit;
end {if Size mod 3 <> 0};
{Fill array with the palette entries}
fCount := Size div 3;
PalColor := Data;
FOR j := 0 TO fCount - 1 DO
with Header.BitmapInfo.bmiColors[j] do
begin
rgbRed := Owner.GammaTable[PalColor.r];
rgbGreen := Owner.GammaTable[PalColor.g];
rgbBlue := Owner.GammaTable[PalColor.b];
rgbReserved := 0;
{Move to next palette entry}
inc(PalColor);
end;
end;
{Saves the PLTE chunk to a stream}
function TChunkPLTE.SaveToStream(Stream: TStream): Boolean;
var
J: Integer;
DataPtr: pByte;
begin
{Adjust size to hold all the palette items}
ResizeData(fCount * 3);
{Copy pointer to data}
DataPtr := fData;
{Copy palette items}
with Header do
FOR j := 0 TO fCount - 1 DO
with BitmapInfo.bmiColors[j] do
begin
DataPtr^ := Owner.InverseGamma[rgbRed]; inc(DataPtr);
DataPtr^ := Owner.InverseGamma[rgbGreen]; inc(DataPtr);
DataPtr^ := Owner.InverseGamma[rgbBlue]; inc(DataPtr);
end {with BitmapInfo};
{Let ancestor do the rest of the work}
Result := inherited SaveToStream(Stream);
end;
{Assigns from another PLTE chunk}
procedure TChunkPLTE.Assign(Source: TChunk);
begin
{Copy the number of palette items}
if Source is TChunkPLTE then
fCount := TChunkPLTE(Source).fCount
else
Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText);
end;
{TChunkgAMA implementation}
{Assigns from another chunk}
procedure TChunkgAMA.Assign(Source: TChunk);
begin
{Copy the gamma value}
if Source is TChunkgAMA then
Gamma := TChunkgAMA(Source).Gamma
else
Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText);
end;
{Gamma chunk being created}
constructor TChunkgAMA.Create(Owner: TPngObject);
begin
{Call ancestor}
inherited Create(Owner);
Gamma := 1; {Initial value}
end;
{Returns gamma value}
function TChunkgAMA.GetValue: Cardinal;
begin
{Make sure that the size is four bytes}
if DataSize <> 4 then
begin
{Adjust size and returns 1}
ResizeData(4);
Result := 1;
end
{If it's right, read the value}
else Result := Cardinal(ByteSwap(pCardinal(Data)^))
end;
function Power(Base, Exponent: Extended): Extended;
begin
if Exponent = 0.0 then
Result := 1.0 {Math rule}
else if (Base = 0) or (Exponent = 0) then Result := 0
else
Result := Exp(Exponent * Ln(Base));
end;
{Loading the chunk from a stream}
function TChunkgAMA.LoadFromStream(Stream: TStream;
const ChunkName: TChunkName; Size: Integer): Boolean;
var
i: Integer;
Value: Cardinal;
begin
{Call ancestor and test if it went ok}
Result := inherited LoadFromStream(Stream, ChunkName, Size);
if not Result then exit;
Value := Gamma;
{Build gamma table and inverse table for saving}
if Value <> 0 then
with Owner do
FOR i := 0 TO 255 DO
begin
GammaTable[I] := Round(Power((I / 255), 1 /
(Value / 100000 * 2.2)) * 255);
InverseGamma[Round(Power((I / 255), 1 /
(Value / 100000 * 2.2)) * 255)] := I;
end
end;
{Sets the gamma value}
procedure TChunkgAMA.SetValue(const Value: Cardinal);
begin
{Make sure that the size is four bytes}
if DataSize <> 4 then ResizeData(4);
{If it's right, set the value}
pCardinal(Data)^ := ByteSwap(Value);
end;
{TPngObject implementation}
{Assigns from another object}
procedure TPngObject.Assign(Source: TPersistent);
begin
{Being cleared}
if Source = nil then
ClearChunks
{Assigns contents from another TPNGObject}
else if Source is TPNGObject then
AssignPNG(Source as TPNGObject)
{Copy contents from a TBitmap}
{$IFDEF UseDelphi}else if Source is TBitmap then
with Source as TBitmap do
AssignHandle(Handle, Transparent,
ColorToRGB(TransparentColor)){$ENDIF}
{Unknown source, let ancestor deal with it}
else
inherited;
end;
{Clear all the chunks in the list}
procedure TPngObject.ClearChunks;
var
i: Integer;
begin
{Initialize gamma}
InitializeGamma();
{Free all the objects and memory (0 chunks Bug fixed by Noel Sharpe)}
for i := 0 TO Integer(Chunks.Count) - 1 do
TChunk(Chunks.Item[i]).Free;
Chunks.Count := 0;
end;
{Portable Network Graphics object being created}
constructor TPngObject.Create;
begin
{Let it be created}
inherited Create;
{Initial properties}
TempPalette := 0;
fFilters := [pfSub];
fCompressionLevel := 7;
fInterlaceMethod := imNone;
fMaxIdatSize := High(Word);
{Create chunklist object}
fChunkList := TPngList.Create(Self);
end;
{Portable Network Graphics object being destroyed}
destructor TPngObject.Destroy;
begin
{Free object list}
ClearChunks;
fChunkList.Free;
{Free the temporary palette}
if TempPalette <> 0 then DeleteObject(TempPalette);
{Call ancestor destroy}
inherited Destroy;
end;
{Returns linesize and byte offset for pixels}
procedure TPngObject.GetPixelInfo(var LineSize, Offset: Cardinal);
begin
{There must be an Header chunk to calculate size}
if HeaderPresent then
begin
{Calculate number of bytes for each line}
LineSize := BytesForPixels(Header.Width, Header.ColorType, Header.BitDepth);
{Calculates byte offset}
Case Header.ColorType of
{Grayscale}
COLOR_GRAYSCALE:
If Header.BitDepth = 16 Then
Offset := 2
Else
Offset := 1 ;
{It always smaller or equal one byte, so it occupes one byte}
COLOR_PALETTE:
offset := 1;
{It might be 3 or 6 bytes}
COLOR_RGB:
offset := 3 * Header.BitDepth Div 8;
{It might be 2 or 4 bytes}
COLOR_GRAYSCALEALPHA:
offset := 2 * Header.BitDepth Div 8;
{4 or 8 bytes}
COLOR_RGBALPHA:
offset := 4 * Header.BitDepth Div 8;
else
Offset := 0;
End ;
end
else
begin
{In case if there isn't any Header chunk}
Offset := 0;
LineSize := 0;
end;
end;
{Returns image height}
function TPngObject.GetHeight: Integer;
begin
{There must be a Header chunk to get the size, otherwise returns 0}
if HeaderPresent then
Result := TChunkIHDR(Chunks.Item[0]).Height
else Result := 0;
end;
{Returns image width}
function TPngObject.GetWidth: Integer;
begin
{There must be a Header chunk to get the size, otherwise returns 0}
if HeaderPresent then
Result := Header.Width
else Result := 0;
end;
{Returns if the image is empty}
function TPngObject.GetEmpty: Boolean;
begin
Result := (Chunks.Count = 0);
end;
{Raises an error}
procedure TPngObject.RaiseError(ExceptionClass: ExceptClass; Text: String);
begin
raise ExceptionClass.Create(Text);
end;
{Set the maximum size for IDAT chunk}
procedure TPngObject.SetMaxIdatSize(const Value: Integer);
begin
{Make sure the size is at least 65535}
if Value < High(Word) then
fMaxIdatSize := High(Word) else fMaxIdatSize := Value;
end;
{$IFNDEF UseDelphi}
{Creates a file stream reading from the filename in the parameter and load}
procedure TPngObject.LoadFromFile(const Filename: String);
var
FileStream: TFileStream;
begin
{Test if the file exists}
if not FileExists(Filename) then
begin
{In case it does not exists, raise error}
RaiseError(EPNGNotExists, EPNGNotExistsText);
exit;
end;
{Creates the file stream to read}
FileStream := TFileStream.Create(Filename, [fsmRead]);
LoadFromStream(FileStream); {Loads the data}
FileStream.Free; {Free file stream}
end;
{Saves the current png image to a file}
procedure TPngObject.SaveToFile(const Filename: String);
var
FileStream: TFileStream;
begin
{Creates the file stream to write}
FileStream := TFileStream.Create(Filename, [fsmWrite]);
SaveToStream(FileStream); {Saves the data}
FileStream.Free; {Free file stream}
end;
{$ENDIF}
{Returns pointer to the chunk TChunkIHDR which should be the first}
function TPngObject.GetHeader: TChunkIHDR;
begin
{If there is a TChunkIHDR returns it, otherwise returns nil}
if (Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR) then
Result := Chunks.Item[0] as TChunkIHDR
else
begin
{No header, throw error message}
RaiseError(EPNGHeaderNotPresent, EPNGHeaderNotPresentText);
Result := nil
end
end;
{Draws using partial transparency}
procedure TPngObject.DrawPartialTrans(DC: HDC; Rect: TRect);
{Adjust the rectangle structure}
procedure AdjustRect(var Rect: TRect);
var
t: Integer;
begin
if Rect.Right < Rect.Left then
begin
t := Rect.Right;
Rect.Right := Rect.Left;
Rect.Left := t;
end;
if Rect.Bottom < Rect.Top then
begin
t := Rect.Bottom;
Rect.Bottom := Rect.Top;
Rect.Top := t;
end
end;
type
{Access to pixels}
TPixelLine = Array[Word] of TRGBQuad;
pPixelLine = ^TPixelLine;
const
{Structure used to create the bitmap}
BitmapInfoHeader: TBitmapInfoHeader =
(biSize: sizeof(TBitmapInfoHeader);
biWidth: 100;
biHeight: 100;
biPlanes: 1;
biBitCount: 32;
biCompression: BI_RGB;
biSizeImage: 0;
biXPelsPerMeter: 0;
biYPelsPerMeter: 0;
biClrUsed: 0;
biClrImportant: 0);
var
{Buffer bitmap creation}
BitmapInfo : TBitmapInfo;
BufferDC : HDC;
BufferBits : Pointer;
OldBitmap,
BufferBitmap: HBitmap;
Header: TChunkIHDR;
{Transparency/palette chunks}
TransparencyChunk: TChunktRNS;
PaletteChunk: TChunkPLTE;
TransValue, PaletteIndex: Byte;
CurBit: Integer;
Data: PByte;
{Buffer bitmap modification}
BytesPerRowDest,
BytesPerRowSrc,
BytesPerRowAlpha: Integer;
ImageSource, ImageSourceOrg,
AlphaSource : pByteArray;
ImageData : pPixelLine;
i, j, i2, j2 : Integer;
{For bitmap stretching}
W, H : Cardinal;
Stretch : Boolean;
FactorX, FactorY: Double;
begin
{Prepares the rectangle structure to stretch draw}
if (Rect.Right = Rect.Left) or (Rect.Bottom = Rect.Top) then exit;
AdjustRect(Rect);
{Gets the width and height}
W := Rect.Right - Rect.Left;
H := Rect.Bottom - Rect.Top;
Header := Self.Header; {Fast access to header}
Stretch := (W <> Header.Width) or (H <> Header.Height);
if Stretch then FactorX := W / Header.Width else FactorX := 1;
if Stretch then FactorY := H / Header.Height else FactorY := 1;
{Prepare to create the bitmap}
Fillchar(BitmapInfo, sizeof(BitmapInfo), #0);
BitmapInfoHeader.biWidth := W;
BitmapInfoHeader.biHeight := -Integer(H);
BitmapInfo.bmiHeader := BitmapInfoHeader;
{Create the bitmap which will receive the background, the applied}
{alpha blending and then will be painted on the background}
BufferDC := CreateCompatibleDC(0);
{In case BufferDC could not be created}
if (BufferDC = 0) then RaiseError(EPNGOutMemory, EPNGOutMemoryText);
BufferBitmap := CreateDIBSection(BufferDC, BitmapInfo, DIB_RGB_COLORS,
BufferBits, 0, 0);
{In case buffer bitmap could not be created}
if (BufferBitmap = 0) or (BufferBits = Nil) then
begin
if BufferBitmap <> 0 then DeleteObject(BufferBitmap);
DeleteDC(BufferDC);
RaiseError(EPNGOutMemory, EPNGOutMemoryText);
end;
{Selects new bitmap and release old bitmap}
OldBitmap := SelectObject(BufferDC, BufferBitmap);
{Draws the background on the buffer image}
BitBlt(BufferDC, 0, 0, W, H, DC, Rect.Left, Rect.Top, SRCCOPY);
{Obtain number of bytes for each row}
BytesPerRowAlpha := Header.Width;
BytesPerRowDest := (((BitmapInfo.bmiHeader.biBitCount * W) + 31)
and not 31) div 8; {Number of bytes for each image row in destination}
BytesPerRowSrc := (((Header.BitmapInfo.bmiHeader.biBitCount * Header.Width) +
31) and not 31) div 8; {Number of bytes for each image row in source}
{Obtains image pointers}
ImageData := BufferBits;
AlphaSource := Header.ImageAlpha;
Longint(ImageSource) := Longint(Header.ImageData) +
Header.BytesPerRow * Longint(Header.Height - 1);
ImageSourceOrg := ImageSource;
case Header.BitmapInfo.bmiHeader.biBitCount of
{R, G, B images}
24:
FOR j := 1 TO H DO
begin
{Process all the pixels in this line}
FOR i := 0 TO W - 1 DO
begin
if Stretch then i2 := trunc(i / FactorX) else i2 := i;
{Optmize when we don磘 have transparency}
if (AlphaSource[i2] <> 0) then
if (AlphaSource[i2] = 255) then
ImageData[i] := pRGBQuad(@ImageSource[i2 * 3])^
else
with ImageData[i] do
begin
rgbRed := (255+ImageSource[2+i2*3] * AlphaSource[i2] + rgbRed *
(not AlphaSource[i2])) shr 8;
rgbGreen := (255+ImageSource[1+i2*3] * AlphaSource[i2] +
rgbGreen * (not AlphaSource[i2])) shr 8;
rgbBlue := (255+ImageSource[i2*3] * AlphaSource[i2] + rgbBlue *
(not AlphaSource[i2])) shr 8;
end;
end;
{Move pointers}
inc(Longint(ImageData), BytesPerRowDest);
if Stretch then j2 := trunc(j / FactorY) else j2 := j;
Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
Longint(AlphaSource) := Longint(Header.ImageAlpha) +
BytesPerRowAlpha * j2;
end;
{Palette images with 1 byte for each pixel}
1,4,8: if Header.ColorType = COLOR_GRAYSCALEALPHA then
FOR j := 1 TO H DO
begin
{Process all the pixels in this line}
FOR i := 0 TO W - 1 DO
with ImageData[i], Header.BitmapInfo do begin
if Stretch then i2 := trunc(i / FactorX) else i2 := i;
rgbRed := (255 + ImageSource[i2] * AlphaSource[i2] +
rgbRed * (255 - AlphaSource[i2])) shr 8;
rgbGreen := (255 + ImageSource[i2] * AlphaSource[i2] +
rgbGreen * (255 - AlphaSource[i2])) shr 8;
rgbBlue := (255 + ImageSource[i2] * AlphaSource[i2] +
rgbBlue * (255 - AlphaSource[i2])) shr 8;
end;
{Move pointers}
Longint(ImageData) := Longint(ImageData) + BytesPerRowDest;
if Stretch then j2 := trunc(j / FactorY) else j2 := j;
Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
Longint(AlphaSource) := Longint(Header.ImageAlpha) +
BytesPerRowAlpha * j2;
end
else {Palette images}
begin
{Obtain pointer to the transparency chunk}
TransparencyChunk := TChunktRNS(Chunks.ItemFromClass(TChunktRNS));
PaletteChunk := TChunkPLTE(Chunks.ItemFromClass(TChunkPLTE));
FOR j := 1 TO H DO
begin
{Process all the pixels in this line}
i := 0;
repeat
CurBit := 0;
if Stretch then i2 := trunc(i / FactorX) else i2 := i;
Data := @ImageSource[i2];
repeat
{Obtains the palette index}
case Header.BitDepth of
1: PaletteIndex := (Data^ shr (7-(I Mod 8))) and 1;
2,4: PaletteIndex := (Data^ shr ((1-(I Mod 2))*4)) and $0F;
else PaletteIndex := Data^;
end;
{Updates the image with the new pixel}
with ImageData[i] do
begin
TransValue := TransparencyChunk.PaletteValues[PaletteIndex];
rgbRed := (255 + PaletteChunk.Item[PaletteIndex].rgbRed *
TransValue + rgbRed * (255 - TransValue)) shr 8;
rgbGreen := (255 + PaletteChunk.Item[PaletteIndex].rgbGreen *
TransValue + rgbGreen * (255 - TransValue)) shr 8;
rgbBlue := (255 + PaletteChunk.Item[PaletteIndex].rgbBlue *
TransValue + rgbBlue * (255 - TransValue)) shr 8;
end;
{Move to next data}
inc(i); inc(CurBit, Header.BitmapInfo.bmiHeader.biBitCount);
until CurBit >= 8;
{Move to next source data}
//inc(Data);
until i >= Integer(W);
{Move pointers}
Longint(ImageData) := Longint(ImageData) + BytesPerRowDest;
if Stretch then j2 := trunc(j / FactorY) else j2 := j;
Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
end
end {Palette images}
end {case Header.BitmapInfo.bmiHeader.biBitCount};
{Draws the new bitmap on the foreground}
BitBlt(DC, Rect.Left, Rect.Top, W, H, BufferDC, 0, 0, SRCCOPY);
{Free bitmap}
SelectObject(BufferDC, OldBitmap);
DeleteObject(BufferBitmap);
DeleteDC(BufferDC);
end;
{Draws the image into a canvas}
procedure TPngObject.Draw(ACanvas: TCanvas; const Rect: TRect);
var
Header: TChunkIHDR;
begin
{Quit in case there is no header, otherwise obtain it}
if Empty then Exit;
Header := Chunks.GetItem(0) as TChunkIHDR;
{Copy the data to the canvas}
case Self.TransparencyMode of
{$IFDEF PartialTransparentDraw}
ptmPartial:
DrawPartialTrans(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, Rect);
{$ENDIF}
ptmBit: DrawTransparentBitmap(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF},
Header.ImageData, Header.BitmapInfo.bmiHeader,
pBitmapInfo(@Header.BitmapInfo), Rect,
{$IFDEF UseDelphi}ColorToRGB({$ENDIF}TransparentColor)
{$IFDEF UseDelphi}){$ENDIF}
else
begin
SetStretchBltMode(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, COLORONCOLOR);
StretchDiBits(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, Rect.Left,
Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, 0, 0,
Header.Width, Header.Height, Header.ImageData,
pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS, SRCCOPY)
end
end {case}
end;
{Characters for the header}
const
PngHeader: Array[0..7] of Char = (#137, #80, #78, #71, #13, #10, #26, #10);
{Loads the image from a stream of data}
procedure TPngObject.LoadFromStream(Stream: TStream);
var
Header : Array[0..7] of Char;
HasIDAT : Boolean;
{Chunks reading}
ChunkCount : Cardinal;
ChunkLength: Cardinal;
ChunkName : TChunkName;
begin
{Initialize before start loading chunks}
ChunkCount := 0;
ClearChunks();
{Reads the header}
Stream.Read(Header[0], 8);
{Test if the header matches}
if Header <> PngHeader then
begin
RaiseError(EPNGInvalidFileHeader, EPNGInvalidFileHeaderText);
Exit;
end;
HasIDAT := FALSE;
Chunks.Count := 10;
{Load chunks}
repeat
inc(ChunkCount); {Increment number of chunks}
if Chunks.Count < ChunkCount then {Resize the chunks list if needed}
Chunks.Count := Chunks.Count + 10;
{Reads chunk length and invert since it is in network order}
{also checks the Read method return, if it returns 0, it}
{means that no bytes was readed, probably because it reached}
{the end of the file}
if Stream.Read(ChunkLength, 4) = 0 then
begin
{In case it found the end of the file here}
Chunks.Count := ChunkCount - 1;
RaiseError(EPNGUnexpectedEnd, EPNGUnexpectedEndText);
end;
ChunkLength := ByteSwap(ChunkLength);
{Reads chunk name}
Stream.Read(Chunkname, 4);
{Here we check if the first chunk is the Header which is necessary}
{to the file in order to be a valid Portable Network Graphics image}
if (ChunkCount = 1) and (ChunkName <> 'IHDR') then
begin
Chunks.Count := ChunkCount - 1;
RaiseError(EPNGIHDRNotFirst, EPNGIHDRNotFirstText);
exit;
end;
{Has a previous IDAT}
if (HasIDAT and (ChunkName = 'IDAT')) or (ChunkName = 'cHRM') then
begin
dec(ChunkCount);
Stream.Seek(ChunkLength + 4, soFromCurrent);
Continue;
end;
{Tell it has an IDAT chunk}
if ChunkName = 'IDAT' then HasIDAT := TRUE;
{Creates object for this chunk}
Chunks.SetItem(ChunkCount - 1, CreateClassChunk(Self, ChunkName));
{Check if the chunk is critical and unknown}
{$IFDEF ErrorOnUnknownCritical}
if (TChunk(Chunks.Item[ChunkCount - 1]).ClassType = TChunk) and
((Byte(ChunkName[0]) AND $20) = 0) and (ChunkName <> '') then
begin
Chunks.Count := ChunkCount;
RaiseError(EPNGUnknownCriticalChunk, EPNGUnknownCriticalChunkText);
end;
{$ENDIF}
{Loads it}
try if not TChunk(Chunks.Item[ChunkCount - 1]).LoadFromStream(Stream,
ChunkName, ChunkLength) then break;
except
Chunks.Count := ChunkCount;
raise;
end;
{Terminates when it reaches the IEND chunk}
until (ChunkName = 'IEND');
{Resize the list to the appropriate size}
Chunks.Count := ChunkCount;
{Check if there is data}
if not HasIDAT then
RaiseError(EPNGNoImageData, EPNGNoImageDataText);
end;
{Changing height is not supported}
procedure TPngObject.SetHeight(Value: Integer);
begin
RaiseError(EPNGError, EPNGCannotChangeSizeText);
end;
{Changing width is not supported}
procedure TPngObject.SetWidth(Value: Integer);
begin
RaiseError(EPNGError, EPNGCannotChangeSizeText);
end;
{$IFDEF UseDelphi}
{Saves to clipboard format (thanks to Antoine Pottern)}
procedure TPNGObject.SaveToClipboardFormat(var AFormat: Word;
var AData: THandle; var APalette: HPalette);
begin
with TBitmap.Create do
try
Width := Self.Width;
Height := Self.Height;
Self.Draw(Canvas, Rect(0, 0, Width, Height));
SaveToClipboardFormat(AFormat, AData, APalette);
finally
Free;
end {try}
end;
{Loads data from clipboard}
procedure TPngObject.LoadFromClipboardFormat(AFormat: Word;
AData: THandle; APalette: HPalette);
begin
with TBitmap.Create do
try
LoadFromClipboardFormat(AFormat, AData, APalette);
Self.AssignHandle(Handle, False, 0);
finally
Free;
end {try}
end;
{Returns if the image is transparent}
function TPngObject.GetTransparent: Boolean;
begin
Result := (TransparencyMode <> ptmNone);
end;
{$ENDIF}
{Saving the PNG image to a stream of data}
procedure TPngObject.SaveToStream(Stream: TStream);
var
j: Integer;
begin
{Reads the header}
Stream.Write(PNGHeader[0], 8);
{Write each chunk}
FOR j := 0 TO Chunks.Count - 1 DO
Chunks.Item[j].SaveToStream(Stream)
end;
{Prepares the Header chunk}
procedure BuildHeader(Header: TChunkIHDR; Handle: HBitmap; Info: pBitmap;
HasPalette: Boolean);
var
DC: HDC;
begin
{Set width and height}
Header.Width := Info.bmWidth;
Header.Height := abs(Info.bmHeight);
{Set bit depth}
if Info.bmBitsPixel >= 16 then
Header.BitDepth := 8 else Header.BitDepth := Info.bmBitsPixel;
{Set color type}
if Info.bmBitsPixel >= 16 then
Header.ColorType := COLOR_RGB else Header.ColorType := COLOR_PALETTE;
{Set other info}
Header.CompressionMethod := 0; {deflate/inflate}
Header.InterlaceMethod := 0; {no interlace}
{Prepares bitmap headers to hold data}
Header.PrepareImageData();
{Copy image data}
DC := CreateCompatibleDC(0);
GetDIBits(DC, Handle, 0, Header.Height, Header.ImageData,
pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS);
DeleteDC(DC);
end;
{Loads the image from a resource}
procedure TPngObject.LoadFromResourceName(Instance: HInst;
const Name: String);
var
ResStream: TResourceStream;
begin
{Creates an especial stream to load from the resource}
try ResStream := TResourceStream.Create(Instance, Name, RT_RCDATA);
except RaiseError(EPNGCouldNotLoadResource, EPNGCouldNotLoadResourceText);
exit; end;
{Loads the png image from the resource}
try
LoadFromStream(ResStream);
finally
ResStream.Free;
end;
end;
{Loads the png from a resource ID}
procedure TPngObject.LoadFromResourceID(Instance: HInst; ResID: Integer);
begin
LoadFromResourceName(Instance, String(ResID));
end;
{Assigns this tpngobject to another object}
procedure TPngObject.AssignTo(Dest: TPersistent);
{$IFDEF UseDelphi}
var
DeskDC: HDC;
TRNS: TChunkTRNS;
{$ENDIF}
begin
{If the destination is also a TPNGObject make it assign}
{this one}
if Dest is TPNGObject then
TPNGObject(Dest).AssignPNG(Self)
{$IFDEF UseDelphi}
{In case the destination is a bitmap}
else if (Dest is TBitmap) and HeaderPresent then
begin
{Tests for the best pixelformat
case Header.BitmapInfo.bmiHeader.biBitCount of
1: TBitmap(Dest).PixelFormat := pf1Bit;
4: TBitmap(Dest).PixelFormat := pf4Bit;
8: TBitmap(Dest).PixelFormat := pf8Bit;
24: TBitmap(Dest).PixelFormat := pf24Bit;
32: TBitmap(Dest).PixelFormat := pf32Bit;
end {case Header.BitmapInfo.bmiHeader.biBitCount};
{Device context}
DeskDC := GetDC(0);
{Copy the data}
TBitmap(Dest).Handle := CreateDIBitmap(DeskDC,
Header.BitmapInfo.bmiHeader, CBM_INIT, Header.ImageData,
pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS);
ReleaseDC(0, DeskDC);
{Copy transparency mode}
if (TransparencyMode = ptmBit) then
begin
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
TBitmap(Dest).TransparentColor := TRNS.TransparentColor;
TBitmap(Dest).Transparent := True
end {if (TransparencyMode = ptmBit)}
end
else
{Unknown destination kind, }
inherited AssignTo(Dest);
{$ENDIF}
end;
{Assigns from a bitmap object}
procedure TPngObject.AssignHandle(Handle: HBitmap; Transparent: Boolean;
TransparentColor: ColorRef);
var
BitmapInfo: Windows.TBitmap;
HasPalette: Boolean;
{Chunks}
Header: TChunkIHDR;
PLTE: TChunkPLTE;
IDAT: TChunkIDAT;
IEND: TChunkIEND;
TRNS: TChunkTRNS;
begin
{Obtain bitmap info}
GetObject(Handle, SizeOf(BitmapInfo), @BitmapInfo);
{Only bit depths 1, 4 and 8 needs a palette}
HasPalette := (BitmapInfo.bmBitsPixel < 16);
{Clear old chunks and prepare}
ClearChunks();
{Create the chunks}
Header := TChunkIHDR.Create(Self);
if HasPalette then PLTE := TChunkPLTE.Create(Self) else PLTE := nil;
if Transparent then TRNS := TChunkTRNS.Create(Self) else TRNS := nil;
IDAT := TChunkIDAT.Create(Self);
IEND := TChunkIEND.Create(Self);
{Add chunks}
TPNGPointerList(Chunks).Add(Header);
if HasPalette then TPNGPointerList(Chunks).Add(PLTE);
if Transparent then TPNGPointerList(Chunks).Add(TRNS);
TPNGPointerList(Chunks).Add(IDAT);
TPNGPointerList(Chunks).Add(IEND);
{This method will fill the Header chunk with bitmap information}
{and copy the image data}
BuildHeader(Header, Handle, @BitmapInfo, HasPalette);
{In case there is a image data, set the PLTE chunk fCount variable}
{to the actual number of palette colors which is 2^(Bits for each pixel)}
if HasPalette then PLTE.fCount := 1 shl BitmapInfo.bmBitsPixel;
{In case it is a transparent bitmap, prepares it}
if Transparent then TRNS.TransparentColor := TransparentColor;
end;
{Assigns from another PNG}
procedure TPngObject.AssignPNG(Source: TPNGObject);
var
J: Integer;
begin
{Copy properties}
InterlaceMethod := Source.InterlaceMethod;
MaxIdatSize := Source.MaxIdatSize;
CompressionLevel := Source.CompressionLevel;
Filters := Source.Filters;
{Clear old chunks and prepare}
ClearChunks();
Chunks.Count := Source.Chunks.Count;
{Create chunks and makes a copy from the source}
FOR J := 0 TO Chunks.Count - 1 DO
with Source.Chunks do
begin
Chunks.SetItem(J, TChunkClass(TChunk(Item[J]).ClassType).Create(Self));
TChunk(Chunks.Item[J]).Assign(TChunk(Item[J]));
end {with};
end;
{Returns a alpha data scanline}
function TPngObject.GetAlphaScanline(const LineIndex: Integer): pByteArray;
begin
with Header do
if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then
Longint(Result) := Longint(ImageAlpha) + (LineIndex * Longint(Width))
else Result := nil; {In case the image does not use alpha information}
end;
{$IFDEF Store16bits}
{Returns a png data extra scanline}
function TPngObject.GetExtraScanline(const LineIndex: Integer): Pointer;
begin
with Header do
Longint(Result) := (Longint(ExtraImageData) + ((Longint(Height) - 1) *
BytesPerRow)) - (LineIndex * BytesPerRow);
end;
{$ENDIF}
{Returns a png data scanline}
function TPngObject.GetScanline(const LineIndex: Integer): Pointer;
begin
with Header do
Longint(Result) := (Longint(ImageData) + ((Longint(Height) - 1) *
BytesPerRow)) - (LineIndex * BytesPerRow);
end;
{Initialize gamma table}
procedure TPngObject.InitializeGamma;
var
i: Integer;
begin
{Build gamma table as if there was no gamma}
FOR i := 0 to 255 do
begin
GammaTable[i] := i;
InverseGamma[i] := i;
end {for i}
end;
{Returns the transparency mode used by this png}
function TPngObject.GetTransparencyMode: TPNGTransparencyMode;
var
TRNS: TChunkTRNS;
begin
with Header do
begin
Result := ptmNone; {Default result}
{Gets the TRNS chunk pointer}
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
{Test depending on the color type}
case ColorType of
{This modes are always partial}
COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA: Result := ptmPartial;
{This modes support bit transparency}
COLOR_RGB, COLOR_GRAYSCALE: if TRNS <> nil then Result := ptmBit;
{Supports booth translucid and bit}
COLOR_PALETTE:
{A TRNS chunk must be present, otherwise it won't support transparency}
if TRNS <> nil then
if TRNS.BitTransparency then
Result := ptmBit else Result := ptmPartial
end {case}
end {with Header}
end;
{Add a text chunk}
procedure TPngObject.AddtEXt(const Keyword, Text: String);
var
TextChunk: TChunkTEXT;
begin
TextChunk := Chunks.Add(TChunkText) as TChunkTEXT;
TextChunk.Keyword := Keyword;
TextChunk.Text := Text;
end;
{Add a text chunk}
procedure TPngObject.AddzTXt(const Keyword, Text: String);
var
TextChunk: TChunkzTXt;
begin
TextChunk := Chunks.Add(TChunkzTXt) as TChunkzTXt;
TextChunk.Keyword := Keyword;
TextChunk.Text := Text;
end;
{Removes the image transparency}
procedure TPngObject.RemoveTransparency;
var
TRNS: TChunkTRNS;
begin
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
if TRNS <> nil then Chunks.RemoveChunk(TRNS)
end;
{Generates alpha information}
procedure TPngObject.CreateAlpha;
var
TRNS: TChunkTRNS;
begin
{Generates depending on the color type}
with Header do
case ColorType of
{Png allocates different memory space to hold alpha information}
{for these types}
COLOR_GRAYSCALE, COLOR_RGB:
begin
{Transform into the appropriate color type}
if ColorType = COLOR_GRAYSCALE then
ColorType := COLOR_GRAYSCALEALPHA
else ColorType := COLOR_RGBALPHA;
{Allocates memory to hold alpha information}
GetMem(ImageAlpha, Integer(Width) * Integer(Height));
FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #255);
end;
{Palette uses the TChunktRNS to store alpha}
COLOR_PALETTE:
begin
{Gets/creates TRNS chunk}
if Chunks.ItemFromClass(TChunkTRNS) = nil then
TRNS := Chunks.Add(TChunkTRNS) as TChunkTRNS
else
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
{Prepares the TRNS chunk}
with TRNS do
begin
Fillchar(PaletteValues[0], 256, 255);
fDataSize := 1 shl Header.BitDepth;
fBitTransparency := False
end {with Chunks.Add};
end;
end {case Header.ColorType}
end;
{Returns transparent color}
function TPngObject.GetTransparentColor: TColor;
var
TRNS: TChunkTRNS;
begin
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
{Reads the transparency chunk to get this info}
if Assigned(TRNS) then Result := TRNS.TransparentColor
else Result := 0
end;
{$OPTIMIZATION OFF}
procedure TPngObject.SetTransparentColor(const Value: TColor);
var
TRNS: TChunkTRNS;
begin
if HeaderPresent then
{Tests the ColorType}
case Header.ColorType of
{Not allowed for this modes}
COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA: Self.RaiseError(
EPNGCannotChangeTransparent, EPNGCannotChangeTransparentText);
{Allowed}
COLOR_PALETTE, COLOR_RGB, COLOR_GRAYSCALE:
begin
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
if not Assigned(TRNS) then TRNS := Chunks.Add(TChunkTRNS) as TChunkTRNS;
{Sets the transparency value from TRNS chunk}
TRNS.TransparentColor := {$IFDEF UseDelphi}ColorToRGB({$ENDIF}Value{$IFDEF UseDelphi}){$ENDIF}
end {COLOR_PALETTE, COLOR_RGB, COLOR_GRAYSCALE)}
end {case}
end;
{Returns if header is present}
function TPngObject.HeaderPresent: Boolean;
begin
Result := ((Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR))
end;
{Returns pixel for png using palette and grayscale}
function GetByteArrayPixel(const png: TPngObject; const X, Y: Integer): TColor;
var
ByteData: Byte;
DataDepth: Byte;
begin
with png, Header do
begin
{Make sure the bitdepth is not greater than 8}
DataDepth := BitDepth;
if DataDepth > 8 then DataDepth := 8;
{Obtains the byte containing this pixel}
ByteData := pByteArray(png.Scanline[Y])^[X div (8 div DataDepth)];
{Moves the bits we need to the right}
ByteData := (ByteData shr ((8 - DataDepth) -
(X mod (8 div DataDepth)) * DataDepth));
{Discard the unwanted pixels}
ByteData:= ByteData and ($FF shr (8 - DataDepth));
{For palette mode map the palette entry and for grayscale convert and
returns the intensity}
case ColorType of
COLOR_PALETTE:
with TChunkPLTE(png.Chunks.ItemFromClass(TChunkPLTE)).Item[ByteData] do
Result := rgb(GammaTable[rgbRed], GammaTable[rgbGreen],
GammaTable[rgbBlue]);
COLOR_GRAYSCALE:
begin
if BitDepth = 1
then ByteData := GammaTable[Byte(ByteData * 255)]
else ByteData := GammaTable[Byte(ByteData * ((1 shl DataDepth) + 1))];
Result := rgb(ByteData, ByteData, ByteData);
end;
else Result := 0;
end {case};
end {with}
end;
{In case vcl units are not being used}
{$IFNDEF UseDelphi}
function ColorToRGB(const Color: TColor): COLORREF;
begin
Result := Color
end;
{$ENDIF}
{Sets a pixel for grayscale and palette pngs}
procedure SetByteArrayPixel(const png: TPngObject; const X, Y: Integer;
const Value: TColor);
const
ClearFlag: Array[1..8] of Integer = (1, 3, 0, 15, 0, 0, 0, $FF);
var
ByteData: pByte;
DataDepth: Byte;
ValEntry: Byte;
begin
with png.Header do
begin
{Map into a palette entry}
ValEntry := GetNearestPaletteIndex(Png.Palette, ColorToRGB(Value));
{16 bits grayscale extra bits are discarted}
DataDepth := BitDepth;
if DataDepth > 8 then DataDepth := 8;
{Gets a pointer to the byte we intend to change}
ByteData := @pByteArray(png.Scanline[Y])^[X div (8 div DataDepth)];
{Clears the old pixel data}
ByteData^ := ByteData^ and not (ClearFlag[DataDepth] shl ((8 - DataDepth) -
(X mod (8 div DataDepth)) * DataDepth));
{Setting the new pixel}
ByteData^ := ByteData^ or (ValEntry shl ((8 - DataDepth) -
(X mod (8 div DataDepth)) * DataDepth));
end {with png.Header}
end;
{Returns pixel when png uses RGB}
function GetRGBLinePixel(const png: TPngObject;
const X, Y: Integer): TColor;
begin
with pRGBLine(png.Scanline[Y])^[X] do
Result := RGB(rgbtRed, rgbtGreen, rgbtBlue)
end;
{Sets pixel when png uses RGB}
procedure SetRGBLinePixel(const png: TPngObject;
const X, Y: Integer; Value: TColor);
begin
with pRGBLine(png.Scanline[Y])^[X] do
begin
rgbtRed := GetRValue(Value);
rgbtGreen := GetGValue(Value);
rgbtBlue := GetBValue(Value)
end
end;
{Sets a pixel}
procedure TPngObject.SetPixels(const X, Y: Integer; const Value: TColor);
begin
if ((X >= 0) and (X <= Width - 1)) and
((Y >= 0) and (Y <= Height - 1)) then
with Header do
begin
if ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE] then
SetByteArrayPixel(Self, X, Y, Value)
else
SetRGBLinePixel(Self, X, Y, Value)
end {with}
end;
{Returns a pixel}
function TPngObject.GetPixels(const X, Y: Integer): TColor;
begin
if ((X >= 0) and (X <= Width - 1)) and
((Y >= 0) and (Y <= Height - 1)) then
with Header do
begin
if ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE] then
Result := GetByteArrayPixel(Self, X, Y)
else
Result := GetRGBLinePixel(Self, X, Y)
end {with}
else Result := 0
end;
{Returns the image palette}
function TPngObject.GetPalette: HPALETTE;
var
LogPalette: TMaxLogPalette;
i: Integer;
begin
{Palette is avaliable for COLOR_PALETTE and COLOR_GRAYSCALE modes}
if (Header.ColorType in [COLOR_PALETTE, COLOR_GRAYSCALE]) then
begin
{In case the pal}
if TempPalette = 0 then
with LogPalette do
begin
{Prepares the new palette}
palVersion := $300;
palNumEntries := 256;
{Copy entries}
for i := 0 to LogPalette.palNumEntries - 1 do
begin
palPalEntry[i].peRed := Header.BitmapInfo.bmiColors[i].rgbRed;
palPalEntry[i].peGreen := Header.BitmapInfo.bmiColors[i].rgbGreen;
palPalEntry[i].peBlue := Header.BitmapInfo.bmiColors[i].rgbBlue;
palPalEntry[i].peFlags := 0;
end {for i};
{Creates the palette}
TempPalette := CreatePalette(pLogPalette(@LogPalette)^);
end {with LogPalette, if Temppalette = 0}
end {if Header.ColorType in ...};
Result := TempPalette;
end;
initialization
{Initialize}
ChunkClasses := nil;
{crc table has not being computed yet}
crc_table_computed := FALSE;
{Register the necessary chunks for png}
RegisterCommonChunks;
{Registers TPNGObject to use with TPicture}
{$IFDEF UseDelphi}{$IFDEF RegisterGraphic}
TPicture.RegisterFileFormat('PNG', 'Portable Network Graphics', TPNGObject);
{$ENDIF}{$ENDIF}
finalization
{$IFDEF UseDelphi}{$IFDEF RegisterGraphic}
TPicture.UnregisterGraphicClass(TPNGObject);
{$ENDIF}{$ENDIF}
{Free chunk classes}
FreeChunkClassList;
end.