From 93f69ff9a0c9b05dfbbdcf6f7d737a68fc4d3bd1 Mon Sep 17 00:00:00 2001 From: tobigun Date: Sun, 6 Apr 2008 12:18:01 +0000 Subject: - removed (linux incompatible) PngImage. In addition it was rather outdated (from 2003, newest version is from 2006) - introduced UImage-unit for JPG/PNG/BMP image saving - the png part uses the libpng12-0.dll (part of SDL_Image) so - the jpg part uses either Delphi's Jpeg unit or FPC's base/pasjpeg unit -> so no additional libs are needed. git-svn-id: svn://svn.code.sf.net/p/ultrastardx/svn/trunk@1007 b956fd51-792f-4845-bead-9b4dfca2ff2c --- Game/Code/Classes/UImage.pas | 703 ++++ Game/Code/Classes/UMain.pas | 2 +- Game/Code/Classes/UTexture.pas | 55 +- Game/Code/Classes/Ulazjpeg.pas | 151 - Game/Code/Menu/UDisplay.pas | 145 +- Game/Code/Screens/UScreenScore.pas | 14 +- Game/Code/Screens/UScreenTop5.pas | 2 +- Game/Code/UltraStar.dpr | 4 + Game/Code/lib/PngImage/Tpngimage.DPK | 34 - Game/Code/lib/PngImage/Tpngimage.bdsproj | 177 - Game/Code/lib/PngImage/Tpngimage.bdsproj.local | 2 - Game/Code/lib/PngImage/Tpngimage.cfg | 40 - Game/Code/lib/PngImage/Tpngimage.dof | 136 - Game/Code/lib/PngImage/Tpngimage.drc | 62 - Game/Code/lib/PngImage/Tpngimage.res | Bin 1536 -> 0 bytes Game/Code/lib/PngImage/Tpngimage.stat | 10 - Game/Code/lib/PngImage/lazarustest.lpi | 239 -- Game/Code/lib/PngImage/lazarustest.lpr | 15 - Game/Code/lib/PngImage/obj/adler32.obj | Bin 602 -> 0 bytes Game/Code/lib/PngImage/obj/deflate.obj | Bin 6993 -> 0 bytes Game/Code/lib/PngImage/obj/infblock.obj | Bin 5347 -> 0 bytes Game/Code/lib/PngImage/obj/infcodes.obj | Bin 3600 -> 0 bytes Game/Code/lib/PngImage/obj/inffast.obj | Bin 2323 -> 0 bytes Game/Code/lib/PngImage/obj/inflate.obj | Bin 3188 -> 0 bytes Game/Code/lib/PngImage/obj/inftrees.obj | Bin 7995 -> 0 bytes Game/Code/lib/PngImage/obj/infutil.obj | Bin 1339 -> 0 bytes Game/Code/lib/PngImage/obj/trees.obj | Bin 11623 -> 0 bytes Game/Code/lib/PngImage/pngimage.chm | Bin 162254 -> 0 bytes Game/Code/lib/PngImage/pngimage.pas | 5213 ------------------------ Game/Code/lib/PngImage/pngimage.~pas | 5205 ----------------------- Game/Code/lib/PngImage/pnglang.pas | 301 -- Game/Code/lib/PngImage/pngzlib.pas | 172 - Game/Code/lib/libpng/png.pas | 980 +++++ Game/Code/lib/zlib/zlib.pas | 207 + 34 files changed, 1955 insertions(+), 11914 deletions(-) create mode 100644 Game/Code/Classes/UImage.pas delete mode 100644 Game/Code/Classes/Ulazjpeg.pas delete mode 100644 Game/Code/lib/PngImage/Tpngimage.DPK delete mode 100644 Game/Code/lib/PngImage/Tpngimage.bdsproj delete mode 100644 Game/Code/lib/PngImage/Tpngimage.bdsproj.local delete mode 100644 Game/Code/lib/PngImage/Tpngimage.cfg delete mode 100644 Game/Code/lib/PngImage/Tpngimage.dof delete mode 100644 Game/Code/lib/PngImage/Tpngimage.drc delete mode 100644 Game/Code/lib/PngImage/Tpngimage.res delete mode 100644 Game/Code/lib/PngImage/Tpngimage.stat delete mode 100644 Game/Code/lib/PngImage/lazarustest.lpi delete mode 100644 Game/Code/lib/PngImage/lazarustest.lpr delete mode 100644 Game/Code/lib/PngImage/obj/adler32.obj delete mode 100644 Game/Code/lib/PngImage/obj/deflate.obj delete mode 100644 Game/Code/lib/PngImage/obj/infblock.obj delete mode 100644 Game/Code/lib/PngImage/obj/infcodes.obj delete mode 100644 Game/Code/lib/PngImage/obj/inffast.obj delete mode 100644 Game/Code/lib/PngImage/obj/inflate.obj delete mode 100644 Game/Code/lib/PngImage/obj/inftrees.obj delete mode 100644 Game/Code/lib/PngImage/obj/infutil.obj delete mode 100644 Game/Code/lib/PngImage/obj/trees.obj delete mode 100644 Game/Code/lib/PngImage/pngimage.chm delete mode 100644 Game/Code/lib/PngImage/pngimage.pas delete mode 100644 Game/Code/lib/PngImage/pngimage.~pas delete mode 100644 Game/Code/lib/PngImage/pnglang.pas delete mode 100644 Game/Code/lib/PngImage/pngzlib.pas create mode 100644 Game/Code/lib/libpng/png.pas create mode 100644 Game/Code/lib/zlib/zlib.pas (limited to 'Game') diff --git a/Game/Code/Classes/UImage.pas b/Game/Code/Classes/UImage.pas new file mode 100644 index 00000000..640e5202 --- /dev/null +++ b/Game/Code/Classes/UImage.pas @@ -0,0 +1,703 @@ +unit UImage; + +interface + +{$IFDEF FPC} + {$MODE Delphi} +{$ENDIF} + +{$I ../switches.inc} + +uses + SDL; + +{$DEFINE HavePNG} +{$DEFINE HaveBMP} +{$DEFINE HaveJPG} + +const + PixelFmt_RGBA: TSDL_Pixelformat = ( + palette: nil; + BitsPerPixel: 32; + BytesPerPixel: 4; + Rloss: 0; + Gloss: 0; + Bloss: 0; + Aloss: 0; + Rshift: 0; + Gshift: 8; + Bshift: 16; + Ashift: 24; + Rmask: $000000ff; + Gmask: $0000ff00; + Bmask: $00ff0000; + Amask: $ff000000; + ColorKey: 0; + Alpha: 255 + ); + + PixelFmt_RGB: TSDL_Pixelformat = ( + palette: nil; + BitsPerPixel: 24; + BytesPerPixel: 3; + Rloss: 0; + Gloss: 0; + Bloss: 0; + Aloss: 0; + Rshift: 0; + Gshift: 8; + Bshift: 16; + Ashift: 0; + Rmask: $000000ff; + Gmask: $0000ff00; + Bmask: $00ff0000; + Amask: $00000000; + ColorKey: 0; + Alpha: 255 + ); + + PixelFmt_BGRA: TSDL_Pixelformat = ( + palette: nil; + BitsPerPixel: 32; + BytesPerPixel: 4; + Rloss: 0; + Gloss: 0; + Bloss: 0; + Aloss: 0; + Rshift: 16; + Gshift: 8; + Bshift: 0; + Ashift: 24; + Rmask: $00ff0000; + Gmask: $0000ff00; + Bmask: $000000ff; + Amask: $ff000000; + ColorKey: 0; + Alpha: 255 + ); + + PixelFmt_BGR: TSDL_Pixelformat = ( + palette: nil; + BitsPerPixel: 24; + BytesPerPixel: 3; + Rloss: 0; + Gloss: 0; + Bloss: 0; + Aloss: 0; + Rshift: 16; + Gshift: 8; + Bshift: 0; + Ashift: 0; + Rmask: $00ff0000; + Gmask: $0000ff00; + Bmask: $000000ff; + Amask: $00000000; + ColorKey: 0; + Alpha: 255 + ); + + +{$IFDEF HavePNG} +function WritePNGImage(const FileName: string; Surface: PSDL_Surface): boolean; +{$ENDIF} +{$IFDEF HaveBMP} +function WriteBMPImage(const FileName: string; Surface: PSDL_Surface): boolean; +{$ENDIF} +{$IFDEF HaveJPG} +function WriteJPGImage(const FileName: string; Surface: PSDL_Surface; Quality: integer): boolean; +{$ENDIF} + +implementation + +uses + SysUtils, + Classes, + {$IFDEF MSWINDOWS} + Windows, + {$ENDIF} + {$IFDEF HaveJPG} + {$IFDEF Delphi} + Graphics, + jpeg, + {$ELSE} + jpeglib, + jerror, + jcparam, + jdatadst, jcapimin, jcapistd, + {$ENDIF} + {$ENDIF} + {$IFDEF HavePNG} + png, + {$ENDIF} + zlib, + ULog; + +function IsRGBSurface(pixelFmt: PSDL_PixelFormat): boolean; +begin + Result := (pixelFmt.BitsPerPixel = 24) and + (pixelFmt.RMask = $0000FF) and + (pixelFmt.GMask = $00FF00) and + (pixelFmt.BMask = $FF0000); +end; + +function IsRGBASurface(pixelFmt: PSDL_PixelFormat): boolean; +begin + Result := (pixelFmt.BitsPerPixel = 32) and + (pixelFmt.RMask = $000000FF) and + (pixelFmt.GMask = $0000FF00) and + (pixelFmt.BMask = $00FF0000) and + (pixelFmt.AMask = $FF000000); +end; + +function IsBGRSurface(pixelFmt: PSDL_PixelFormat): boolean; +begin + Result := (pixelFmt.BitsPerPixel = 24) and + (pixelFmt.BMask = $0000FF) and + (pixelFmt.GMask = $00FF00) and + (pixelFmt.RMask = $FF0000); +end; + +function IsBGRASurface(pixelFmt: PSDL_PixelFormat): boolean; +begin + Result := (pixelFmt.BitsPerPixel = 32) and + (pixelFmt.BMask = $000000FF) and + (pixelFmt.GMask = $0000FF00) and + (pixelFmt.RMask = $00FF0000) and + (pixelFmt.AMask = $FF000000); +end; + +// Converts alpha-formats to BGRA, non-alpha to BGR, and leaves BGR(A) as is +// sets converted to true if the surface needed to be converted +function ConvertToBGR_BGRASurface(Surface: PSDL_Surface; out Converted: boolean): PSDL_Surface; +var + pixelFmt: PSDL_PixelFormat; +begin + pixelFmt := Surface.format; + if (IsBGRSurface(pixelFmt) or IsBGRASurface(pixelFmt)) then + begin + Converted := false; + Result := Surface; + end + else + begin + // invalid format -> needs conversion + if (pixelFmt.AMask <> 0) then + Result := SDL_ConvertSurface(Surface, @PixelFmt_BGRA, SDL_SWSURFACE) + else + Result := SDL_ConvertSurface(Surface, @PixelFmt_BGR, SDL_SWSURFACE); + Converted := true; + end; +end; + +// Converts alpha-formats to RGBA, non-alpha to RGB, and leaves RGB(A) as is +// sets converted to true if the surface needed to be converted +function ConvertToRGB_RGBASurface(Surface: PSDL_Surface; out Converted: boolean): PSDL_Surface; +var + pixelFmt: PSDL_PixelFormat; +begin + pixelFmt := Surface.format; + if (IsRGBSurface(pixelFmt) or IsRGBASurface(pixelFmt)) then + begin + Converted := false; + Result := Surface; + end + else + begin + // invalid format -> needs conversion + if (pixelFmt.AMask <> 0) then + Result := SDL_ConvertSurface(Surface, @PixelFmt_RGBA, SDL_SWSURFACE) + else + Result := SDL_ConvertSurface(Surface, @PixelFmt_RGB, SDL_SWSURFACE); + Converted := true; + end; +end; + +(*************************** + * PNG section + *****************************) + +{$IFDEF HavePNG} + +// delphi does not support setjmp()/longjmp() -> define our own error-handler +procedure user_error_fn(png_ptr: png_structp; error_msg: png_const_charp); cdecl; +begin + raise Exception.Create(error_msg); +end; + +procedure user_read_data(png_ptr: png_structp; data: png_bytep; length: png_size_t); cdecl; +var + inFile: TFileStream; +begin + inFile := TFileStream(png_get_io_ptr(png_ptr)); + inFile.Read(data^, length); +end; + +procedure user_write_data(png_ptr: png_structp; data: png_bytep; length: png_size_t); cdecl; +var + outFile: TFileStream; +begin + outFile := TFileStream(png_get_io_ptr(png_ptr)); + outFile.Write(data^, length); +end; + +procedure user_flush_data(png_ptr: png_structp); cdecl; +//var +// outFile: TFileStream; +begin + // binary files are flushed automatically, Flush() works with Text-files only + //outFile := TFileStream(png_get_io_ptr(png_ptr)); + //outFile.Flush(); +end; + +procedure DateTimeToPngTime(time: TDateTime; var pngTime: png_time); +var + year, month, day: word; + hour, minute, second, msecond: word; +begin + DecodeDate(time, year, month, day); + pngTime.year := year; + pngTime.month := month; + pngTime.day := day; + DecodeTime(time, hour, minute, second, msecond); + pngTime.hour := hour; + pngTime.minute := minute; + pngTime.second := second; +end; + +(* + * ImageData must be in RGB-format + *) +function WritePNGImage(const FileName: string; Surface: PSDL_Surface): boolean; +var + png_ptr: png_structp; + info_ptr: png_infop; + pngFile: TFileStream; + row: integer; + rowData: array of png_bytep; + rowStride: integer; + converted: boolean; + colorType: integer; + //time: png_time; +begin + Result := false; + + // open file for writing + try + pngFile := TFileStream.Create(FileName, fmCreate); + except + Log.LogError('Could not open file: "' + FileName + '"', 'WritePngImage'); + Exit; + end; + + // only 24bit (RGB) or 32bit (RGBA) data is supported, so convert to it + Surface := ConvertToRGB_RGBASurface(Surface, converted); + + png_ptr := nil; + + try + // initialize png (and enable a user-defined error-handler that throws an exception on error) + png_ptr := png_create_write_struct(PNG_LIBPNG_VER_STRING, nil, @user_error_fn, nil); + // the error-handler is called if png_create_write_struct() fails, so png_ptr should always be <> nil + if (png_ptr = nil) then + begin + Log.LogError('png_create_write_struct() failed', 'WritePngImage'); + if (converted) then + SDL_FreeSurface(Surface); + Exit; + end; + + info_ptr := png_create_info_struct(png_ptr); + + if (Surface^.format^.BitsPerPixel = 24) then + colorType := PNG_COLOR_TYPE_RGB + else + colorType := PNG_COLOR_TYPE_RGBA; + + // define write IO-functions (POSIX-style FILE-pointers are not available in Delphi) + png_set_write_fn(png_ptr, pngFile, @user_write_data, @user_flush_data); + png_set_IHDR( + png_ptr, info_ptr, + Surface.w, Surface.h, + 8, + colorType, + PNG_INTERLACE_NONE, + PNG_COMPRESSION_TYPE_DEFAULT, + PNG_FILTER_TYPE_DEFAULT + ); + + // TODO: do we need the modification time? + //DateTimeToPngTime(Now, time); + //png_set_tIME(png_ptr, info_ptr, @time); + + if (SDL_MUSTLOCK(Surface)) then + SDL_LockSurface(Surface); + + // setup data + SetLength(rowData, Surface.h); + for row := 0 to Surface.h-1 do + begin + // set rowData-elements to beginning of each image row + // Note: the byte-count of a row is pitch (which is not width*bitsPerPixel if the image is aligned) + rowData[row] := @PChar(Surface.pixels)[(Surface.h-row-1) * Surface.pitch]; + end; + + if (SDL_MUSTLOCK(Surface)) then + SDL_UnlockSurface(Surface); + + png_write_info(png_ptr, info_ptr); + png_write_image(png_ptr, png_bytepp(rowData)); + png_write_end(png_ptr, nil); + + Result := true; + except on E: Exception do + Log.LogError(E.message, 'WritePngImage'); + end; + + // free row-data + SetLength(rowData, 0); + + // free png-resources + if (png_ptr <> nil) then + png_destroy_write_struct(@png_ptr, nil); + + if (converted) then + SDL_FreeSurface(Surface); + + // close file + pngFile.Free; +end; + +{$ENDIF} + +(*************************** + * BMP section + *****************************) + +{$IFDEF HaveBMP} + +{$IFNDEF MSWINDOWS} +const + (* constants for the biCompression field *) + BI_RGB = 0; + BI_RLE8 = 1; + BI_RLE4 = 2; + BI_BITFIELDS = 3; + BI_JPEG = 4; + BI_PNG = 5; + +type + BITMAPINFOHEADER = record + biSize: longword; + biWidth: longint; + biHeight: longint; + biPlanes: word; + biBitCount: word; + biCompression: longword; + biSizeImage: longword; + biXPelsPerMeter: longint; + biYPelsPerMeter: longint; + biClrUsed: longword; + biClrImportant: longword; + end; + LPBITMAPINFOHEADER = ^BITMAPINFOHEADER; + TBITMAPINFOHEADER = BITMAPINFOHEADER; + PBITMAPINFOHEADER = ^BITMAPINFOHEADER; + + RGBTRIPLE = record + rgbtBlue: byte; + rgbtGreen: byte; + rgbtRed: byte; + end; + tagRGBTRIPLE = RGBTRIPLE; + TRGBTRIPLE = RGBTRIPLE; + PRGBTRIPLE = ^RGBTRIPLE; + + RGBQUAD = record + rgbBlue: byte; + rgbGreen: byte; + rgbRed: byte; + rgbReserved: byte; + end; + tagRGBQUAD = RGBQUAD; + TRGBQUAD = RGBQUAD; + PRGBQUAD = ^RGBQUAD; + + BITMAPINFO = record + bmiHeader: BITMAPINFOHEADER; + bmiColors: array[0..0] of RGBQUAD; + end; + LPBITMAPINFO = ^BITMAPINFO; + PBITMAPINFO = ^BITMAPINFO; + TBITMAPINFO = BITMAPINFO; + + {$PACKRECORDS 2} + BITMAPFILEHEADER = record + bfType: word; + bfSize: longword; + bfReserved1: word; + bfReserved2: word; + bfOffBits: longword; + end; + {$PACKRECORDS DEFAULT} +{$ENDIF} + +(* + * ImageData must be in BGR-format + *) +function WriteBMPImage(const FileName: string; Surface: PSDL_Surface): boolean; +var + bmpFile: TFileStream; + FileInfo: BITMAPINFOHEADER; + FileHeader: BITMAPFILEHEADER; + Converted: boolean; + Row: integer; + RowSize: integer; +begin + Result := false; + + // open file for writing + try + bmpFile := TFileStream.Create(FileName, fmCreate); + except + Log.LogError('Could not open file: "' + FileName + '"', 'WriteBMPImage'); + Exit; + end; + + // only 24bit (BGR) or 32bit (BGRA) data is supported, so convert to it + Surface := ConvertToBGR_BGRASurface(Surface, Converted); + + // aligned (4-byte) row-size in bytes + RowSize := ((Surface.w * Surface.format.BytesPerPixel + 3) div 4) * 4; + + // initialize bitmap info + FillChar(FileInfo, SizeOf(BITMAPINFOHEADER), 0); + with FileInfo do + begin + biSize := SizeOf(BITMAPINFOHEADER); + biWidth := Surface.w; + biHeight := Surface.h; + biPlanes := 1; + biBitCount := Surface^.format^.BitsPerPixel; + biCompression := BI_RGB; + biSizeImage := RowSize * Surface.h; + end; + + // initialize header-data + FillChar(FileHeader, SizeOf(BITMAPFILEHEADER), 0); + with FileHeader do + begin + bfType := $4D42; // = 'BM' + bfOffBits := SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER); + bfSize := bfOffBits + FileInfo.biSizeImage; + end; + + // and move the whole stuff into the file ;-) + try + // write headers + bmpFile.Write(FileHeader, SizeOf(BITMAPFILEHEADER)); + bmpFile.Write(FileInfo, SizeOf(BITMAPINFOHEADER)); + + // write image-data + + if (SDL_MUSTLOCK(Surface)) then + SDL_LockSurface(Surface); + + // BMP needs 4-byte alignment + if (Surface.pitch mod 4 = 0) then + begin + // aligned correctly -> write whole image at once + bmpFile.Write(Surface.pixels^, FileInfo.biSizeImage); + end + else + begin + // misaligned -> write each line separately + // Note: for the last line unassigned memory (> last Surface.pixels element) + // will be copied to the padding area (last bytes of a row), + // but we do not care because the content of padding data is ignored anyhow. + for Row := 0 to Surface.h do + bmpFile.Write(PChar(Surface.pixels)[Row * Surface.pitch], RowSize); + end; + + if (SDL_MUSTLOCK(Surface)) then + SDL_UnlockSurface(Surface); + + Result := true; + finally + Log.LogError('Could not write file: "' + FileName + '"', 'WriteBMPImage'); + end; + + if (Converted) then + SDL_FreeSurface(Surface); + + // close file + bmpFile.Free; +end; + +{$ENDIF} + +(*************************** + * JPG section + *****************************) + +{$IFDEF HaveJPG} + +function WriteJPGImage(const FileName: string; Surface: PSDL_Surface; Quality: integer): boolean; +var + {$IFDEF Delphi} + Bitmap: TBitmap; + BitmapInfo: TBitmapInfo; + Jpeg: TJpegImage; + row: integer; + {$ELSE} + cinfo: jpeg_compress_struct; + jerr : jpeg_error_mgr; + jpgFile: TFileStream; + rowPtr: array[0..0] of JSAMPROW; + {$ENDIF} + converted: boolean; +begin + Result := false; + + {$IFDEF Delphi} + // only 24bit (BGR) data is supported, so convert to it + if (IsBGRSurface(Surface.format)) then + converted := false + else + begin + Surface := SDL_ConvertSurface(Surface, @PixelFmt_BGR, SDL_SWSURFACE); + converted := true; + end; + + // create and setup bitmap + Bitmap := TBitmap.Create; + Bitmap.PixelFormat := pf24bit; + Bitmap.Width := Surface.w; + Bitmap.Height := Surface.h; + + // setup bitmap info on source image (Surface parameter) + ZeroMemory(@BitmapInfo, SizeOf(BitmapInfo)); + with BitmapInfo.bmiHeader do + begin + biSize := SizeOf(BITMAPINFOHEADER); + biWidth := Surface.w; + biHeight := Surface.h; + biPlanes := 1; + biBitCount := 24; + biCompression := BI_RGB; + end; + + if (SDL_MUSTLOCK(Surface)) then + SDL_LockSurface(Surface); + + // use fast Win32-API functions to copy data instead of Bitmap.Canvas.Pixels + if (Surface.pitch mod 4 = 0) then + begin + // if the image is aligned (to a 4-byte boundary) -> copy all data at once + // Note: surfaces created with SDL (e.g. with SDL_ConvertSurface) are aligned + SetDIBits(0, Bitmap.Handle, 0, Bitmap.Height, Surface.pixels, BitmapInfo, DIB_RGB_COLORS); + end + else + begin + // wrong alignment -> copy each line separately. + // Note: for the last line unassigned memory (> last Surface.pixels element) + // will be copied to the padding area (last bytes of a row), + // but we do not care because the content of padding data is ignored anyhow. + for row := 0 to Surface.h do + begin + SetDIBits(0, Bitmap.Handle, row, 1, @PChar(Surface.pixels)[row * Surface.pitch], + BitmapInfo, DIB_RGB_COLORS); + end; + end; + + if (SDL_MUSTLOCK(Surface)) then + SDL_UnlockSurface(Surface); + + // assign Bitmap to JPEG and store the latter + Jpeg := TJPEGImage.Create; + Jpeg.Assign(Bitmap); + Bitmap.Free; + Jpeg.CompressionQuality := Quality; + try + // compress image (don't forget this line, otherwise it won't be compressed) + Jpeg.Compress(); + Jpeg.SaveToFile(FileName); + except + Log.LogError('Could not save file: "' + FileName + '"', 'WriteJPGImage'); + Exit; + end; + Jpeg.Free; + {$ELSE} + // based on example.pas in FPC's packages/base/pasjpeg directory + + // only 24bit (RGB) data is supported, so convert to it + if (IsRGBSurface(Surface.format)) then + converted := false + else + begin + Surface := SDL_ConvertSurface(Surface, @PixelFmt_RGB, SDL_SWSURFACE); + converted := true; + end; + + // allocate and initialize JPEG compression object + cinfo.err := jpeg_std_error(jerr); + // msg_level that will be displayed. (Nomssi) + //jerr.trace_level := 3; + // initialize the JPEG compression object + jpeg_create_compress(@cinfo); + + // open file for writing + try + jpgFile := TFileStream.Create(FileName, fmCreate); + except + Log.LogError('Could not open file: "' + FileName + '"', 'WriteJPGImage'); + Exit; + end; + + // specify data destination + jpeg_stdio_dest(@cinfo, @jpgFile); + + // set parameters for compression + cinfo.image_width := Surface.w; + cinfo.image_height := Surface.h; + cinfo.in_color_space := JCS_RGB; + cinfo.input_components := 3; + cinfo.data_precision := 8; + + // set default compression parameters + jpeg_set_defaults(@cinfo); + jpeg_set_quality(@cinfo, quality, true); + + // start compressor + jpeg_start_compress(@cinfo, true); + + if (SDL_MUSTLOCK(Surface)) then + SDL_LockSurface(Surface); + + while (cinfo.next_scanline < cinfo.image_height) do + begin + // Note: the byte-count of a row is pitch (which is not width*bitsPerPixel if the image is aligned) + rowPtr[0] := JSAMPROW(@PChar(Surface.pixels)[(Surface.h-cinfo.next_scanline-1) * Surface.pitch]); + jpeg_write_scanlines(@cinfo, JSAMPARRAY(@rowPtr), 1); + end; + + if (SDL_MUSTLOCK(Surface)) then + SDL_UnlockSurface(Surface); + + // finish compression + jpeg_finish_compress(@cinfo); + // close the output file + jpgFile.Free; + + // release JPEG compression object + jpeg_destroy_compress(@cinfo); + {$ENDIF} + + if (converted) then + SDL_FreeSurface(Surface); + + Result := true; +end; + +{$ENDIF} + +end. diff --git a/Game/Code/Classes/UMain.pas b/Game/Code/Classes/UMain.pas index 898c7193..2c6c2fe5 100644 --- a/Game/Code/Classes/UMain.pas +++ b/Game/Code/Classes/UMain.pas @@ -468,7 +468,7 @@ begin end // ScreenShot hack. If Print is pressed-> Make screenshot and Save to Screenshots Path else if (Event.key.keysym.sym = SDLK_SYSREQ) or (Event.key.keysym.sym = SDLK_PRINT) then - Display.ScreenShot + Display.SaveScreenShot // popup hack... if there is a visible popup then let it handle input instead of underlying screen // shoud be done in a way to be sure the topmost popup has preference (maybe error, then check) else if (ScreenPopupError <> nil) and (ScreenPopupError.Visible) then diff --git a/Game/Code/Classes/UTexture.pas b/Game/Code/Classes/UTexture.pas index f9f0cc10..35757a8e 100644 --- a/Game/Code/Classes/UTexture.pas +++ b/Game/Code/Classes/UTexture.pas @@ -18,6 +18,7 @@ uses OpenGL12, Classes, SysUtils, UCommon, + UImage, SDL, sdlutils, SDL_Image; @@ -139,46 +140,6 @@ uses ULog, {$ENDIF} StrUtils; -const - fmt_rgba: TSDL_Pixelformat = ( - palette: nil; - BitsPerPixel: 32; - BytesPerPixel: 4; - Rloss: 0; - Gloss: 0; - Bloss: 0; - Aloss: 0; - Rshift: 0; - Gshift: 8; - Bshift: 16; - Ashift: 24; - Rmask: $000000ff; - Gmask: $0000ff00; - Bmask: $00ff0000; - Amask: $ff000000; - ColorKey: 0; - Alpha: 255 - ); - fmt_rgb: TSDL_Pixelformat = ( - palette: nil; - BitsPerPixel: 24; - BytesPerPixel: 3; - Rloss: 0; - Gloss: 0; - Bloss: 0; - Aloss: 0; - Rshift: 0; - Gshift: 8; - Bshift: 16; - Ashift: 0; - Rmask: $000000ff; - Gmask: $0000ff00; - Bmask: $00ff0000; - Amask: $00000000; - ColorKey: 0; - Alpha: 255 - ); - Constructor TTextureUnit.Create; begin @@ -388,14 +349,14 @@ var TempSurface: PSDL_Surface; NeededPixFmt: PSDL_Pixelformat; begin - NeededPixFmt:=@fmt_rgba; - if (Typ = TEXTURE_TYPE_PLAIN) then NeededPixFmt:=@fmt_rgb - else - if (Typ = TEXTURE_TYPE_TRANSPARENT) or - (Typ = TEXTURE_TYPE_COLORIZED) - then NeededPixFmt:=@fmt_rgba + NeededPixFmt:=@PixelFmt_RGBA; + if (Typ = TEXTURE_TYPE_PLAIN) then + NeededPixFmt:=@PixelFmt_RGB + else if (Typ = TEXTURE_TYPE_TRANSPARENT) or + (Typ = TEXTURE_TYPE_COLORIZED) then + NeededPixFmt:=@PixelFmt_RGBA else - NeededPixFmt:=@fmt_rgb; + NeededPixFmt:=@PixelFmt_RGB; if not pixfmt_eq(TexSurface^.format, NeededPixFmt) then diff --git a/Game/Code/Classes/Ulazjpeg.pas b/Game/Code/Classes/Ulazjpeg.pas deleted file mode 100644 index 2414002c..00000000 --- a/Game/Code/Classes/Ulazjpeg.pas +++ /dev/null @@ -1,151 +0,0 @@ -{ Copyright (C) 2003 Mattias Gaertner - - This library is free software; you can redistribute it and/or modify it - under the terms of the GNU Library General Public License as published by - the Free Software Foundation; either version 2 of the License, or (at your - option) any later version. - - This program is distributed in the hope that it will be useful, but WITHOUT - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License - for more details. - - You should have received a copy of the GNU Library General Public License - along with this library; if not, write to the Free Software Foundation, - Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -} -unit Ulazjpeg; - -{$mode delphi} - -{$I switches.inc} - -interface - -uses - SysUtils, Classes, FPImage, IntfGraphics, Graphics, FPReadJPEG, FPWriteJPEG, - UConfig; - -type - TJPEGQualityRange = TFPJPEGCompressionQuality; - TJPEGPerformance = TJPEGReadPerformance; - - TJPEGImage = class(TFPImageBitmap) - private - FPerformance: TJPEGPerformance; - FProgressiveEncoding: boolean; - FQuality: TJPEGQualityRange; - protected -{$IF LAZARUS_VERSION >= 000009024} // 0.9.24 - procedure InitFPImageReader(IntfImg: TLazIntfImage; ImgReader: TFPCustomImageReader); override; -{$ELSE} - procedure InitFPImageReader(ImgReader: TFPCustomImageReader); override; -{$IFEND} - procedure FinalizeFPImageReader(ImgReader: TFPCustomImageReader); override; -{$IF LAZARUS_VERSION >= 000009024} // 0.9.24 - procedure InitFPImageWriter(IntfImg: TLazIntfImage; ImgWriter: TFPCustomImageWriter); override; -{$ELSE} - procedure InitFPImageWriter(ImgWriter: TFPCustomImageWriter); override; -{$IFEND} - public - constructor Create; override; - class function GetFileExtensions: string; override; - class function GetDefaultFPReader: TFPCustomImageReaderClass; override; - class function GetDefaultFPWriter: TFPCustomImageWriterClass; override; - public - property CompressionQuality: TJPEGQualityRange read FQuality write FQuality; - property ProgressiveEncoding: boolean read FProgressiveEncoding; - property Performance: TJPEGPerformance read FPerformance write FPerformance; - end; - -const - DefaultJPEGMimeType = 'image/jpeg'; - - -implementation - - -{ TJPEGImage } - -{$IF LAZARUS_VERSION >= 000009024} // 0.9.24 -procedure TJPEGImage.InitFPImageReader(IntfImg: TLazIntfImage; ImgReader: TFPCustomImageReader); -{$ELSE} -procedure TJPEGImage.InitFPImageReader(ImgReader: TFPCustomImageReader); -{$IFEND} -var - JPEGReader: TFPReaderJPEG; -begin - if ImgReader is TFPReaderJPEG then begin - JPEGReader:=TFPReaderJPEG(ImgReader); - JPEGReader.Performance:=Performance; -{$IF LAZARUS_VERSION >= 000009024} // 0.9.24 - JPEGReader.OnProgress:=Progress; -{$IFEND} - end; -{$IF LAZARUS_VERSION >= 000009024} // 0.9.24 - inherited InitFPImageReader(IntfImg, ImgReader); -{$ELSE} - inherited InitFPImageReader(ImgReader); -{$IFEND} -end; - -procedure TJPEGImage.FinalizeFPImageReader(ImgReader: TFPCustomImageReader); -var - JPEGReader: TFPReaderJPEG; -begin - if ImgReader is TFPReaderJPEG then begin - JPEGReader:=TFPReaderJPEG(ImgReader); - FProgressiveEncoding:=JPEGReader.ProgressiveEncoding; - end; - inherited FinalizeFPImageReader(ImgReader); -end; - -{$IF LAZARUS_VERSION >= 000009024} // 0.9.24 -procedure TJPEGImage.InitFPImageWriter(IntfImg: TLazIntfImage; ImgWriter: TFPCustomImageWriter); -{$ELSE} -procedure TJPEGImage.InitFPImageWriter(ImgWriter: TFPCustomImageWriter); -{$IFEND} -var - JPEGWriter: TFPWriterJPEG; -begin - if ImgWriter is TFPWriterJPEG then begin - JPEGWriter:=TFPWriterJPEG(ImgWriter); - if JPEGWriter<>nil then ; - JPEGWriter.ProgressiveEncoding:=ProgressiveEncoding; - JPEGWriter.CompressionQuality:=CompressionQuality; -{$IF LAZARUS_VERSION >= 000009024} // 0.9.24 - JPEGWriter.OnProgress:=Progress; -{$IFEND} - end; -{$IF LAZARUS_VERSION >= 000009024} // 0.9.24 - inherited InitFPImageWriter(IntfImg, ImgWriter); -{$ELSE} - inherited InitFPImageWriter(ImgWriter); -{$IFEND} -end; - -class function TJPEGImage.GetDefaultFPReader: TFPCustomImageReaderClass; -begin - Result:=TFPReaderJPEG; -end; - -class function TJPEGImage.GetDefaultFPWriter: TFPCustomImageWriterClass; -begin - Result:=TFPWriterJPEG; -end; - -constructor TJPEGImage.Create; -begin - inherited Create; - FPerformance:=jpBestQuality; - FProgressiveEncoding:=false; - FQuality:=75; -end; - -class function TJPEGImage.GetFileExtensions: string; -begin - Result:='jpg;jpeg'; -end; - -end. - diff --git a/Game/Code/Menu/UDisplay.pas b/Game/Code/Menu/UDisplay.pas index 896e7656..19c42483 100644 --- a/Game/Code/Menu/UDisplay.pas +++ b/Game/Code/Menu/UDisplay.pas @@ -34,8 +34,6 @@ type OSD_LastError : String; - PrintScreenData: array[0..1024*768-1] of longword; - procedure DrawDebugInformation; public NextScreen : PMenu; @@ -50,8 +48,7 @@ type constructor Create; destructor Destroy; override; - procedure PrintScreen; - procedure ScreenShot; + procedure SaveScreenShot; function Draw: Boolean; end; @@ -62,18 +59,15 @@ var implementation uses - {$IFDEF Delphi} - JPEG, - graphics, - {$ENDIF} - TextGL, -// ULog, - UMain, - UTexture, - UIni, - UGraphic, - UTime, - UCommandLine; + UImage, + TextGL, + ULog, + UMain, + UTexture, + UIni, + UGraphic, + UTime, + UCommandLine; constructor TDisplay.Create; var @@ -327,111 +321,48 @@ begin Result := $FF div FadeStep; end;} -procedure TDisplay.PrintScreen; -(* +procedure TDisplay.SaveScreenShot; var - Bitmap: TBitmap; - Jpeg: TJpegImage; - X, Y: integer; Num: integer; FileName: string; -*) + ScreenData: PChar; + Surface: PSDL_Surface; + Success: boolean; + Align: integer; + RowSize: integer; begin -(* for Num := 1 to 9999 do begin FileName := IntToStr(Num); while Length(FileName) < 4 do FileName := '0' + FileName; - FileName := ScreenshotsPath + 'screenshot' + FileName + '.jpg'; + FileName := ScreenshotsPath + 'screenshot' + FileName + '.png'; if not FileExists(FileName) then break end; - glReadPixels(0, 0, ScreenW, ScreenH, GL_RGBA, GL_UNSIGNED_BYTE, @PrintScreenData[0]); - Bitmap := TBitmap.Create; - Bitmap.Width := ScreenW; - Bitmap.Height := ScreenH; - - for Y := 0 to ScreenH-1 do - for X := 0 to ScreenW-1 do - Bitmap.Canvas.Pixels[X, Y] := PrintScreenData[(ScreenH-1-Y) * ScreenW + X] and $00FFFFFF; - - Jpeg := TJpegImage.Create; - Jpeg.Assign(Bitmap); - Bitmap.Free; - Jpeg.CompressionQuality := 95;//90; - Jpeg.SaveToFile(FileName); - Jpeg.Free; -*) -end; - -procedure TDisplay.ScreenShot; -{ -var - F : file; - FileInfo: BITMAPINFOHEADER; - FileHeader : BITMAPFILEHEADER; - pPicData:Pointer; - FileName: String; - Num: Integer; -} -begin - // FIXME: something broken in here... quick fix... disabled it - Exit; -{ - // search image-file - for Num := 1 to 9999 do - begin - FileName := IntToStr(Num); - while Length(FileName) < 4 do - FileName := '0' + FileName; - FileName := ScreenshotsPath + FileName + '.BMP'; - if not FileExists(FileName) then - break - end; + // we must take the row-alignment (4byte by default) into account + glGetIntegerv(GL_PACK_ALIGNMENT, @Align); + // calc aligned row-size + RowSize := ((ScreenW*3 + (Align-1)) div Align) * Align; + + GetMem(ScreenData, RowSize * ScreenH); + glReadPixels(0, 0, ScreenW, ScreenH, GL_BGR, GL_UNSIGNED_BYTE, ScreenData); + Surface := SDL_CreateRGBSurfaceFrom( + ScreenData, ScreenW, ScreenH, 24, RowSize, + //$0000FF, $00FF00, $FF0000, 0); + $FF0000, $00FF00, $0000FF, 0); + + //Success := WriteJPGImage(FileName, Surface, 95); + //Success := WriteBMPImage(FileName, Surface); + Success := WritePNGImage(FileName, Surface); + if Success then + ScreenPopupError.ShowPopup('Screenshot saved: ' + ExtractFileName(FileName)) + else + ScreenPopupError.ShowPopup('Screenshot failed'); - // prepare header memory - ZeroMemory(@FileHeader, SizeOf(BITMAPFILEHEADER)); - ZeroMemory(@FileInfo , SizeOf(BITMAPINFOHEADER)); - - // initialize header-data - FileHeader.bfType := 19778; // $4D42 = 'BM' - FileHeader.bfOffBits := SizeOf(BITMAPINFOHEADER)+SizeOf(BITMAPFILEHEADER); - - // write bitmap info - FileInfo.biSize := SizeOf(BITMAPINFOHEADER); - FileInfo.biWidth := ScreenW; - FileInfo.biHeight := ScreenH; - FileInfo.biPlanes := 1; - FileInfo.biBitCount := 32; - FileInfo.biSizeImage := FileInfo.biWidth*FileInfo.biHeight*(FileInfo.biBitCount div 8); - - // copy size-info to header - FileHeader.bfSize := FileHeader.bfOffBits + FileInfo.biSizeImage; - - // reserve memory for image-data - GetMem(pPicData, FileInfo.biSizeImage); - try - // retrieve image-data from OpenGL (see above) - glReadPixels(0, 0, ScreenW, ScreenH, GL_BGRA, GL_UNSIGNED_BYTE, pPicData); - - // and move the whole stuff into the file ;-) - // up-to-date guys use streams for this purpose ... - AssignFile(f, Filename); - Rewrite( f,1 ); - try - BlockWrite(F, FileHeader, SizeOf(BITMAPFILEHEADER)); - BlockWrite(F, FileInfo, SizeOf(BITMAPINFOHEADER)); - BlockWrite(F, pPicData^, FileInfo.biSizeImage ); - finally - CloseFile(f); - end; - finally - // free allocated data ... - FreeMem(pPicData, FileInfo.biSizeImage); - end; -} + SDL_FreeSurface(Surface); + FreeMem(ScreenData); end; //------------ diff --git a/Game/Code/Screens/UScreenScore.pas b/Game/Code/Screens/UScreenScore.pas index 3ce60b2b..9a13681b 100644 --- a/Game/Code/Screens/UScreenScore.pas +++ b/Game/Code/Screens/UScreenScore.pas @@ -175,7 +175,7 @@ begin end; SDLK_SYSREQ: begin - Display.PrintScreen; + Display.SaveScreenShot; end; end; end; @@ -619,6 +619,7 @@ begin end; // end todo + {{$IFDEF TRANSLATE} case (Player[PlayerNumber-1].ScoreTotalI) of 0..2000: begin @@ -656,6 +657,17 @@ begin Rating := 6; end; end; + {{$ELSE}{ + case (Player[PlayerNumber-1].ScoreTotalI) of + 0..2000: Text[TextScore[fu]].Text := 'Tone Deaf'; + 2010..4000: Text[TextScore[fu]].Text := 'Amateur'; + 4010..6000: Text[TextScore[fu]].Text := 'Rising Star'; + 6010..8000: Text[TextScore[fu]].Text := 'Lead Singer'; + 8010..9000: Text[TextScore[fu]].Text := 'Hit Artist'; + 9010..9800: Text[TextScore[fu]].Text := 'Superstar'; + 9810..10000: Text[TextScore[fu]].Text := 'Ultrastar'; + end; + {$ENDIF} // Bounce the rating picture in PosX := aPlayerScoreScreenRatings[PlayerNumber].RatePic_X + (aPlayerScoreScreenRatings[PlayerNumber].RatePic_Width / 2); diff --git a/Game/Code/Screens/UScreenTop5.pas b/Game/Code/Screens/UScreenTop5.pas index 4b3356dc..2a673880 100644 --- a/Game/Code/Screens/UScreenTop5.pas +++ b/Game/Code/Screens/UScreenTop5.pas @@ -59,7 +59,7 @@ begin end; SDLK_SYSREQ: begin - Display.PrintScreen; + Display.SaveScreenShot; end; end; end; diff --git a/Game/Code/UltraStar.dpr b/Game/Code/UltraStar.dpr index 5f1ba7e1..9dd65fc8 100644 --- a/Game/Code/UltraStar.dpr +++ b/Game/Code/UltraStar.dpr @@ -25,6 +25,9 @@ uses sdl_ttf in 'lib\JEDI-SDL\SDL_ttf\Pas\sdl_ttf.pas', sdlutils in 'lib\JEDI-SDL\SDL\Pas\sdlutils.pas', + zlib in 'lib\zlib\zlib.pas', + png in 'lib\libpng\png.pas', + {$IFDEF UseBass} bass in 'lib\bass\delphi\bass.pas', UAudioCore_Bass in 'Classes\UAudioCore_Bass.pas', @@ -109,6 +112,7 @@ uses UXMLSong in 'Classes\UXMLSong.pas', USongs in 'Classes\USongs.pas', UIni in 'Classes\UIni.pas', + UImage in 'Classes\UImage.pas', ULyrics in 'Classes\ULyrics.pas', ULyrics_bak in 'Classes\ULyrics_bak.pas', USkins in 'Classes\USkins.pas', diff --git a/Game/Code/lib/PngImage/Tpngimage.DPK b/Game/Code/lib/PngImage/Tpngimage.DPK deleted file mode 100644 index b9c395f4..00000000 --- a/Game/Code/lib/PngImage/Tpngimage.DPK +++ /dev/null @@ -1,34 +0,0 @@ -package Tpngimage; - -{$R *.res} -{$ALIGN 8} -{$ASSERTIONS ON} -{$BOOLEVAL OFF} -{$DEBUGINFO ON} -{$EXTENDEDSYNTAX ON} -{$IMPORTEDDATA ON} -{$IOCHECKS ON} -{$LOCALSYMBOLS ON} -{$LONGSTRINGS ON} -{$OPENSTRINGS ON} -{$OPTIMIZATION ON} -{$OVERFLOWCHECKS OFF} -{$RANGECHECKS OFF} -{$REFERENCEINFO ON} -{$SAFEDIVIDE OFF} -{$STACKFRAMES OFF} -{$TYPEDADDRESS OFF} -{$VARSTRINGCHECKS ON} -{$WRITEABLECONST OFF} -{$MINENUMSIZE 1} -{$IMAGEBASE $400000} -{$IMPLICITBUILD OFF} - -requires - rtl, - vcl; - -contains - pngimage in 'pngimage.pas'; - -end. diff --git a/Game/Code/lib/PngImage/Tpngimage.bdsproj b/Game/Code/lib/PngImage/Tpngimage.bdsproj deleted file mode 100644 index b7a30970..00000000 --- a/Game/Code/lib/PngImage/Tpngimage.bdsproj +++ /dev/null @@ -1,177 +0,0 @@ - - - - - - - - - - - - Tpngimage.DPK - - - 7.0 - - - 8 - 0 - 1 - 1 - 0 - 0 - 1 - 1 - 1 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - 0 - 0 - 0 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - True - True - WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; - - False - - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - False - False - False - True - True - True True - True - - - - 3 - 0 - 1 - False - False - False - 16384 - 1048576 - 4194304 - False - - - - - - - - - - - False - - - - - - False - - - - - - False - True - False - - - - $00000000 - C:\Program Files\Borland\Delphi7\Bin\ - - - True - False - 1 - 0 - 0 - 0 - False - False - False - False - False - 1033 - 1252 - - - - - 1.0.0.0 - - - - - - 1.0.0.0 - - - - diff --git a/Game/Code/lib/PngImage/Tpngimage.bdsproj.local b/Game/Code/lib/PngImage/Tpngimage.bdsproj.local deleted file mode 100644 index d576f039..00000000 --- a/Game/Code/lib/PngImage/Tpngimage.bdsproj.local +++ /dev/null @@ -1,2 +0,0 @@ - - diff --git a/Game/Code/lib/PngImage/Tpngimage.cfg b/Game/Code/lib/PngImage/Tpngimage.cfg deleted file mode 100644 index 4a78a005..00000000 --- a/Game/Code/lib/PngImage/Tpngimage.cfg +++ /dev/null @@ -1,40 +0,0 @@ --$A8 --$B- --$C+ --$D+ --$E- --$F- --$G+ --$H+ --$I+ --$J- --$K- --$L+ --$M- --$N+ --$O+ --$P+ --$Q- --$R- --$S- --$T- --$U- --$V+ --$W- --$X+ --$YD --$Z1 --GD --cg --AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; --H+ --W+ --M --$M16384,1048576 --K$00400000 --LE"C:\Documents and Settings\Jay Binks\My Documents\Borland Studio Projects\Bpl" --LN"C:\Documents and Settings\Jay Binks\My Documents\Borland Studio Projects\Bpl" --Z --w-UNSAFE_TYPE --w-UNSAFE_CODE --w-UNSAFE_CAST diff --git a/Game/Code/lib/PngImage/Tpngimage.dof b/Game/Code/lib/PngImage/Tpngimage.dof deleted file mode 100644 index 45e43c01..00000000 --- a/Game/Code/lib/PngImage/Tpngimage.dof +++ /dev/null @@ -1,136 +0,0 @@ -[FileVersion] -Version=7.0 -[Compiler] -A=8 -B=0 -C=1 -D=1 -E=0 -F=0 -G=1 -H=1 -I=1 -J=0 -K=0 -L=1 -M=0 -N=1 -O=1 -P=1 -Q=0 -R=0 -S=0 -T=0 -U=0 -V=1 -W=0 -X=1 -Y=1 -Z=1 -ShowHints=1 -ShowWarnings=1 -UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; -NamespacePrefix= -SymbolDeprecated=1 -SymbolLibrary=1 -SymbolPlatform=1 -UnitLibrary=1 -UnitPlatform=1 -UnitDeprecated=1 -HResultCompat=1 -HidingMember=1 -HiddenVirtual=1 -Garbage=1 -BoundsError=1 -ZeroNilCompat=1 -StringConstTruncated=1 -ForLoopVarVarPar=1 -TypedConstVarPar=1 -AsgToTypedConst=1 -CaseLabelRange=1 -ForVariable=1 -ConstructingAbstract=1 -ComparisonFalse=1 -ComparisonTrue=1 -ComparingSignedUnsigned=1 -CombiningSignedUnsigned=1 -UnsupportedConstruct=1 -FileOpen=1 -FileOpenUnitSrc=1 -BadGlobalSymbol=1 -DuplicateConstructorDestructor=1 -InvalidDirective=1 -PackageNoLink=1 -PackageThreadVar=1 -ImplicitImport=1 -HPPEMITIgnored=1 -NoRetVal=1 -UseBeforeDef=1 -ForLoopVarUndef=1 -UnitNameMismatch=1 -NoCFGFileFound=1 -MessageDirective=1 -ImplicitVariants=1 -UnicodeToLocale=1 -LocaleToUnicode=1 -ImagebaseMultiple=1 -SuspiciousTypecast=1 -PrivatePropAccessor=1 -UnsafeType=0 -UnsafeCode=0 -UnsafeCast=0 -[Linker] -MapFile=0 -OutputObjs=0 -ConsoleApp=1 -DebugInfo=0 -RemoteSymbols=0 -MinStackSize=16384 -MaxStackSize=1048576 -ImageBase=4194304 -ExeDescription= -[Directories] -OutputDir= -UnitOutputDir= -PackageDLLOutputDir= -PackageDCPOutputDir= -SearchPath= -Packages=vcl;rtl;vclx;VclSmp;vclshlctrls;VirtualTreesD7;Tpngimage;THTTPGet;XmlComponents_D6;EmbWb;TINetDetector;FolderDialog;Indy70;madBasic_;madHelp_;madDisAsm_;madExcept_;madRemote_;madKernel_;madCodeHook_;madSecurity_;madShell_;TRegs32;Progress;TTRAYICON;TXPPanel;DelphiX_for5 -Conditionals= -DebugSourceDirs= -UsePackages=0 -[Parameters] -RunParams= -HostApplication= -Launcher= -UseLauncher=0 -DebugCWD= -[Language] -ActiveLang= -ProjectLang= -RootDir=C:\Program Files\Borland\Delphi7\Bin\ -[Version Info] -IncludeVerInfo=1 -AutoIncBuild=0 -MajorVer=1 -MinorVer=0 -Release=0 -Build=0 -Debug=0 -PreRelease=0 -Special=0 -Private=0 -DLL=0 -Locale=1033 -CodePage=1252 -[Version Info Keys] -CompanyName= -FileDescription= -FileVersion=1.0.0.0 -InternalName= -LegalCopyright= -LegalTrademarks= -OriginalFilename= -ProductName= -ProductVersion=1.0.0.0 -Comments= diff --git a/Game/Code/lib/PngImage/Tpngimage.drc b/Game/Code/lib/PngImage/Tpngimage.drc deleted file mode 100644 index 52d3a522..00000000 --- a/Game/Code/lib/PngImage/Tpngimage.drc +++ /dev/null @@ -1,62 +0,0 @@ -/* VER180 - Generated by the Borland Delphi Pascal Compiler - because -GD or --drc was supplied to the compiler. - - This file contains compiler-generated resources that - were bound to the executable. - If this file is empty, then no compiler-generated - resources were bound to the produced executable. -*/ - -#define pnglang_EPNGNoImageDataText 65504 -#define pnglang_EPNGCannotChangeSizeText 65505 -#define pnglang_EPNGCannotAddChunkText 65506 -#define pnglang_EPNGCannotAddInvalidImageText 65507 -#define pnglang_EPNGCouldNotLoadResourceText 65508 -#define pnglang_EPNGOutMemoryText 65509 -#define pnglang_EPNGCannotChangeTransparentText 65510 -#define pnglang_EPNGHeaderNotPresentText 65511 -#define pnglang_EPngInvalidCRCText 65520 -#define pnglang_EPNGInvalidIHDRText 65521 -#define pnglang_EPNGMissingMultipleIDATText 65522 -#define pnglang_EPNGZLIBErrorText 65523 -#define pnglang_EPNGInvalidPaletteText 65524 -#define pnglang_EPNGInvalidFileHeaderText 65525 -#define pnglang_EPNGIHDRNotFirstText 65526 -#define pnglang_EPNGNotExistsText 65527 -#define pnglang_EPNGSizeExceedsText 65528 -#define pnglang_EPNGUnknownPalEntryText 65529 -#define pnglang_EPNGMissingPaletteText 65530 -#define pnglang_EPNGUnknownCriticalChunkText 65531 -#define pnglang_EPNGUnknownCompressionText 65532 -#define pnglang_EPNGUnknownInterlaceText 65533 -#define pnglang_EPNGCannotAssignChunkText 65534 -#define pnglang_EPNGUnexpectedEndText 65535 -STRINGTABLE -BEGIN - pnglang_EPNGNoImageDataText, "This \"Portable Network Graphics\" image contains no data." - pnglang_EPNGCannotChangeSizeText, "The \"Portable Network Graphics\" image can not be resize by changing width and height properties. Try assigning the image from a bitmap." - pnglang_EPNGCannotAddChunkText, "The program tried to add a existent critical chunk to the current image which is not allowed." - pnglang_EPNGCannotAddInvalidImageText, "It's not allowed to add a new chunk because the current image is invalid." - pnglang_EPNGCouldNotLoadResourceText, "The png image could not be loaded from the resource ID." - pnglang_EPNGOutMemoryText, "Some operation could not be performed because the system is out of resources. Close some windows and try again." - pnglang_EPNGCannotChangeTransparentText, "Setting bit transparency color is not allowed for png images containing alpha value for each pixel (COLOR_RGBALPHA and COLOR_GRAYSCALEALPHA)" - pnglang_EPNGHeaderNotPresentText, "This operation is not valid because the current image contains no valid header." - pnglang_EPngInvalidCRCText, "This \"Portable Network Graphics\" image is not valid because it contains invalid pieces of data (crc error)" - pnglang_EPNGInvalidIHDRText, "The \"Portable Network Graphics\" image could not be loaded because one of its main piece of data (ihdr) might be corrupted" - pnglang_EPNGMissingMultipleIDATText, "This \"Portable Network Graphics\" image is invalid because it has missing image parts." - pnglang_EPNGZLIBErrorText, "Could not decompress the image because it contains invalid compressed data.\r\n Description: " - pnglang_EPNGInvalidPaletteText, "The \"Portable Network Graphics\" image contains an invalid palette." - pnglang_EPNGInvalidFileHeaderText, "The file being readed is not a valid \"Portable Network Graphics\" image because it contains an invalid header. This file may be corruped, try obtaining it again." - pnglang_EPNGIHDRNotFirstText, "This \"Portable Network Graphics\" image is not supported or it might be invalid.\r\n(IHDR chunk is not the first)" - pnglang_EPNGNotExistsText, "The png file could not be loaded because it does not exists." - pnglang_EPNGSizeExceedsText, "This \"Portable Network Graphics\" image is not supported because either it's width or height exceeds the maximum size, which is 65535 pixels length." - pnglang_EPNGUnknownPalEntryText, "There is no such palette entry." - pnglang_EPNGMissingPaletteText, "This \"Portable Network Graphics\" could not be loaded because it uses a color table which is missing." - pnglang_EPNGUnknownCriticalChunkText, "This \"Portable Network Graphics\" image contains an unknown critical part which could not be decoded." - pnglang_EPNGUnknownCompressionText, "This \"Portable Network Graphics\" image is encoded with an unknown compression scheme which could not be decoded." - pnglang_EPNGUnknownInterlaceText, "This \"Portable Network Graphics\" image uses an unknown interlace scheme which could not be decoded." - pnglang_EPNGCannotAssignChunkText, "The chunks must be compatible to be assigned." - pnglang_EPNGUnexpectedEndText, "This \"Portable Network Graphics\" image is invalid because the decoder found an unexpected end of the file." -END - diff --git a/Game/Code/lib/PngImage/Tpngimage.res b/Game/Code/lib/PngImage/Tpngimage.res deleted file mode 100644 index aac9aa64..00000000 Binary files a/Game/Code/lib/PngImage/Tpngimage.res and /dev/null differ diff --git a/Game/Code/lib/PngImage/Tpngimage.stat b/Game/Code/lib/PngImage/Tpngimage.stat deleted file mode 100644 index 57f32789..00000000 --- a/Game/Code/lib/PngImage/Tpngimage.stat +++ /dev/null @@ -1,10 +0,0 @@ -[Stats] -EditorSecs=3 -DesignerSecs=1 -InspectorSecs=1 -CompileSecs=1542 -OtherSecs=11 -StartTime=5/6/2004 7:36:05 PM -RealKeys=0 -EffectiveKeys=0 -DebugSecs=1 diff --git a/Game/Code/lib/PngImage/lazarustest.lpi b/Game/Code/lib/PngImage/lazarustest.lpi deleted file mode 100644 index 4dec8a9e..00000000 --- a/Game/Code/lib/PngImage/lazarustest.lpi +++ /dev/null @@ -1,239 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/Game/Code/lib/PngImage/lazarustest.lpr b/Game/Code/lib/PngImage/lazarustest.lpr deleted file mode 100644 index f567b6cb..00000000 --- a/Game/Code/lib/PngImage/lazarustest.lpr +++ /dev/null @@ -1,15 +0,0 @@ -program lazarustest; - -uses - pngimage in 'pngimage.pas', - pnglang in 'pnglang.pas', - pngzlib in 'pngzlib.pas', - sysutils; - -begin - writeln( 'pngimage is NOT lazarus compatible' ); - writeln( 'It might compile ( not link though ), however the object files are in borland obj format' ); - writeln( 'to use this, it will need to be in GCC object file format format' ); - writeln( 'Or we can use the lazarus / freepascal png unit' ); -end. - diff --git a/Game/Code/lib/PngImage/obj/adler32.obj b/Game/Code/lib/PngImage/obj/adler32.obj deleted file mode 100644 index 7da9fd19..00000000 Binary files a/Game/Code/lib/PngImage/obj/adler32.obj and /dev/null differ diff --git a/Game/Code/lib/PngImage/obj/deflate.obj b/Game/Code/lib/PngImage/obj/deflate.obj deleted file mode 100644 index 804e9334..00000000 Binary files a/Game/Code/lib/PngImage/obj/deflate.obj and /dev/null differ diff --git a/Game/Code/lib/PngImage/obj/infblock.obj b/Game/Code/lib/PngImage/obj/infblock.obj deleted file mode 100644 index 3bc38e41..00000000 Binary files a/Game/Code/lib/PngImage/obj/infblock.obj and /dev/null differ diff --git a/Game/Code/lib/PngImage/obj/infcodes.obj b/Game/Code/lib/PngImage/obj/infcodes.obj deleted file mode 100644 index faec2222..00000000 Binary files a/Game/Code/lib/PngImage/obj/infcodes.obj and /dev/null differ diff --git a/Game/Code/lib/PngImage/obj/inffast.obj b/Game/Code/lib/PngImage/obj/inffast.obj deleted file mode 100644 index 62e18ceb..00000000 Binary files a/Game/Code/lib/PngImage/obj/inffast.obj and /dev/null differ diff --git a/Game/Code/lib/PngImage/obj/inflate.obj b/Game/Code/lib/PngImage/obj/inflate.obj deleted file mode 100644 index 7dc522e0..00000000 Binary files a/Game/Code/lib/PngImage/obj/inflate.obj and /dev/null differ diff --git a/Game/Code/lib/PngImage/obj/inftrees.obj b/Game/Code/lib/PngImage/obj/inftrees.obj deleted file mode 100644 index 5755233f..00000000 Binary files a/Game/Code/lib/PngImage/obj/inftrees.obj and /dev/null differ diff --git a/Game/Code/lib/PngImage/obj/infutil.obj b/Game/Code/lib/PngImage/obj/infutil.obj deleted file mode 100644 index 7e175a83..00000000 Binary files a/Game/Code/lib/PngImage/obj/infutil.obj and /dev/null differ diff --git a/Game/Code/lib/PngImage/obj/trees.obj b/Game/Code/lib/PngImage/obj/trees.obj deleted file mode 100644 index 81f05568..00000000 Binary files a/Game/Code/lib/PngImage/obj/trees.obj and /dev/null differ diff --git a/Game/Code/lib/PngImage/pngimage.chm b/Game/Code/lib/PngImage/pngimage.chm deleted file mode 100644 index c7e51b2e..00000000 Binary files a/Game/Code/lib/PngImage/pngimage.chm and /dev/null differ diff --git a/Game/Code/lib/PngImage/pngimage.pas b/Game/Code/lib/PngImage/pngimage.pas deleted file mode 100644 index ecd52c5b..00000000 --- a/Game/Code/lib/PngImage/pngimage.pas +++ /dev/null @@ -1,5213 +0,0 @@ -{Portable Network Graphics Delphi 1.4361 (8 March 2003) } - -{This is the latest implementation for TPngImage component } -{It's meant to be a full replacement for the previous one. } -{There are lots of new improvements, including cleaner code, } -{full partial transparency support, speed improvements, } -{saving using ADAM 7 interlacing, better error handling, also } -{the best compression for the final image ever. And now it's } -{truly able to read about any png image. } - -{ - Version 1.4361 - 2003-03-04 - Fixed important bug for simple transparency when using - RGB, Grayscale color modes - - Version 1.436 - 2003-03-04 - * NEW * Property Pixels for direct access to pixels - * IMPROVED * Palette property (TPngObject) (read only) - Slovenian traslation for the component (Miha Petelin) - Help file update (scanline article/png->jpg example) - - Version 1.435 - 2003-11-03 - * NEW * New chunk implementation zTXt (method AddzTXt) - * NEW * New compiler flags to store the extra 8 bits - from 16 bits samples (when saving it is ignored), the - extra data may be acessed using ExtraScanline property - * Fixed * a bug on tIMe chunk - French translation included (Thanks to IBE Software) - Bugs fixed - - Version 1.432 - 2002-08-24 - * NEW * A new method, CreateAlpha will transform the - current image into partial transparency. - Help file updated with a new article on how to handle - partial transparency. - - Version 1.431 - 2002-08-14 - Fixed and tested to work on: - C++ Builder 3 - C++ Builder 5 - Delphi 3 - There was an error when setting TransparentColor, fixed - New method, RemoveTransparency to remove image - BIT TRANSPARENCY - - Version 1.43 - 2002-08-01 - * NEW * Support for Delphi 3 and C++ Builder 3 - Implements mostly some things that were missing, - a few tweaks and fixes. - - Version 1.428 - 2002-07-24 - More minor fixes (thanks to Ian Boyd) - Bit transparency fixes - * NEW * Finally support to bit transparency - (palette / rgb / grayscale -> all) - - Version 1.427 - 2002-07-19 - Lots of bugs and leaks fixed - * NEW * method to easy adding text comments, AddtEXt - * NEW * property for setting bit transparency, - TransparentColor - - Version 1.426 - 2002-07-18 - Clipboard finally fixed (hope) - Changed UseDelphi trigger to UseDelphi - * NEW * Support for bit transparency bitmaps - when assigning from/to TBitmap objects - Altough it does not support drawing transparent - parts of bit transparency pngs (only partial) - it is closer than ever - - Version 1.425 - 2002-07-01 - Clipboard methods implemented - Lots of bugs fixed - - Version 1.424 - 2002-05-16 - Scanline and AlphaScanline are now working correctly. - New methods for handling the clipboard - - Version 1.423 - 2002-05-16 - * NEW * Partial transparency for 1, 2, 4 and 8 bits is - also supported using the tRNS chunk (for palette and - grayscaling). - New bug fixes (Peter Haas). - - Version 1.422 - 2002-05-14 - Fixed some critical leaks, thanks to Peter Haas tips. - New translation for German (Peter Haas). - - Version 1.421 - 2002-05-06 - Now uses new ZLIB version, 1.1.4 with some security - fixes. - LoadFromResourceID and LoadFromResourceName added and - help file updated for that. - The resources strings are now located in pnglang.pas. - New translation for Brazilian Portuguese. - Bugs fixed. - - IMPORTANT: I'm currently looking for bugs on the library. If - anyone has found one, please send me an email and - I will fix right away. Thanks for all the help and - ideias I'm receiving so far.} - -{My new email is: gubadaud@terra.com.br} -{Website link : pngdelphi.sourceforge.net} -{Gustavo Huffenbacher Daud} - -unit pngimage; - -interface - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} - -{Triggers avaliable (edit the fields bellow)} -{$IFNDef FPC} -{$DEFINE UseDelphi} //Disable fat vcl units (perfect to small apps) -{$ENDIF} - -{$DEFINE ErrorOnUnknownCritical} //Error when finds an unknown critical chunk -{$DEFINE CheckCRC} //Enables CRC checking -{$DEFINE RegisterGraphic} //Registers TPNGObject to use with TPicture -{$DEFINE PartialTransparentDraw} //Draws partial transparent images -{.$DEFINE Store16bits} //Stores the extra 8 bits from 16bits/sample -{.$DEFINE Debug} //For programming purposes -{$RANGECHECKS OFF} {$J+} - - - -uses - Windows, - {$IFDEF UseDelphi} - Classes, - Graphics, - SysUtils, - {$ENDIF} - {$IFDEF Debug} - dialogs, - {$ENDIF} - pngzlib, - pnglang; - -{$IFNDEF UseDelphi} - const - soFromBeginning = 0; - soFromCurrent = 1; - soFromEnd = 2; -{$ENDIF} - -const - {ZLIB constants} - ZLIBErrors: Array[-6..2] of string = ('incompatible version (-6)', - 'buffer error (-5)', 'insufficient memory (-4)', 'data error (-3)', - 'stream error (-2)', 'file error (-1)', '(0)', 'stream end (1)', - 'need dictionary (2)'); - Z_NO_FLUSH = 0; - Z_FINISH = 4; - Z_STREAM_END = 1; - - {Avaliable PNG filters for mode 0} - FILTER_NONE = 0; - FILTER_SUB = 1; - FILTER_UP = 2; - FILTER_AVERAGE = 3; - FILTER_PAETH = 4; - - {Avaliable color modes for PNG} - COLOR_GRAYSCALE = 0; - COLOR_RGB = 2; - COLOR_PALETTE = 3; - COLOR_GRAYSCALEALPHA = 4; - COLOR_RGBALPHA = 6; - - -type - {$IFNDEF UseDelphi} - {Custom exception handler} - Exception = class(TObject) - constructor Create(Msg: String); - end; - ExceptClass = class of Exception; - TColor = ColorRef; - {$ENDIF} - - {Error types} - EPNGOutMemory = class(Exception); - EPngError = class(Exception); - EPngUnexpectedEnd = class(Exception); - EPngInvalidCRC = class(Exception); - EPngInvalidIHDR = class(Exception); - EPNGMissingMultipleIDAT = class(Exception); - EPNGZLIBError = class(Exception); - EPNGInvalidPalette = class(Exception); - EPNGInvalidFileHeader = class(Exception); - EPNGIHDRNotFirst = class(Exception); - EPNGNotExists = class(Exception); - EPNGSizeExceeds = class(Exception); - EPNGMissingPalette = class(Exception); - EPNGUnknownCriticalChunk = class(Exception); - EPNGUnknownCompression = class(Exception); - EPNGUnknownInterlace = class(Exception); - EPNGNoImageData = class(Exception); - EPNGCouldNotLoadResource = class(Exception); - EPNGCannotChangeTransparent = class(Exception); - EPNGHeaderNotPresent = class(Exception); - -type - {Direct access to pixels using R,G,B} - TRGBLine = array[word] of TRGBTriple; - pRGBLine = ^TRGBLine; - - {Same as TBitmapInfo but with allocated space for} - {palette entries} - TMAXBITMAPINFO = packed record - bmiHeader: TBitmapInfoHeader; - bmiColors: packed array[0..255] of TRGBQuad; - end; - - {Transparency mode for pngs} - TPNGTransparencyMode = (ptmNone, ptmBit, ptmPartial); - {Pointer to a cardinal type} - pCardinal = ^Cardinal; - {Access to a rgb pixel} - pRGBPixel = ^TRGBPixel; - TRGBPixel = packed record - B, G, R: Byte; - end; - - {Pointer to an array of bytes type} - TByteArray = Array[Word] of Byte; - pByteArray = ^TByteArray; - - {Forward} - TPNGObject = class; - pPointerArray = ^TPointerArray; - TPointerArray = Array[Word] of Pointer; - - {Contains a list of objects} - TPNGPointerList = class - private - fOwner: TPNGObject; - fCount : Cardinal; - fMemory: pPointerArray; - function GetItem(Index: Cardinal): Pointer; - procedure SetItem(Index: Cardinal; const Value: Pointer); - protected - {Removes an item} - function Remove(Value: Pointer): Pointer; virtual; - {Inserts an item} - procedure Insert(Value: Pointer; Position: Cardinal); - {Add a new item} - procedure Add(Value: Pointer); - {Returns an item} - property Item[Index: Cardinal]: Pointer read GetItem write SetItem; - {Set the size of the list} - procedure SetSize(const Size: Cardinal); - {Returns owner} - property Owner: TPNGObject read fOwner; - public - {Returns number of items} - property Count: Cardinal read fCount write SetSize; - {Object being either created or destroyed} - constructor Create(AOwner: TPNGObject); - destructor Destroy; override; - end; - - {Forward declaration} - TChunk = class; - TChunkClass = class of TChunk; - - {Same as TPNGPointerList but providing typecasted values} - TPNGList = class(TPNGPointerList) - private - {Used with property Item} - function GetItem(Index: Cardinal): TChunk; - public - {Removes an item} - procedure RemoveChunk(Chunk: TChunk); overload; - {Add a new chunk using the class from the parameter} - function Add(ChunkClass: TChunkClass): TChunk; - {Returns pointer to the first chunk of class} - function ItemFromClass(ChunkClass: TChunkClass): TChunk; - {Returns a chunk item from the list} - property Item[Index: Cardinal]: TChunk read GetItem; - end; - - {$IFNDEF UseDelphi} - {The STREAMs bellow are only needed in case delphi provided ones is not} - {avaliable (UseDelphi trigger not set)} - {Object becomes handles} - TCanvas = THandle; - TBitmap = HBitmap; - {Trick to work} - TPersistent = TObject; - - {Base class for all streams} - TStream = class - protected - {Returning/setting size} - function GetSize: Longint; virtual; - procedure SetSize(const Value: Longint); virtual; abstract; - {Returns/set position} - function GetPosition: Longint; virtual; - procedure SetPosition(const Value: Longint); virtual; - public - {Returns/sets current position} - property Position: Longint read GetPosition write SetPosition; - {Property returns/sets size} - property Size: Longint read GetSize write SetSize; - {Allows reading/writing data} - function Read(var Buffer; Count: Longint): Cardinal; virtual; abstract; - function Write(const Buffer; Count: Longint): Cardinal; virtual; abstract; - {Copies from another Stream} - function CopyFrom(Source: TStream; - Count: Cardinal): Cardinal; virtual; - {Seeks a stream position} - function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract; - end; - - {File stream modes} - TFileStreamMode = (fsmRead, fsmWrite, fsmCreate); - TFileStreamModeSet = set of TFileStreamMode; - - {File stream for reading from files} - TFileStream = class(TStream) - private - {Opened mode} - Filemode: TFileStreamModeSet; - {Handle} - fHandle: THandle; - protected - {Set the size of the file} - procedure SetSize(const Value: Longint); override; - public - {Seeks a file position} - function Seek(Offset: Longint; Origin: Word): Longint; override; - {Reads/writes data from/to the file} - function Read(var Buffer; Count: Longint): Cardinal; override; - function Write(const Buffer; Count: Longint): Cardinal; override; - {Stream being created and destroy} - constructor Create(Filename: String; Mode: TFileStreamModeSet); - destructor Destroy; override; - end; - - {Stream for reading from resources} - TResourceStream = class(TStream) - constructor Create(Instance: HInst; const ResName: String; ResType:PChar); - private - {Variables for reading} - Size: Integer; - Memory: Pointer; - Position: Integer; - protected - {Set the size of the file} - procedure SetSize(const Value: Longint); override; - public - {Stream processing} - function Read(var Buffer; Count: Integer): Cardinal; override; - function Seek(Offset: Integer; Origin: Word): Longint; override; - function Write(const Buffer; Count: Longint): Cardinal; override; - end; - {$ENDIF} - - {Forward} - TChunkIHDR = class; - {Interlace method} - TInterlaceMethod = (imNone, imAdam7); - {Compression level type} - TCompressionLevel = 0..9; - {Filters type} - TFilter = (pfNone, pfSub, pfUp, pfAverage, pfPaeth); - TFilters = set of TFilter; - - {Png implementation object} - TPngObject = class{$IFDEF UseDelphi}(TGraphic){$ENDIF} - protected - {Gamma table values} - GammaTable, InverseGamma: Array[Byte] of Byte; - procedure InitializeGamma; - private - {Temporary palette} - TempPalette: HPalette; - {Filters to test to encode} - fFilters: TFilters; - {Compression level for ZLIB} - fCompressionLevel: TCompressionLevel; - {Maximum size for IDAT chunks} - fMaxIdatSize: Cardinal; - {Returns if image is interlaced} - fInterlaceMethod: TInterlaceMethod; - {Chunks object} - fChunkList: TPngList; - {Clear all chunks in the list} - procedure ClearChunks; - {Returns if header is present} - function HeaderPresent: Boolean; - {Returns linesize and byte offset for pixels} - procedure GetPixelInfo(var LineSize, Offset: Cardinal); - procedure SetMaxIdatSize(const Value: Cardinal); - function GetAlphaScanline(const LineIndex: Integer): pByteArray; - function GetScanline(const LineIndex: Integer): Pointer; - {$IFDEF Store16bits} - function GetExtraScanline(const LineIndex: Integer): Pointer; - {$ENDIF} - function GetTransparencyMode: TPNGTransparencyMode; - function GetTransparentColor: TColor; - procedure SetTransparentColor(const Value: TColor); - protected - {Returns the image palette} - function GetPalette: HPALETTE; {$IFDEF UseDelphi}override;{$ENDIF} - {Returns/sets image width and height} - function GetWidth: Integer; {$IFDEF UseDelphi}override;{$ENDIF} - function GetHeight: Integer; {$IFDEF UseDelphi}override; {$ENDIF} - procedure SetWidth(Value: Integer); {$IFDEF UseDelphi}override; {$ENDIF} - procedure SetHeight(Value: Integer); {$IFDEF UseDelphi}override;{$ENDIF} - {Assigns from another TPNGObject} - procedure AssignPNG(Source: TPNGObject); - {Returns if the image is empty} - function GetEmpty: Boolean; {$IFDEF UseDelphi}override; {$ENDIF} - {Used with property Header} - function GetHeader: TChunkIHDR; - {Draws using partial transparency} - procedure DrawPartialTrans(DC: HDC; Rect: TRect); - {$IFDEF UseDelphi} - {Returns if the image is transparent} - function GetTransparent: Boolean; override; - {$ENDIF} - {Returns a pixel} - function GetPixels(const X, Y: Integer): TColor; virtual; - procedure SetPixels(const X, Y: Integer; const Value: TColor); virtual; - public - {Generates alpha information} - procedure CreateAlpha; - {Removes the image transparency} - procedure RemoveTransparency; - {Transparent color} - property TransparentColor: TColor read GetTransparentColor write - SetTransparentColor; - {Add text chunk, TChunkTEXT, TChunkzTXT} - procedure AddtEXt(const Keyword, Text: String); - procedure AddzTXt(const Keyword, Text: String); - {$IFDEF UseDelphi} - {Saves to clipboard format (thanks to Antoine Pottern)} - procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; - var APalette: HPalette); override; - procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; - APalette: HPalette); override; - {$ENDIF} - {Calling errors} - procedure RaiseError(ExceptionClass: ExceptClass; Text: String); - {Returns a scanline from png} - property Scanline[const Index: Integer]: Pointer read GetScanline; - {$IFDEF Store16bits} - property ExtraScanline[const Index: Integer]: Pointer read GetExtraScanline; - {$ENDIF} - property AlphaScanline[const Index: Integer]: pByteArray read GetAlphaScanline; - {Returns pointer to the header} - property Header: TChunkIHDR read GetHeader; - {Returns the transparency mode used by this png} - property TransparencyMode: TPNGTransparencyMode read GetTransparencyMode; - {Assigns from another object} - procedure Assign(Source: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF} - {Assigns to another object} - procedure AssignTo(Dest: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF} - {Assigns from a windows bitmap handle} - procedure AssignHandle(Handle: HBitmap; Transparent: Boolean; - TransparentColor: ColorRef); - {Draws the image into a canvas} - procedure Draw(ACanvas: TCanvas; const Rect: TRect); - {$IFDEF UseDelphi}override;{$ENDIF} - {Width and height properties} - property Width: Integer read GetWidth; - property Height: Integer read GetHeight; - {Returns if the image is interlaced} - property InterlaceMethod: TInterlaceMethod read fInterlaceMethod - write fInterlaceMethod; - {Filters to test to encode} - property Filters: TFilters read fFilters write fFilters; - {Maximum size for IDAT chunks, default and minimum is 65536} - property MaxIdatSize: Cardinal read fMaxIdatSize write SetMaxIdatSize; - {Property to return if the image is empty or not} - property Empty: Boolean read GetEmpty; - {Compression level} - property CompressionLevel: TCompressionLevel read fCompressionLevel - write fCompressionLevel; - {Access to the chunk list} - property Chunks: TPngList read fChunkList; - {Object being created and destroyed} - constructor Create; {$IFDEF UseDelphi}override;{$ENDIF} - destructor Destroy; override; - {$IFNDEF UseDelphi}procedure LoadFromFile(const Filename: String);{$ENDIF} - {$IFNDEF UseDelphi}procedure SaveToFile(const Filename: String);{$ENDIF} - procedure LoadFromStream(Stream: TStream); {$IFDEF UseDelphi}override;{$ENDIF} - procedure SaveToStream(Stream: TStream); {$IFDEF UseDelphi}override;{$ENDIF} - {Loading the image from resources} - procedure LoadFromResourceName(Instance: HInst; const Name: String); - procedure LoadFromResourceID(Instance: HInst; ResID: Integer); - {Access to the png pixels} - property Pixels[const X, Y: Integer]: TColor read GetPixels write SetPixels; - {Palette property} - {$IFNDEF UseDelphi}property Palette: HPalette read GetPalette;{$ENDIF} - end; - - {Chunk name object} - TChunkName = Array[0..3] of Char; - - {Global chunk object} - TChunk = class - private - {Contains data} - fData: Pointer; - fDataSize: Cardinal; - {Stores owner} - fOwner: TPngObject; - {Stores the chunk name} - fName: TChunkName; - {Returns pointer to the TChunkIHDR} - function GetHeader: TChunkIHDR; - {Used with property index} - function GetIndex: Integer; - {Should return chunk class/name} - class function GetName: String; virtual; - {Returns the chunk name} - function GetChunkName: String; - public - {Returns index from list} - property Index: Integer read GetIndex; - {Returns pointer to the TChunkIHDR} - property Header: TChunkIHDR read GetHeader; - {Resize the data} - procedure ResizeData(const NewSize: Cardinal); - {Returns data and size} - property Data: Pointer read fData; - property DataSize: Cardinal read fDataSize; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); virtual; - {Returns owner} - property Owner: TPngObject read fOwner; - {Being destroyed/created} - constructor Create(Owner: TPngObject); virtual; - destructor Destroy; override; - {Returns chunk class/name} - property Name: String read GetChunkName; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; virtual; - {Saves the chunk to a stream} - function SaveData(Stream: TStream): Boolean; - function SaveToStream(Stream: TStream): Boolean; virtual; - end; - - {Chunk classes} - TChunkIEND = class(TChunk); {End chunk} - - {IHDR data} - pIHDRData = ^TIHDRData; - TIHDRData = packed record - Width, Height: Cardinal; - BitDepth, - ColorType, - CompressionMethod, - FilterMethod, - InterlaceMethod: Byte; - end; - - {Information header chunk} - TChunkIHDR = class(TChunk) - private - {Current image} - ImageHandle: HBitmap; - ImageDC: HDC; - - {Output windows bitmap} - HasPalette: Boolean; - BitmapInfo: TMaxBitmapInfo; - BytesPerRow: Integer; - {Stores the image bytes} - {$IFDEF Store16bits}ExtraImageData: Pointer;{$ENDIF} - ImageData: pointer; - ImageAlpha: Pointer; - - {Contains all the ihdr data} - IHDRData: TIHDRData; - protected - {Resizes the image data to fill the color type, bit depth, } - {width and height parameters} - procedure PrepareImageData; - {Release allocated ImageData memory} - procedure FreeImageData; - public - {Properties} - property Width: Cardinal read IHDRData.Width write IHDRData.Width; - property Height: Cardinal read IHDRData.Height write IHDRData.Height; - property BitDepth: Byte read IHDRData.BitDepth write IHDRData.BitDepth; - property ColorType: Byte read IHDRData.ColorType write IHDRData.ColorType; - property CompressionMethod: Byte read IHDRData.CompressionMethod - write IHDRData.CompressionMethod; - property FilterMethod: Byte read IHDRData.FilterMethod - write IHDRData.FilterMethod; - property InterlaceMethod: Byte read IHDRData.InterlaceMethod - write IHDRData.InterlaceMethod; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Destructor/constructor} - constructor Create(Owner: TPngObject); override; - destructor Destroy; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {Gamma chunk} - TChunkgAMA = class(TChunk) - private - {Returns/sets the value for the gamma chunk} - function GetValue: Cardinal; - procedure SetValue(const Value: Cardinal); - public - {Returns/sets gamma value} - property Gamma: Cardinal read GetValue write SetValue; - {Loading the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Being created} - constructor Create(Owner: TPngObject); override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {ZLIB Decompression extra information} - TZStreamRec2 = packed record - {From ZLIB} - ZLIB: TZStreamRec; - {Additional info} - Data: Pointer; - fStream : TStream; - end; - - {Palette chunk} - TChunkPLTE = class(TChunk) - private - {Number of items in the palette} - fCount: Integer; - {Contains the palette handle} - function GetPaletteItem(Index: Byte): TRGBQuad; - public - {Returns the color for each item in the palette} - property Item[Index: Byte]: TRGBQuad read GetPaletteItem; - {Returns the number of items in the palette} - property Count: Integer read fCount; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {Transparency information} - TChunktRNS = class(TChunk) - private - fBitTransparency: Boolean; - function GetTransparentColor: ColorRef; - {Returns the transparent color} - procedure SetTransparentColor(const Value: ColorRef); - public - {Palette values for transparency} - PaletteValues: Array[Byte] of Byte; - {Returns if it uses bit transparency} - property BitTransparency: Boolean read fBitTransparency; - {Returns the transparent color} - property TransparentColor: ColorRef read GetTransparentColor write - SetTransparentColor; - {Loads/saves the chunk from/to a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {Actual image information} - TChunkIDAT = class(TChunk) - private - {Holds another pointer to the TChunkIHDR} - Header: TChunkIHDR; - {Stores temporary image width and height} - ImageWidth, ImageHeight: Integer; - {Size in bytes of each line and offset} - Row_Bytes, Offset : Cardinal; - {Contains data for the lines} - Encode_Buffer: Array[0..5] of pByteArray; - Row_Buffer: Array[Boolean] of pByteArray; - {Variable to invert the Row_Buffer used} - RowUsed: Boolean; - {Ending position for the current IDAT chunk} - EndPos: Integer; - {Filter the current line} - procedure FilterRow; - {Filter to encode and returns the best filter} - function FilterToEncode: Byte; - {Reads ZLIB compressed data} - function IDATZlibRead(var ZLIBStream: TZStreamRec2; Buffer: Pointer; - Count: Integer; var EndPos: Integer; var crcfile: Cardinal): Integer; - {Compress and writes IDAT data} - procedure IDATZlibWrite(var ZLIBStream: TZStreamRec2; Buffer: Pointer; - const Length: Cardinal); - procedure FinishIDATZlib(var ZLIBStream: TZStreamRec2); - {Prepares the palette} - procedure PreparePalette; - protected - {Decode interlaced image} - procedure DecodeInterlacedAdam7(Stream: TStream; - var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); - {Decode non interlaced imaged} - procedure DecodeNonInterlaced(Stream: TStream; - var ZLIBStream: TZStreamRec2; const Size: Integer; - var crcfile: Cardinal); - protected - {Encode non interlaced images} - procedure EncodeNonInterlaced(Stream: TStream; - var ZLIBStream: TZStreamRec2); - {Encode interlaced images} - procedure EncodeInterlacedAdam7(Stream: TStream; - var ZLIBStream: TZStreamRec2); - protected - {Memory copy methods to decode} - procedure CopyNonInterlacedRGB8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedRGB16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedPalette148( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedPalette2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGray2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGrayscale16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedRGBAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedRGBAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGrayscaleAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGrayscaleAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGB8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGB16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedPalette2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGray2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - protected - {Memory copy methods to encode} - procedure EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedGrayscaleAlpha8(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedGrayscaleAlpha16(Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGB8(const Pass: Byte; Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGB16(const Pass: Byte; Src, Dest, Trans: pChar); - procedure EncodeInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans: pChar); - public - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - end; - - {Image last modification chunk} - TChunktIME = class(TChunk) - private - {Holds the variables} - fYear: Word; - fMonth, fDay, fHour, fMinute, fSecond: Byte; - public - {Returns/sets variables} - property Year: Word read fYear write fYear; - property Month: Byte read fMonth write fMonth; - property Day: Byte read fDay write fDay; - property Hour: Byte read fHour write fHour; - property Minute: Byte read fMinute write fMinute; - property Second: Byte read fSecond write fSecond; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - end; - - {Textual data} - TChunktEXt = class(TChunk) - private - fKeyword, fText: String; - public - {Keyword and text} - property Keyword: String read fKeyword write fKeyword; - property Text: String read fText write fText; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {zTXT chunk} - TChunkzTXt = class(TChunktEXt) - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - end; - -{Here we test if it's c++ builder or delphi version 3 or less} -{$IFDEF VER110}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER100}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER93}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER90}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER80}{$DEFINE DelphiBuilder3Less}{$ENDIF} - - -{Registers a new chunk class} -procedure RegisterChunk(ChunkClass: TChunkClass); -{Calculates crc} -function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer - {$ENDIF}; buf: pByteArray; len: Integer): Cardinal; -{Invert bytes using assembly} -function ByteSwap(const a: integer): integer; - -implementation - -var - ChunkClasses: TPngPointerList; - {Table of CRCs of all 8-bit messages} - crc_table: Array[0..255] of Cardinal; - {Flag: has the table been computed? Initially false} - crc_table_computed: Boolean; - -{Draw transparent image using transparent color} -procedure DrawTransparentBitmap(dc: HDC; srcBits: Pointer; - var srcHeader: TBitmapInfoHeader; - srcBitmapInfo: pBitmapInfo; Rect: TRect; cTransparentColor: COLORREF); -var - cColor: COLORREF; - bmAndBack, bmAndObject, bmAndMem: HBITMAP; - bmBackOld, bmObjectOld, bmMemOld: HBITMAP; - hdcMem, hdcBack, hdcObject, hdcTemp: HDC; - ptSize, orgSize: TPOINT; - OldBitmap, DrawBitmap: HBITMAP; -begin - hdcTemp := CreateCompatibleDC(dc); - // Select the bitmap - DrawBitmap := CreateDIBitmap(dc, srcHeader, CBM_INIT, srcBits, srcBitmapInfo^, - DIB_RGB_COLORS); - OldBitmap := SelectObject(hdcTemp, DrawBitmap); - - // Sizes - OrgSize.x := abs(srcHeader.biWidth); - OrgSize.y := abs(srcHeader.biHeight); - ptSize.x := Rect.Right - Rect.Left; // Get width of bitmap - ptSize.y := Rect.Bottom - Rect.Top; // Get height of bitmap - - // Create some DCs to hold temporary data. - hdcBack := CreateCompatibleDC(dc); - hdcObject := CreateCompatibleDC(dc); - hdcMem := CreateCompatibleDC(dc); - - // Create a bitmap for each DC. DCs are required for a number of - // GDI functions. - - // Monochrome DCs - bmAndBack := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); - bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); - - bmAndMem := CreateCompatibleBitmap(dc, ptSize.x, ptSize.y); - - // Each DC must select a bitmap object to store pixel data. - bmBackOld := SelectObject(hdcBack, bmAndBack); - bmObjectOld := SelectObject(hdcObject, bmAndObject); - bmMemOld := SelectObject(hdcMem, bmAndMem); - - // Set the background color of the source DC to the color. - // contained in the parts of the bitmap that should be transparent - cColor := SetBkColor(hdcTemp, cTransparentColor); - - // Create the object mask for the bitmap by performing a BitBlt - // from the source bitmap to a monochrome bitmap. - StretchBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, - orgSize.x, orgSize.y, SRCCOPY); - - // Set the background color of the source DC back to the original - // color. - SetBkColor(hdcTemp, cColor); - - // Create the inverse of the object mask. - BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, - NOTSRCCOPY); - - // Copy the background of the main DC to the destination. - BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, dc, Rect.Left, Rect.Top, - SRCCOPY); - - // Mask out the places where the bitmap will be placed. - BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND); - - // Mask out the transparent colored pixels on the bitmap. -// BitBlt(hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND); - StretchBlt(hdcTemp, 0, 0, OrgSize.x, OrgSize.y, hdcBack, 0, 0, - PtSize.x, PtSize.y, SRCAND); - - // XOR the bitmap with the background on the destination DC. - StretchBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, - OrgSize.x, OrgSize.y, SRCPAINT); - - // Copy the destination to the screen. - BitBlt(dc, Rect.Left, Rect.Top, ptSize.x, ptSize.y, hdcMem, 0, 0, - SRCCOPY); - - // Delete the memory bitmaps. - DeleteObject(SelectObject(hdcBack, bmBackOld)); - DeleteObject(SelectObject(hdcObject, bmObjectOld)); - DeleteObject(SelectObject(hdcMem, bmMemOld)); - DeleteObject(SelectObject(hdcTemp, OldBitmap)); - - // Delete the memory DCs. - DeleteDC(hdcMem); - DeleteDC(hdcBack); - DeleteDC(hdcObject); - DeleteDC(hdcTemp); -end; - -{Make the table for a fast CRC.} -procedure make_crc_table; -var - c: Cardinal; - n, k: Integer; -begin - - {fill the crc table} - for n := 0 to 255 do - begin - c := Cardinal(n); - for k := 0 to 7 do - begin - if Boolean(c and 1) then - c := $edb88320 xor (c shr 1) - else - c := c shr 1; - end; - crc_table[n] := c; - end; - - {The table has already being computated} - crc_table_computed := true; -end; - -{Update a running CRC with the bytes buf[0..len-1]--the CRC - should be initialized to all 1's, and the transmitted value - is the 1's complement of the final running CRC (see the - crc() routine below)).} -function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer - {$ENDIF}; buf: pByteArray; len: Integer): Cardinal; -var - c: Cardinal; - n: Integer; -begin - c := crc; - - {Create the crc table in case it has not being computed yet} - if not crc_table_computed then make_crc_table; - - {Update} - for n := 0 to len - 1 do - c := crc_table[(c XOR buf^[n]) and $FF] XOR (c shr 8); - - {Returns} - Result := c; -end; - -{$IFNDEF UseDelphi} - function FileExists(Filename: String): Boolean; - var - FindFile: THandle; - FindData: TWin32FindData; - begin - FindFile := FindFirstFile(PChar(Filename), FindData); - Result := FindFile <> INVALID_HANDLE_VALUE; - if Result then Windows.FindClose(FindFile); - end; - - -{$ENDIF} - -{$IFNDEF UseDelphi} - {Exception implementation} - constructor Exception.Create(Msg: String); - begin - end; -{$ENDIF} - -{Calculates the paeth predictor} -function PaethPredictor(a, b, c: Byte): Byte; -var - pa, pb, pc: Integer; -begin - { a = left, b = above, c = upper left } - pa := abs(b - c); { distances to a, b, c } - pb := abs(a - c); - pc := abs(a + b - c * 2); - - { return nearest of a, b, c, breaking ties in order a, b, c } - if (pa <= pb) and (pa <= pc) then - Result := a - else - if pb <= pc then - Result := b - else - Result := c; -end; - -{Invert bytes using assembly} -function ByteSwap(const a: integer): integer; -asm - bswap eax -end; -function ByteSwap16(inp:word): word; -asm - bswap eax - shr eax, 16 -end; - -{Calculates number of bytes for the number of pixels using the} -{color mode in the paramenter} -function BytesForPixels(const Pixels: Integer; const ColorType, - BitDepth: Byte): Integer; -begin - case ColorType of - {Palette and grayscale contains a single value, for palette} - {an value of size 2^bitdepth pointing to the palette index} - {and grayscale the value from 0 to 2^bitdepth with color intesity} - COLOR_GRAYSCALE, COLOR_PALETTE: - Result := (Pixels * BitDepth + 7) div 8; - {RGB contains 3 values R, G, B with size 2^bitdepth each} - COLOR_RGB: - Result := (Pixels * BitDepth * 3) div 8; - {Contains one value followed by alpha value booth size 2^bitdepth} - COLOR_GRAYSCALEALPHA: - Result := (Pixels * BitDepth * 2) div 8; - {Contains four values size 2^bitdepth, Red, Green, Blue and alpha} - COLOR_RGBALPHA: - Result := (Pixels * BitDepth * 4) div 8; - else - Result := 0; - end {case ColorType} -end; - -type - pChunkClassInfo = ^TChunkClassInfo; - TChunkClassInfo = record - ClassName: TChunkClass; - end; - -{Register a chunk type} -procedure RegisterChunk(ChunkClass: TChunkClass); -var - NewClass: pChunkClassInfo; -begin - {In case the list object has not being created yet} - if ChunkClasses = nil then ChunkClasses := TPngPointerList.Create(nil); - - {Add this new class} - new(NewClass); - NewClass^.ClassName := ChunkClass; - ChunkClasses.Add(NewClass); -end; - -{Free chunk class list} -procedure FreeChunkClassList; -var - i: Integer; -begin - if (ChunkClasses <> nil) then - begin - FOR i := 0 TO ChunkClasses.Count - 1 do - Dispose(pChunkClassInfo(ChunkClasses.Item[i])); - ChunkClasses.Free; - end; -end; - -{Registering of common chunk classes} -procedure RegisterCommonChunks; -begin - {Important chunks} - RegisterChunk(TChunkIEND); - RegisterChunk(TChunkIHDR); - RegisterChunk(TChunkIDAT); - RegisterChunk(TChunkPLTE); - RegisterChunk(TChunkgAMA); - RegisterChunk(TChunktRNS); - - {Not so important chunks} - RegisterChunk(TChunktIME); - RegisterChunk(TChunktEXt); - RegisterChunk(TChunkzTXt); -end; - -{Creates a new chunk of this class} -function CreateClassChunk(Owner: TPngObject; Name: TChunkName): TChunk; -var - i : Integer; - NewChunk: TChunkClass; -begin - {Looks for this chunk} - NewChunk := TChunk; {In case there is no registered class for this} - - {Looks for this class in all registered chunks} - if Assigned(ChunkClasses) then - FOR i := 0 TO ChunkClasses.Count - 1 DO - begin - if pChunkClassInfo(ChunkClasses.Item[i])^.ClassName.GetName = Name then - begin - NewChunk := pChunkClassInfo(ChunkClasses.Item[i])^.ClassName; - break; - end; - end; - - {Returns chunk class} - Result := NewChunk.Create(Owner); - Result.fName := Name; -end; - -{ZLIB support} - -const - ZLIBAllocate = High(Word); - -{Initializes ZLIB for decompression} -function ZLIBInitInflate(Stream: TStream): TZStreamRec2; -begin - {Fill record} - Fillchar(Result, SIZEOF(TZStreamRec2), #0); - - {Set internal record information} - with Result do - begin - GetMem(Data, ZLIBAllocate); - fStream := Stream; - end; - - {Init decompression} - InflateInit_(Result.zlib, zlib_version, SIZEOF(TZStreamRec)); -end; - -{Initializes ZLIB for compression} -function ZLIBInitDeflate(Stream: TStream; - Level: TCompressionlevel; Size: Cardinal): TZStreamRec2; -begin - {Fill record} - Fillchar(Result, SIZEOF(TZStreamRec2), #0); - - {Set internal record information} - with Result, ZLIB do - begin - GetMem(Data, Size); - fStream := Stream; - next_out := Data; - avail_out := Size; - end; - - {Inits compression} - deflateInit_(Result.zlib, Level, zlib_version, sizeof(TZStreamRec)); -end; - -{Terminates ZLIB for compression} -procedure ZLIBTerminateDeflate(var ZLIBStream: TZStreamRec2); -begin - {Terminates decompression} - DeflateEnd(ZLIBStream.zlib); - {Free internal record} - FreeMem(ZLIBStream.Data, ZLIBAllocate); -end; - -{Terminates ZLIB for decompression} -procedure ZLIBTerminateInflate(var ZLIBStream: TZStreamRec2); -begin - {Terminates decompression} - InflateEnd(ZLIBStream.zlib); - {Free internal record} - FreeMem(ZLIBStream.Data, ZLIBAllocate); -end; - -{Decompresses ZLIB into a memory address} -function DecompressZLIB(const Input: Pointer; InputSize: Integer; - var Output: Pointer; var OutputSize: Integer; - var ErrorOutput: String): Boolean; -var - StreamRec : TZStreamRec; - Buffer : Array[Byte] of Byte; - InflateRet: Integer; -begin - with StreamRec do - begin - {Initializes} - Result := True; - OutputSize := 0; - - {Prepares the data to decompress} - FillChar(StreamRec, SizeOf(TZStreamRec), #0); - InflateInit_(StreamRec, zlib_version, SIZEOF(TZStreamRec)); - next_in := Input; - avail_in := InputSize; - - {Decodes data} - repeat - {In case it needs an output buffer} - if (avail_out = 0) then - begin - next_out := @Buffer; - avail_out := SizeOf(Buffer); - end {if (avail_out = 0)}; - - {Decompress and put in output} - InflateRet := inflate(StreamRec, 0); - if (InflateRet = Z_STREAM_END) or (InflateRet = 0) then - begin - {Reallocates output buffer} - inc(OutputSize, total_out); - if Output = nil then - GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize); - {Copies the new data} - CopyMemory(pointer(Longint(Output) + OutputSize - total_out), @Buffer, total_out); - end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)} - {Now tests for errors} - else if InflateRet < 0 then - begin - Result := False; - ErrorOutput := StreamRec.msg; - InflateEnd(StreamRec); - Exit; - end {if InflateRet < 0} - until InflateRet = Z_STREAM_END; - - {Terminates decompression} - InflateEnd(StreamRec); - end {with StreamRec} - -end; - -{Compresses ZLIB into a memory address} -function CompressZLIB(Input: Pointer; InputSize, CompressionLevel: Integer; - var Output: Pointer; var OutputSize: Integer; - var ErrorOutput: String): Boolean; -var - StreamRec : TZStreamRec; - Buffer : Array[Byte] of Byte; - DeflateRet: Integer; -begin - with StreamRec do - begin - Result := True; {By default returns TRUE as everything might have gone ok} - OutputSize := 0; {Initialize} - {Prepares the data to compress} - FillChar(StreamRec, SizeOf(TZStreamRec), #0); - DeflateInit_(StreamRec, CompressionLevel,zlib_version, SIZEOF(TZStreamRec)); - - next_in := Input; - avail_in := InputSize; - - while avail_in > 0 do - begin - {When it needs new buffer to stores the compressed data} - if avail_out = 0 then - begin - {Restore buffer} - next_out := @Buffer; - avail_out := SizeOf(Buffer); - end {if avail_out = 0}; - - {Compresses} - DeflateRet := deflate(StreamRec, Z_FINISH); - - if (DeflateRet = Z_STREAM_END) or (DeflateRet = 0) then - begin - {Updates the output memory} - inc(OutputSize, total_out); - if Output = nil then - GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize); - - {Copies the new data} - CopyMemory(Pointer(Longint(Output) + OutputSize - total_out), @Buffer, total_out); - end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)} - {Now tests for errors} - else if DeflateRet < 0 then - begin - Result := False; - ErrorOutput := StreamRec.msg; - DeflateEnd(StreamRec); - Exit; - end {if InflateRet < 0} - - end {while avail_in > 0}; - - {Finishes compressing} - DeflateEnd(StreamRec); - end {with StreamRec} - -end; - -{TPngPointerList implementation} - -{Object being created} -constructor TPngPointerList.Create(AOwner: TPNGObject); -begin - inherited Create; {Let ancestor work} - {Holds owner} - fOwner := AOwner; - {Memory pointer not being used yet} - fMemory := nil; - {No items yet} - fCount := 0; -end; - -{Removes value from the list} -function TPngPointerList.Remove(Value: Pointer): Pointer; -var - I, Position: Integer; -begin - {Gets item position} - Position := -1; - FOR I := 0 TO Count - 1 DO - if Value = Item[I] then Position := I; - {In case a match was found} - if Position >= 0 then - begin - Result := Item[Position]; {Returns pointer} - {Remove item and move memory} - Dec(fCount); - if Position < Integer(FCount) then - System.Move(fMemory^[Position + 1], fMemory^[Position], - (Integer(fCount) - Position) * SizeOf(Pointer)); - end {if Position >= 0} else Result := nil -end; - -{Add a new value in the list} -procedure TPngPointerList.Add(Value: Pointer); -begin - Count := Count + 1; - Item[Count - 1] := Value; -end; - - -{Object being destroyed} -destructor TPngPointerList.Destroy; -begin - {Release memory if needed} - if fMemory <> nil then - FreeMem(fMemory, fCount * sizeof(Pointer)); - - {Free things} - inherited Destroy; -end; - -{Returns one item from the list} -function TPngPointerList.GetItem(Index: Cardinal): Pointer; -begin - if (Index <= Count - 1) then - Result := fMemory[Index] - else - {In case it's out of bounds} - Result := nil; -end; - -{Inserts a new item in the list} -procedure TPngPointerList.Insert(Value: Pointer; Position: Cardinal); -begin - if (Position < Count) then - begin - {Increase item count} - SetSize(Count + 1); - {Move other pointers} - if Position < Count then - System.Move(fMemory^[Position], fMemory^[Position + 1], - (Count - Position - 1) * SizeOf(Pointer)); - {Sets item} - Item[Position] := Value; - end; -end; - -{Sets one item from the list} -procedure TPngPointerList.SetItem(Index: Cardinal; const Value: Pointer); -begin - {If index is in bounds, set value} - if (Index <= Count - 1) then - fMemory[Index] := Value -end; - -{This method resizes the list} -procedure TPngPointerList.SetSize(const Size: Cardinal); -begin - {Sets the size} - if (fMemory = nil) and (Size > 0) then - GetMem(fMemory, Size * SIZEOF(Pointer)) - else - if Size > 0 then {Only realloc if the new size is greater than 0} - ReallocMem(fMemory, Size * SIZEOF(Pointer)) - else - {In case user is resize to 0 items} - begin - FreeMem(fMemory); - fMemory := nil; - end; - {Update count} - fCount := Size; -end; - -{TPNGList implementation} - -{Removes an item} -procedure TPNGList.RemoveChunk(Chunk: TChunk); -begin - Remove(Chunk); - Chunk.Free -end; - -{Add a new item} -function TPNGList.Add(ChunkClass: TChunkClass): TChunk; -var - IHDR: TChunkIHDR; - IEND: TChunkIEND; - - IDAT: TChunkIDAT; - PLTE: TChunkPLTE; -begin - Result := nil; {Default result} - {Adding these is not allowed} - if (ChunkClass = TChunkIHDR) or (ChunkClass = TChunkIDAT) or - (ChunkClass = TChunkPLTE) or (ChunkClass = TChunkIEND) then - fOwner.RaiseError(EPngError, EPNGCannotAddChunkText) - {Two of these is not allowed} - else if ((ChunkClass = TChunkgAMA) and (ItemFromClass(TChunkgAMA) <> nil)) or - ((ChunkClass = TChunktRNS) and (ItemFromClass(TChunktRNS) <> nil)) then - fOwner.RaiseError(EPngError, EPNGCannotAddChunkText) - {There must have an IEND and IHDR chunk} - else if (ItemFromClass(TChunkIEND) = nil) or - (ItemFromClass(TChunkIHDR) = nil) then - fOwner.RaiseError(EPngError, EPNGCannotAddInvalidImageText) - else - begin - {Get common chunks} - IHDR := ItemFromClass(TChunkIHDR) as TChunkIHDR; - IEND := ItemFromClass(TChunkIEND) as TChunkIEND; - {Create new chunk} - Result := ChunkClass.Create(Owner); - {Add to the list} - if (ChunkClass = TChunkgAMA) then - Insert(Result, IHDR.Index + 1) - {Transparency chunk (fix by Ian Boyd)} - else if (ChunkClass = TChunktRNS) then - begin - {Transparecy chunk must be after PLTE; before IDAT} - IDAT := ItemFromClass(TChunkIDAT) as TChunkIDAT; - PLTE := ItemFromClass(TChunkPLTE) as TChunkPLTE; - - if Assigned(PLTE) then - Insert(Result, PLTE.Index + 1) - else if Assigned(IDAT) then - Insert(Result, IDAT.Index) - else - Insert(Result, IHDR.Index + 1) - end - else {All other chunks} - Insert(Result, IEND.Index); - end {if} -end; - -{Returns item from the list} -function TPNGList.GetItem(Index: Cardinal): TChunk; -begin - Result := inherited GetItem(Index); -end; - -{Returns first item from the list using the class from parameter} -function TPNGList.ItemFromClass(ChunkClass: TChunkClass): TChunk; -var - i: Integer; -begin - Result := nil; {Initial result} - FOR i := 0 TO Count - 1 DO - {Test if this item has the same class} - if Item[i] is ChunkClass then - begin - {Returns this item and exit} - Result := Item[i]; - break; - end {if} -end; - -{$IFNDEF UseDelphi} - - {TStream implementation} - - {Copies all from another stream} - function TStream.CopyFrom(Source: TStream; Count: Cardinal): Cardinal; - const - MaxBytes = $f000; - var - Buffer: PChar; - BufSize, N: Cardinal; - begin - {If count is zero, copy everything from Source} - if Count = 0 then - begin - Source.Seek(0, soFromBeginning); - Count := Source.Size; - end; - - Result := Count; {Returns the number of bytes readed} - {Allocates memory} - if Count > MaxBytes then BufSize := MaxBytes else BufSize := Count; - GetMem(Buffer, BufSize); - - {Copy memory} - while Count > 0 do - begin - if Count > BufSize then N := BufSize else N := Count; - Source.Read(Buffer^, N); - Write(Buffer^, N); - dec(Count, N); - end; - - {Deallocates memory} - FreeMem(Buffer, BufSize); - end; - -{Set current stream position} -procedure TStream.SetPosition(const Value: Longint); -begin - Seek(Value, soFromBeginning); -end; - -{Returns position} -function TStream.GetPosition: Longint; -begin - Result := Seek(0, soFromCurrent); -end; - - {Returns stream size} -function TStream.GetSize: Longint; - var - Pos: Cardinal; - begin - Pos := Seek(0, soFromCurrent); - Result := Seek(0, soFromEnd); - Seek(Pos, soFromCurrent); - end; - - {TFileStream implementation} - - {Filestream object being created} - constructor TFileStream.Create(Filename: String; Mode: TFileStreamModeSet); - {Makes file mode} - function OpenMode: DWORD; - begin - Result := 0; - if fsmRead in Mode then Result := GENERIC_READ; - if (fsmWrite in Mode) or (fsmCreate in Mode) then - Result := Result OR GENERIC_WRITE; - end; - const - IsCreate: Array[Boolean] of Integer = (OPEN_ALWAYS, CREATE_ALWAYS); - begin - {Call ancestor} - inherited Create; - - {Create handle} - fHandle := CreateFile(PChar(Filename), OpenMode, FILE_SHARE_READ or - FILE_SHARE_WRITE, nil, IsCreate[fsmCreate in Mode], 0, 0); - {Store mode} - FileMode := Mode; - end; - - {Filestream object being destroyed} - destructor TFileStream.Destroy; - begin - {Terminates file and close} - if FileMode = [fsmWrite] then - SetEndOfFile(fHandle); - CloseHandle(fHandle); - - {Call ancestor} - inherited Destroy; - end; - - {Writes data to the file} - function TFileStream.Write(const Buffer; Count: Longint): Cardinal; - begin - if not WriteFile(fHandle, Buffer, Count, Result, nil) then - Result := 0; - end; - - {Reads data from the file} - function TFileStream.Read(var Buffer; Count: Longint): Cardinal; - begin - if not ReadFile(fHandle, Buffer, Count, Result, nil) then - Result := 0; - end; - - {Seeks the file position} - function TFileStream.Seek(Offset: Integer; Origin: Word): Longint; - begin - Result := SetFilePointer(fHandle, Offset, nil, Origin); - end; - - {Sets the size of the file} - procedure TFileStream.SetSize(const Value: Longint); - begin - Seek(Value, soFromBeginning); - SetEndOfFile(fHandle); - end; - - {TResourceStream implementation} - - {Creates the resource stream} - constructor TResourceStream.Create(Instance: HInst; const ResName: String; - ResType: PChar); - var - ResID: HRSRC; - ResGlobal: HGlobal; - begin - {Obtains the resource ID} - ResID := FindResource(hInstance, PChar(ResName), RT_RCDATA); - if ResID = 0 then raise EPNGError.Create(''); - {Obtains memory and size} - ResGlobal := LoadResource(hInstance, ResID); - Size := SizeOfResource(hInstance, ResID); - Memory := LockResource(ResGlobal); - if (ResGlobal = 0) or (Memory = nil) then EPNGError.Create(''); - end; - - - {Setting resource stream size is not supported} - procedure TResourceStream.SetSize(const Value: Integer); - begin - end; - - {Writing into a resource stream is not supported} - function TResourceStream.Write(const Buffer; Count: Integer): Cardinal; - begin - Result := 0; - end; - - {Reads data from the stream} - function TResourceStream.Read(var Buffer; Count: Integer): Cardinal; - begin - //Returns data - CopyMemory(@Buffer, pointer(Longint(Memory) + Position), Count); - //Update position - inc(Position, Count); - //Returns - Result := Count; - end; - - {Seeks data} - function TResourceStream.Seek(Offset: Integer; Origin: Word): Longint; - begin - {Move depending on the origin} - case Origin of - soFromBeginning: Position := Offset; - soFromCurrent: inc(Position, Offset); - soFromEnd: Position := Size + Offset; - end; - - {Returns the current position} - Result := Position; - end; - -{$ENDIF} - -{TChunk implementation} - -{Resizes the data} -procedure TChunk.ResizeData(const NewSize: Cardinal); -begin - fDataSize := NewSize; - ReallocMem(fData, NewSize + 1); -end; - -{Returns index from list} -function TChunk.GetIndex: Integer; -var - i: Integer; -begin - Result := -1; {Avoiding warnings} - {Searches in the list} - FOR i := 0 TO Owner.Chunks.Count - 1 DO - if Owner.Chunks.Item[i] = Self then - begin - {Found match} - Result := i; - exit; - end {for i} -end; - -{Returns pointer to the TChunkIHDR} -function TChunk.GetHeader: TChunkIHDR; -begin - Result := Owner.Chunks.Item[0] as TChunkIHDR; -end; - -{Assigns from another TChunk} -procedure TChunk.Assign(Source: TChunk); -begin - {Copy properties} - fName := Source.fName; - {Set data size and realloc} - ResizeData(Source.fDataSize); - - {Copy data (if there's any)} - if fDataSize > 0 then CopyMemory(fData, Source.fData, fDataSize); -end; - -{Chunk being created} -constructor TChunk.Create(Owner: TPngObject); -var - ChunkName: String; -begin - {Ancestor create} - inherited Create; - - {If it's a registered class, set the chunk name based on the class} - {name. For instance, if the class name is TChunkgAMA, the GAMA part} - {will become the chunk name} - ChunkName := Copy(ClassName, Length('TChunk') + 1, Length(ClassName)); - if Length(ChunkName) = 4 then CopyMemory(@fName[0], @ChunkName[1], 4); - - {Initialize data holder} - GetMem(fData, 1); - fDataSize := 0; - {Record owner} - fOwner := Owner; -end; - -{Chunk being destroyed} -destructor TChunk.Destroy; -begin - {Free data holder} - FreeMem(fData, fDataSize + 1); - {Let ancestor destroy} - inherited Destroy; -end; - -{Returns the chunk name 1} -function TChunk.GetChunkName: String; -begin - Result := fName -end; - -{Returns the chunk name 2} -class function TChunk.GetName: String; -begin - {For avoid writing GetName for each TChunk descendent, by default for} - {classes which don't declare GetName, it will look for the class name} - {to extract the chunk kind. Example, if the class name is TChunkIEND } - {this method extracts and returns IEND} - Result := Copy(ClassName, Length('TChunk') + 1, Length(ClassName)); -end; - -{Saves the data to the stream} -function TChunk.SaveData(Stream: TStream): Boolean; -var - ChunkSize, ChunkCRC: Cardinal; -begin - {First, write the size for the following data in the chunk} - ChunkSize := ByteSwap(DataSize); - Stream.Write(ChunkSize, 4); - {The chunk name} - Stream.Write(fName, 4); - {If there is data for the chunk, write it} - if DataSize > 0 then Stream.Write(Data^, DataSize); - {Calculates and write CRC} - ChunkCRC := update_crc($ffffffff, @fName[0], 4); - ChunkCRC := Byteswap(update_crc(ChunkCRC, Data, DataSize) xor $ffffffff); - Stream.Write(ChunkCRC, 4); - - {Returns that everything went ok} - Result := TRUE; -end; - -{Saves the chunk to the stream} -function TChunk.SaveToStream(Stream: TStream): Boolean; -begin - Result := SaveData(Stream) -end; - - -{Loads the chunk from a stream} -function TChunk.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -var - CheckCRC: Cardinal; - {$IFDEF CheckCRC}RightCRC: Cardinal;{$ENDIF} -begin - {Copies data from source} - ResizeData(Size); - if Size > 0 then Stream.Read(fData^, Size); - {Reads CRC} - Stream.Read(CheckCRC, 4); - CheckCrc := ByteSwap(CheckCRC); - - {Check if crc readed is valid} - {$IFDEF CheckCRC} - RightCRC := update_crc($ffffffff, @ChunkName[0], 4); - RightCRC := update_crc(RightCRC, fData, Size) xor $ffffffff; - Result := RightCRC = CheckCrc; - - {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; - -{TChunktIME implementation} - -{Chunk being loaded from a stream} -function TChunktIME.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -begin - {Let ancestor load the data} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result or (Size <> 7) then exit; {Size must be 7} - - {Reads data} - fYear := ((pByte(Longint(Data) )^) * 256)+ (pByte(Longint(Data) + 1)^); - fMonth := pByte(Longint(Data) + 2)^; - fDay := pByte(Longint(Data) + 3)^; - fHour := pByte(Longint(Data) + 4)^; - fMinute := pByte(Longint(Data) + 5)^; - fSecond := pByte(Longint(Data) + 6)^; -end; - -{Saving the chunk to a stream} -function TChunktIME.SaveToStream(Stream: TStream): Boolean; -begin - {Update data} - ResizeData(7); {Make sure the size is 7} - pWord(Data)^ := Year; - pByte(Longint(Data) + 2)^ := Month; - pByte(Longint(Data) + 3)^ := Day; - pByte(Longint(Data) + 4)^ := Hour; - pByte(Longint(Data) + 5)^ := Minute; - pByte(Longint(Data) + 6)^ := Second; - - {Let inherited save data} - Result := inherited SaveToStream(Stream); -end; - -{TChunkztXt implementation} - -{Loading the chunk from a stream} -function TChunkzTXt.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -var - ErrorOutput: String; - CompressionMethod: Byte; - Output: Pointer; - OutputSize: Integer; -begin - {Load data from stream and validate} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result or (Size < 4) then exit; - fKeyword := PChar(Data); {Get keyword and compression method bellow} - CompressionMethod := pByte(Longint(fKeyword) + Length(fKeyword))^; - fText := ''; - - {In case the compression is 0 (only one accepted by specs), reads it} - if CompressionMethod = 0 then - begin - Output := nil; - if DecompressZLIB(PChar(Longint(Data) + Length(fKeyword) + 2), - Size - Length(fKeyword) - 2, Output, OutputSize, ErrorOutput) then - begin - SetLength(fText, OutputSize); - CopyMemory(@fText[1], Output, OutputSize); - end {if DecompressZLIB(...}; - FreeMem(Output); - end {if CompressionMethod = 0} - -end; - -{Saving the chunk to a stream} -function TChunkztXt.SaveToStream(Stream: TStream): Boolean; -var - Output: Pointer; - OutputSize: Integer; - ErrorOutput: String; -begin - Output := nil; {Initializes output} - if fText = '' then fText := ' '; - - {Compresses the data} - if CompressZLIB(@fText[1], Length(fText), Owner.CompressionLevel, Output, - OutputSize, ErrorOutput) then - begin - {Size is length from keyword, plus a null character to divide} - {plus the compression method, plus the length of the text (zlib compressed)} - ResizeData(Length(fKeyword) + 2 + OutputSize); - - Fillchar(Data^, DataSize, #0); - {Copies the keyword data} - if Keyword <> '' then - CopyMemory(Data, @fKeyword[1], Length(Keyword)); - {Compression method 0 (inflate/deflate)} - pByte(pointer(Longint(Data) + Length(Keyword) + 1))^ := 0; - if OutputSize > 0 then - CopyMemory(pointer(Longint(Data) + Length(Keyword) + 2), Output, OutputSize); - - {Let ancestor calculate crc and save} - Result := SaveData(Stream); - end {if CompressZLIB(...} else Result := False; - - {Frees output} - if Output <> nil then FreeMem(Output) -end; - -{TChunktEXt implementation} - -{Assigns from another text chunk} -procedure TChunktEXt.Assign(Source: TChunk); -begin - fKeyword := TChunktEXt(Source).fKeyword; - fText := TChunktEXt(Source).fText; -end; - -{Loading the chunk from a stream} -function TChunktEXt.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -begin - {Load data from stream and validate} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result or (Size < 3) then exit; - {Get text} - fKeyword := PChar(Data); - SetLength(fText, Size - Length(fKeyword) - 1); - CopyMemory(@fText[1], pointer(Longint(Data) + Length(fKeyword) + 1), Length(fText)); -end; - -{Saving the chunk to a stream} -function TChunktEXt.SaveToStream(Stream: TStream): Boolean; -begin - {Size is length from keyword, plus a null character to divide} - {plus the length of the text} - ResizeData(Length(fKeyword) + 1 + Length(fText)); - Fillchar(Data^, DataSize, #0); - {Copy data} - if Keyword <> '' then - CopyMemory(Data, @fKeyword[1], Length(Keyword)); - if Text <> '' then - CopyMemory(pointer(Longint(Data) + Length(Keyword) + 1), @fText[1], Length(Text)); - {Let ancestor calculate crc and save} - Result := inherited SaveToStream(Stream); -end; - - -{TChunkIHDR implementation} - -{Chunk being created} -constructor TChunkIHDR.Create(Owner: TPngObject); -begin - {Call inherited} - inherited Create(Owner); - {Prepare pointers} - ImageHandle := 0; - ImageDC := 0; -end; - -{Chunk being destroyed} -destructor TChunkIHDR.Destroy; -begin - {Free memory} - FreeImageData(); - - {Calls TChunk destroy} - inherited Destroy; -end; - -{Assigns from another IHDR chunk} -procedure TChunkIHDR.Assign(Source: TChunk); -begin - {Copy the IHDR data} - if Source is TChunkIHDR then - begin - {Copy IHDR values} - IHDRData := TChunkIHDR(Source).IHDRData; - - {Prepare to hold data by filling BitmapInfo structure and} - {resizing ImageData and ImageAlpha memory allocations} - PrepareImageData(); - - {Copy image data} - CopyMemory(ImageData, TChunkIHDR(Source).ImageData, - BytesPerRow * Integer(Height)); - CopyMemory(ImageAlpha, TChunkIHDR(Source).ImageAlpha, - Integer(Width) * Integer(Height)); - - {Copy palette colors} - BitmapInfo.bmiColors := TChunkIHDR(Source).BitmapInfo.bmiColors; - end - else - Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText); -end; - -{Release allocated image data} -procedure TChunkIHDR.FreeImageData; -begin - {Free old image data} - if ImageHandle <> 0 then DeleteObject(ImageHandle); - if ImageDC <> 0 then DeleteDC(ImageDC); - if ImageAlpha <> nil then FreeMem(ImageAlpha); - {$IFDEF Store16bits} - if ExtraImageData <> nil then FreeMem(ExtraImageData); - {$ENDIF} - ImageHandle := 0; ImageDC := 0; ImageAlpha := nil; ImageData := nil; -end; - -{Chunk being loaded from a stream} -function TChunkIHDR.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -begin - {Let TChunk load it} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result then Exit; - - {Now check values} - {Note: It's recommended by png specification to make sure that the size} - {must be 13 bytes to be valid, but some images with 14 bytes were found} - {which could be loaded by internet explorer and other tools} - if (fDataSize < SIZEOF(TIHdrData)) then - begin - {Ihdr must always have at least 13 bytes} - Result := False; - Owner.RaiseError(EPNGInvalidIHDR, EPNGInvalidIHDRText); - exit; - end; - - {Everything ok, reads IHDR} - IHDRData := pIHDRData(fData)^; - IHDRData.Width := ByteSwap(IHDRData.Width); - IHDRData.Height := ByteSwap(IHDRData.Height); - - {The width and height must not be larger than 65535 pixels} - if (IHDRData.Width > High(Word)) or (IHDRData.Height > High(Word)) then - begin - Result := False; - Owner.RaiseError(EPNGSizeExceeds, EPNGSizeExceedsText); - exit; - end {if IHDRData.Width > High(Word)}; - {Compression method must be 0 (inflate/deflate)} - if (IHDRData.CompressionMethod <> 0) then - begin - Result := False; - Owner.RaiseError(EPNGUnknownCompression, EPNGUnknownCompressionText); - exit; - end; - {Interlace must be either 0 (none) or 7 (adam7)} - if (IHDRData.InterlaceMethod <> 0) and (IHDRData.InterlaceMethod <> 1) then - begin - Result := False; - Owner.RaiseError(EPNGUnknownInterlace, EPNGUnknownInterlaceText); - exit; - end; - - {Updates owner properties} - Owner.InterlaceMethod := TInterlaceMethod(IHDRData.InterlaceMethod); - - {Prepares data to hold image} - PrepareImageData(); -end; - -{Saving the IHDR chunk to a stream} -function TChunkIHDR.SaveToStream(Stream: TStream): Boolean; -begin - {Ignore 2 bits images} - if BitDepth = 2 then BitDepth := 4; - - {It needs to do is update the data with the IHDR data} - {structure containing the write values} - ResizeData(SizeOf(TIHDRData)); - pIHDRData(fData)^ := IHDRData; - {..byteswap 4 byte types} - pIHDRData(fData)^.Width := ByteSwap(pIHDRData(fData)^.Width); - pIHDRData(fData)^.Height := ByteSwap(pIHDRData(fData)^.Height); - {..update interlace method} - pIHDRData(fData)^.InterlaceMethod := Byte(Owner.InterlaceMethod); - {..and then let the ancestor SaveToStream do the hard work} - Result := inherited SaveToStream(Stream); -end; - -{Resizes the image data to fill the color type, bit depth, } -{width and height parameters} -procedure TChunkIHDR.PrepareImageData(); - - {Set the bitmap info} - procedure SetInfo(const Bitdepth: Integer; const Palette: Boolean); - begin - - {Copy if the bitmap contain palette entries} - HasPalette := Palette; - {Initialize the structure with zeros} - fillchar(BitmapInfo, sizeof(BitmapInfo), #0); - {Fill the strucutre} - with BitmapInfo.bmiHeader do - begin - biSize := sizeof(TBitmapInfoHeader); - biHeight := Height; - biWidth := Width; - biPlanes := 1; - biBitCount := BitDepth; - biCompression := BI_RGB; - end {with BitmapInfo.bmiHeader} - end; -begin - {Prepare bitmap info header} - Fillchar(BitmapInfo, sizeof(TMaxBitmapInfo), #0); - {Release old image data} - FreeImageData(); - - {Obtain number of bits for each pixel} - case ColorType of - COLOR_GRAYSCALE, COLOR_PALETTE, COLOR_GRAYSCALEALPHA: - case BitDepth of - {These are supported by windows} - 1, 4, 8: SetInfo(BitDepth, TRUE); - {2 bits for each pixel is not supported by windows bitmap} - 2 : SetInfo(4, TRUE); - {Also 16 bits (2 bytes) for each pixel is not supported} - {and should be transormed into a 8 bit grayscale} - 16 : SetInfo(8, TRUE); - end; - {Only 1 byte (8 bits) is supported} - COLOR_RGB, COLOR_RGBALPHA: SetInfo(24, FALSE); - end {case ColorType}; - {Number of bytes for each scanline} - BytesPerRow := (((BitmapInfo.bmiHeader.biBitCount * Width) + 31) - and not 31) div 8; - - {Build array for alpha information, if necessary} - if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then - begin - GetMem(ImageAlpha, Integer(Width) * Integer(Height)); - FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #0); - end; - - {Build array for extra byte information} - {$IFDEF Store16bits} - if (BitDepth = 16) then - begin - GetMem(ExtraImageData, BytesPerRow * Integer(Height)); - FillChar(ExtraImageData^, BytesPerRow * Integer(Height), #0); - end; - {$ENDIF} - - {Creates the image to hold the data, CreateDIBSection does a better} - {work in allocating necessary memory} - ImageDC := CreateCompatibleDC(0); - ImageHandle := CreateDIBSection(ImageDC, pBitmapInfo(@BitmapInfo)^, - DIB_RGB_COLORS, ImageData, 0, 0); - - {Clears the old palette (if any)} - with Owner do - if TempPalette <> 0 then - begin - DeleteObject(TempPalette); - TempPalette := 0; - end {with Owner, if TempPalette <> 0}; - - {Build array and allocate bytes for each row} - zeromemory(ImageData, BytesPerRow * Integer(Height)); -end; - -{TChunktRNS implementation} - -{$IFNDEF UseDelphi} -function CompareMem(P1, P2: pByte; const Size: Integer): Boolean; -var i: Integer; -begin - Result := True; - for i := 1 to Size do - begin - if P1^ <> P2^ then Result := False; - inc(P1); inc(P2); - end {for i} -end; -{$ENDIF} - -{Sets the transpararent color} -procedure TChunktRNS.SetTransparentColor(const Value: ColorRef); -var - i: Byte; - LookColor: TRGBQuad; -begin - {Clears the palette values} - Fillchar(PaletteValues, SizeOf(PaletteValues), #0); - {Sets that it uses bit transparency} - fBitTransparency := True; - - - {Depends on the color type} - with Header do - case ColorType of - COLOR_GRAYSCALE: - begin - Self.ResizeData(2); - pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value)); - end; - COLOR_RGB: - begin - Self.ResizeData(6); - pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value)); - pWord(@PaletteValues[2])^ := ByteSwap16(GetGValue(Value)); - pWord(@PaletteValues[4])^ := ByteSwap16(GetBValue(Value)); - end; - COLOR_PALETTE: - begin - {Creates a RGBQuad to search for the color} - LookColor.rgbRed := GetRValue(Value); - LookColor.rgbGreen := GetGValue(Value); - LookColor.rgbBlue := GetBValue(Value); - {Look in the table for the entry} - for i := 0 to 255 do - if CompareMem(@BitmapInfo.bmiColors[i], @LookColor, 3) then - Break; - {Fill the transparency table} - Fillchar(PaletteValues, i, 255); - Self.ResizeData(i + 1) - - end - end {case / with}; - -end; - -{Returns the transparent color for the image} -function TChunktRNS.GetTransparentColor: ColorRef; -var - PaletteChunk: TChunkPLTE; - i: Integer; -begin - Result := 0; {Default: Unknown transparent color} - - {Depends on the color type} - with Header do - case ColorType of - COLOR_GRAYSCALE: - Result := RGB(PaletteValues[0], PaletteValues[0], - PaletteValues[0]); - COLOR_RGB: - Result := RGB(PaletteValues[1], PaletteValues[3], PaletteValues[5]); - COLOR_PALETTE: - begin - {Obtains the palette chunk} - PaletteChunk := Owner.Chunks.ItemFromClass(TChunkPLTE) as TChunkPLTE; - - {Looks for an entry with 0 transparency meaning that it is the} - {full transparent entry} - for i := 0 to Self.DataSize - 1 do - if PaletteValues[i] = 0 then - with PaletteChunk.GetPaletteItem(i) do - begin - Result := RGB(rgbRed, rgbGreen, rgbBlue); - break - end - end {COLOR_PALETTE} - end {case Header.ColorType}; -end; - -{Saving the chunk to a stream} -function TChunktRNS.SaveToStream(Stream: TStream): Boolean; -begin - {Copy palette into data buffer} - if DataSize <= 256 then - CopyMemory(fData, @PaletteValues[0], DataSize); - - Result := inherited SaveToStream(Stream); -end; - -{Assigns from another chunk} -procedure TChunktRNS.Assign(Source: TChunk); -begin - CopyMemory(@PaletteValues[0], @TChunkTrns(Source).PaletteValues[0], 256); - fBitTransparency := TChunkTrns(Source).fBitTransparency; - inherited Assign(Source); -end; - -{Loads the chunk from a stream} -function TChunktRNS.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -var - i, Differ255: Integer; -begin - {Let inherited load} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - - if not Result then Exit; - - {Make sure size is correct} - if Size > 256 then Owner.RaiseError(EPNGInvalidPalette, - EPNGInvalidPaletteText); - - {The unset items should have value 255} - Fillchar(PaletteValues[0], 256, 255); - {Copy the other values} - CopyMemory(@PaletteValues[0], fData, Size); - - {Create the mask if needed} - case Header.ColorType of - {Mask for grayscale and RGB} - COLOR_RGB, COLOR_GRAYSCALE: fBitTransparency := True; - COLOR_PALETTE: - begin - Differ255 := 0; {Count the entries with a value different from 255} - {Tests if it uses bit transparency} - for i := 0 to Size - 1 do - if PaletteValues[i] <> 255 then inc(Differ255); - - {If it has one value different from 255 it is a bit transparency} - fBitTransparency := (Differ255 = 1); - end {COLOR_PALETTE} - end {case Header.ColorType}; - -end; - -{Prepares the image palette} -procedure TChunkIDAT.PreparePalette; -var - Entries: Word; - j : Integer; -begin - {In case the image uses grayscale, build a grayscale palette} - with Header do - if (ColorType = COLOR_GRAYSCALE) or (ColorType = COLOR_GRAYSCALEALPHA) then - begin - {Calculate total number of palette entries} - Entries := (1 shl Byte(BitmapInfo.bmiHeader.biBitCount)); - - FOR j := 0 TO Entries - 1 DO - with BitmapInfo.bmiColors[j] do - begin - - {Calculate each palette entry} - rgbRed := fOwner.GammaTable[MulDiv(j, 255, Entries - 1)]; - rgbGreen := rgbRed; - rgbBlue := rgbRed; - end {with BitmapInfo.bmiColors[j]} - end {if ColorType = COLOR_GRAYSCALE..., with Header} -end; - -{Reads from ZLIB} -function TChunkIDAT.IDATZlibRead(var ZLIBStream: TZStreamRec2; - Buffer: Pointer; Count: Integer; var EndPos: Integer; - var crcfile: Cardinal): Integer; -var - ProcResult : Integer; - IDATHeader : Array[0..3] of char; - IDATCRC : Cardinal; -begin - {Uses internal record pointed by ZLIBStream to gather information} - with ZLIBStream, ZLIBStream.zlib do - begin - {Set the buffer the zlib will read into} - next_out := Buffer; - avail_out := Count; - - {Decode until it reach the Count variable} - while avail_out > 0 do - begin - {In case it needs more data and it's in the end of a IDAT chunk,} - {it means that there are more IDAT chunks} - if (fStream.Position = EndPos) and (avail_out > 0) and - (avail_in = 0) then - begin - {End this chunk by reading and testing the crc value} - fStream.Read(IDATCRC, 4); - - {$IFDEF CheckCRC} - if crcfile xor $ffffffff <> Cardinal(ByteSwap(IDATCRC)) then - begin - Result := -1; - Owner.RaiseError(EPNGInvalidCRC, EPNGInvalidCRCText); - exit; - end; - {$ENDIF} - - {Start reading the next chunk} - fStream.Read(EndPos, 4); {Reads next chunk size} - fStream.Read(IDATHeader[0], 4); {Next chunk header} - {It must be a IDAT chunk since image data is required and PNG} - {specification says that multiple IDAT chunks must be consecutive} - if IDATHeader <> 'IDAT' then - begin - Owner.RaiseError(EPNGMissingMultipleIDAT, EPNGMissingMultipleIDATText); - result := -1; - exit; - end; - - {Calculate chunk name part of the crc} - {$IFDEF CheckCRC} - crcfile := update_crc($ffffffff, @IDATHeader[0], 4); - {$ENDIF} - EndPos := fStream.Position + ByteSwap(EndPos); - end; - - - {In case it needs compressed data to read from} - if avail_in = 0 then - begin - {In case it's trying to read more than it is avaliable} - if fStream.Position + ZLIBAllocate > EndPos then - avail_in := fStream.Read(Data^, EndPos - fStream.Position) - else - avail_in := fStream.Read(Data^, ZLIBAllocate); - {Update crc} - {$IFDEF CheckCRC} - crcfile := update_crc(crcfile, Data, avail_in); - {$ENDIF} - - {In case there is no more compressed data to read from} - if avail_in = 0 then - begin - Result := Count - avail_out; - Exit; - end; - - {Set next buffer to read and record current position} - next_in := Data; - - end {if avail_in = 0}; - - ProcResult := inflate(zlib, 0); - - {In case the result was not sucessfull} - if (ProcResult < 0) then - begin - Result := -1; - Owner.RaiseError(EPNGZLIBError, - EPNGZLIBErrorText + zliberrors[procresult]); - exit; - end; - - end {while avail_out > 0}; - - end {with}; - - {If everything gone ok, it returns the count bytes} - Result := Count; -end; - -{TChunkIDAT implementation} - -const - {Adam 7 interlacing values} - RowStart: array[0..6] of Integer = (0, 0, 4, 0, 2, 0, 1); - ColumnStart: array[0..6] of Integer = (0, 4, 0, 2, 0, 1, 0); - RowIncrement: array[0..6] of Integer = (8, 8, 8, 4, 4, 2, 2); - ColumnIncrement: array[0..6] of Integer = (8, 8, 4, 4, 2, 2, 1); - -{Copy interlaced images with 1 byte for R, G, B} -procedure TChunkIDAT.CopyInterlacedRGB8(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); - repeat - {Copy this row} - 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, 3); - inc(Dest, ColumnIncrement[Pass] * 3 - 3); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy interlaced images with 2 bytes for R, G, B} -procedure TChunkIDAT.CopyInterlacedRGB16(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); - repeat - {Copy this row} - Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); - Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := Owner.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, 6); - inc(Dest, ColumnIncrement[Pass] * 3 - 3); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy ímages with palette using bit depths 1, 4 or 8} -procedure TChunkIDAT.CopyInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: 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; - Dest2: PChar; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - repeat - {Copy data} - CurBit := StartBit[Header.BitDepth]; - repeat - {Adjust pointer to pixel byte bounds} - Dest2 := pChar(Longint(Dest) + (Header.BitDepth * Col) div 8); - {Copy data} - Byte(Dest2^) := Byte(Dest2^) or - ( ((Byte(Src^) shr CurBit) and BitTable[Header.BitDepth]) - shl (StartBit[Header.BitDepth] - (Col * Header.BitDepth mod 8))); - - {Move to next column} - inc(Col, ColumnIncrement[Pass]); - {Will read next bits} - dec(CurBit, Header.BitDepth); - until CurBit < 0; - - {Move to next byte in source} - inc(Src); - until Col >= ImageWidth; -end; - -{Copy ímages with palette using bit depth 2} -procedure TChunkIDAT.CopyInterlacedPalette2(const Pass: Byte; Src, Dest, - Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - CurBit, Col: Integer; - Dest2: PChar; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - repeat - {Copy data} - CurBit := 6; - repeat - {Adjust pointer to pixel byte bounds} - Dest2 := pChar(Longint(Dest) + Col div 2); - {Copy data} - Byte(Dest2^) := Byte(Dest2^) or (((Byte(Src^) shr CurBit) and $3) - shl (4 - (4 * Col) 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 ímages with grayscale using bit depth 2} -procedure TChunkIDAT.CopyInterlacedGray2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - CurBit, Col: Integer; - Dest2: PChar; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - repeat - {Copy data} - CurBit := 6; - repeat - {Adjust pointer to pixel byte bounds} - 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 ímages 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 := pointer(Longint(Header.ImageData) + Header.BytesPerRow * (ImageHeight - 1 - CurrentRow)); - Trans := pointer(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow); - {$IFDEF Store16bits} - Extra := pointer(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, ZLIBAllocate); - - {Restore buffer} - next_out := Data; - avail_out := ZLIBAllocate; - 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, ZLIBAllocate - avail_out); - {Re-update buffer} - next_out := Data; - avail_out := ZLIBAllocate; - end; - - if avail_out < ZLIBAllocate then - {Writes final IDAT} - WriteIDAT(fStream, Data, ZLIBAllocate - 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 := pointer(Longint(Header.ImageData) + Header.BytesPerRow * (ImageHeight - 1 - CurrentRow)); - Trans := pointer(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; - inc(PalColor); {Move to next palette entry} - 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 - {Assigns contents from another TPNGObject} - 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: Cardinal); -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); -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; - - {Transparency/palette chunks} - TransparencyChunk: TChunktRNS; - PaletteChunk: TChunkPLTE; - TransValue, PaletteIndex: Byte; - CurBit: Integer; - Data: PByte; - - {Buffer bitmap modification} - BytesPerRowDest, - BytesPerRowSrc, - BytesPerRowAlpha: Integer; - ImageSource, - AlphaSource : pByteArray; - ImageData : pPixelLine; - i, j : Integer; -begin - {Prepare to create the bitmap} - Fillchar(BitmapInfo, sizeof(BitmapInfo), #0); - BitmapInfoHeader.biWidth := Header.Width; - BitmapInfoHeader.biHeight := -1 * Header.Height; - 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} - StretchBlt(BufferDC, 0, 0, Header.Width, Header.height, DC, Rect.Left, - Rect.Top, Header.Width, Header.Height, SRCCOPY); - - {Obtain number of bytes for each row} - BytesPerRowAlpha := Header.Width; - BytesPerRowDest := (((BitmapInfo.bmiHeader.biBitCount * Width) + 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); - - case Header.BitmapInfo.bmiHeader.biBitCount of - {R, G, B images} - 24: - FOR j := 1 TO Header.Height DO - begin - {Process all the pixels in this line} - FOR i := 0 TO Header.Width - 1 DO - with ImageData[i] do - begin - rgbRed := (255+ImageSource[2+i*3] * AlphaSource[i] + rgbRed * (255 - - AlphaSource[i])) shr 8; - rgbGreen := (255+ImageSource[1+i*3] * AlphaSource[i] + rgbGreen * - (255 - AlphaSource[i])) shr 8; - rgbBlue := (255+ImageSource[i*3] * AlphaSource[i] + rgbBlue * - (255 - AlphaSource[i])) shr 8; - end; - - {Move pointers} - Longint(ImageData) := Longint(ImageData) + BytesPerRowDest; - Longint(ImageSource) := Longint(ImageSource) - BytesPerRowSrc; - Longint(AlphaSource) := Longint(AlphaSource) + BytesPerRowAlpha; - end; - {Palette images with 1 byte for each pixel} - 1,4,8: if Header.ColorType = COLOR_GRAYSCALEALPHA then - FOR j := 1 TO Header.Height DO - begin - {Process all the pixels in this line} - FOR i := 0 TO Header.Width - 1 DO - with ImageData[i], Header.BitmapInfo do begin - rgbRed := (255 + ImageSource[i] * AlphaSource[i] + - rgbRed * (255 - AlphaSource[i])) shr 8; - rgbGreen := (255 + ImageSource[i] * AlphaSource[i] + - rgbGreen * (255 - AlphaSource[i])) shr 8; - rgbBlue := (255 + ImageSource[i] * AlphaSource[i] + - rgbBlue * (255 - AlphaSource[i])) shr 8; - end; - - {Move pointers} - Longint(ImageData) := Longint(ImageData) + BytesPerRowDest; - Longint(ImageSource) := Longint(ImageSource) - BytesPerRowSrc; - Longint(AlphaSource) := Longint(AlphaSource) + BytesPerRowAlpha; - 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 Header.Height DO - begin - {Process all the pixels in this line} - i := 0; Data := @ImageSource[0]; - repeat - CurBit := 0; - - 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(Header.Width); - - {Move pointers} - Longint(ImageData) := Longint(ImageData) + BytesPerRowDest; - Longint(ImageSource) := Longint(ImageSource) - BytesPerRowSrc; - end - end {Palette images} - end {case Header.BitmapInfo.bmiHeader.biBitCount}; - - {Draws the new bitmap on the foreground} - StretchBlt(DC, Rect.Left, Rect.Top, Header.Width, Header.Height, BufferDC, - 0, 0, Header.Width, Header.Height, 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 (Chunks.Count = 0) or not (Chunks.GetItem(0) is TChunkIHDR) 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 - 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 {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 - {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); - {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}; - - {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(TChunkText) 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 - ByteData := GammaTable[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 in [0..Width - 1]) and (Y in [0..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 in [0..Width - 1]) and (Y in [0..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. - - diff --git a/Game/Code/lib/PngImage/pngimage.~pas b/Game/Code/lib/PngImage/pngimage.~pas deleted file mode 100644 index ec712737..00000000 --- a/Game/Code/lib/PngImage/pngimage.~pas +++ /dev/null @@ -1,5205 +0,0 @@ -{Portable Network Graphics Delphi 1.4361 (8 March 2003) } - -{This is the latest implementation for TPngImage component } -{It's meant to be a full replacement for the previous one. } -{There are lots of new improvements, including cleaner code, } -{full partial transparency support, speed improvements, } -{saving using ADAM 7 interlacing, better error handling, also } -{the best compression for the final image ever. And now it's } -{truly able to read about any png image. } - -{ - Version 1.4361 - 2003-03-04 - Fixed important bug for simple transparency when using - RGB, Grayscale color modes - - Version 1.436 - 2003-03-04 - * NEW * Property Pixels for direct access to pixels - * IMPROVED * Palette property (TPngObject) (read only) - Slovenian traslation for the component (Miha Petelin) - Help file update (scanline article/png->jpg example) - - Version 1.435 - 2003-11-03 - * NEW * New chunk implementation zTXt (method AddzTXt) - * NEW * New compiler flags to store the extra 8 bits - from 16 bits samples (when saving it is ignored), the - extra data may be acessed using ExtraScanline property - * Fixed * a bug on tIMe chunk - French translation included (Thanks to IBE Software) - Bugs fixed - - Version 1.432 - 2002-08-24 - * NEW * A new method, CreateAlpha will transform the - current image into partial transparency. - Help file updated with a new article on how to handle - partial transparency. - - Version 1.431 - 2002-08-14 - Fixed and tested to work on: - C++ Builder 3 - C++ Builder 5 - Delphi 3 - There was an error when setting TransparentColor, fixed - New method, RemoveTransparency to remove image - BIT TRANSPARENCY - - Version 1.43 - 2002-08-01 - * NEW * Support for Delphi 3 and C++ Builder 3 - Implements mostly some things that were missing, - a few tweaks and fixes. - - Version 1.428 - 2002-07-24 - More minor fixes (thanks to Ian Boyd) - Bit transparency fixes - * NEW * Finally support to bit transparency - (palette / rgb / grayscale -> all) - - Version 1.427 - 2002-07-19 - Lots of bugs and leaks fixed - * NEW * method to easy adding text comments, AddtEXt - * NEW * property for setting bit transparency, - TransparentColor - - Version 1.426 - 2002-07-18 - Clipboard finally fixed (hope) - Changed UseDelphi trigger to UseDelphi - * NEW * Support for bit transparency bitmaps - when assigning from/to TBitmap objects - Altough it does not support drawing transparent - parts of bit transparency pngs (only partial) - it is closer than ever - - Version 1.425 - 2002-07-01 - Clipboard methods implemented - Lots of bugs fixed - - Version 1.424 - 2002-05-16 - Scanline and AlphaScanline are now working correctly. - New methods for handling the clipboard - - Version 1.423 - 2002-05-16 - * NEW * Partial transparency for 1, 2, 4 and 8 bits is - also supported using the tRNS chunk (for palette and - grayscaling). - New bug fixes (Peter Haas). - - Version 1.422 - 2002-05-14 - Fixed some critical leaks, thanks to Peter Haas tips. - New translation for German (Peter Haas). - - Version 1.421 - 2002-05-06 - Now uses new ZLIB version, 1.1.4 with some security - fixes. - LoadFromResourceID and LoadFromResourceName added and - help file updated for that. - The resources strings are now located in pnglang.pas. - New translation for Brazilian Portuguese. - Bugs fixed. - - IMPORTANT: I'm currently looking for bugs on the library. If - anyone has found one, please send me an email and - I will fix right away. Thanks for all the help and - ideias I'm receiving so far.} - -{My new email is: gubadaud@terra.com.br} -{Website link : pngdelphi.sourceforge.net} -{Gustavo Huffenbacher Daud} - -unit pngimage; - -interface - -{Triggers avaliable (edit the fields bellow)} -{$DEFINE UseDelphi} //Disable fat vcl units (perfect to small apps) -{$DEFINE ErrorOnUnknownCritical} //Error when finds an unknown critical chunk -{$DEFINE CheckCRC} //Enables CRC checking -{$DEFINE RegisterGraphic} //Registers TPNGObject to use with TPicture -{$DEFINE PartialTransparentDraw} //Draws partial transparent images -{.$DEFINE Store16bits} //Stores the extra 8 bits from 16bits/sample -{.$DEFINE Debug} //For programming purposes -{$RANGECHECKS OFF} {$J+} - - - -uses - Windows {$IFDEF UseDelphi}, Classes, Graphics, SysUtils{$ENDIF} {$IFDEF Debug}, - dialogs{$ENDIF}, pngzlib, pnglang; - -{$IFNDEF UseDelphi} - const - soFromBeginning = 0; - soFromCurrent = 1; - soFromEnd = 2; -{$ENDIF} - -const - {ZLIB constants} - ZLIBErrors: Array[-6..2] of string = ('incompatible version (-6)', - 'buffer error (-5)', 'insufficient memory (-4)', 'data error (-3)', - 'stream error (-2)', 'file error (-1)', '(0)', 'stream end (1)', - 'need dictionary (2)'); - Z_NO_FLUSH = 0; - Z_FINISH = 4; - Z_STREAM_END = 1; - - {Avaliable PNG filters for mode 0} - FILTER_NONE = 0; - FILTER_SUB = 1; - FILTER_UP = 2; - FILTER_AVERAGE = 3; - FILTER_PAETH = 4; - - {Avaliable color modes for PNG} - COLOR_GRAYSCALE = 0; - COLOR_RGB = 2; - COLOR_PALETTE = 3; - COLOR_GRAYSCALEALPHA = 4; - COLOR_RGBALPHA = 6; - - -type - {$IFNDEF UseDelphi} - {Custom exception handler} - Exception = class(TObject) - constructor Create(Msg: String); - end; - ExceptClass = class of Exception; - TColor = ColorRef; - {$ENDIF} - - {Error types} - EPNGOutMemory = class(Exception); - EPngError = class(Exception); - EPngUnexpectedEnd = class(Exception); - EPngInvalidCRC = class(Exception); - EPngInvalidIHDR = class(Exception); - EPNGMissingMultipleIDAT = class(Exception); - EPNGZLIBError = class(Exception); - EPNGInvalidPalette = class(Exception); - EPNGInvalidFileHeader = class(Exception); - EPNGIHDRNotFirst = class(Exception); - EPNGNotExists = class(Exception); - EPNGSizeExceeds = class(Exception); - EPNGMissingPalette = class(Exception); - EPNGUnknownCriticalChunk = class(Exception); - EPNGUnknownCompression = class(Exception); - EPNGUnknownInterlace = class(Exception); - EPNGNoImageData = class(Exception); - EPNGCouldNotLoadResource = class(Exception); - EPNGCannotChangeTransparent = class(Exception); - EPNGHeaderNotPresent = class(Exception); - -type - {Direct access to pixels using R,G,B} - TRGBLine = array[word] of TRGBTriple; - pRGBLine = ^TRGBLine; - - {Same as TBitmapInfo but with allocated space for} - {palette entries} - TMAXBITMAPINFO = packed record - bmiHeader: TBitmapInfoHeader; - bmiColors: packed array[0..255] of TRGBQuad; - end; - - {Transparency mode for pngs} - TPNGTransparencyMode = (ptmNone, ptmBit, ptmPartial); - {Pointer to a cardinal type} - pCardinal = ^Cardinal; - {Access to a rgb pixel} - pRGBPixel = ^TRGBPixel; - TRGBPixel = packed record - B, G, R: Byte; - end; - - {Pointer to an array of bytes type} - TByteArray = Array[Word] of Byte; - pByteArray = ^TByteArray; - - {Forward} - TPNGObject = class; - pPointerArray = ^TPointerArray; - TPointerArray = Array[Word] of Pointer; - - {Contains a list of objects} - TPNGPointerList = class - private - fOwner: TPNGObject; - fCount : Cardinal; - fMemory: pPointerArray; - function GetItem(Index: Cardinal): Pointer; - procedure SetItem(Index: Cardinal; const Value: Pointer); - protected - {Removes an item} - function Remove(Value: Pointer): Pointer; virtual; - {Inserts an item} - procedure Insert(Value: Pointer; Position: Cardinal); - {Add a new item} - procedure Add(Value: Pointer); - {Returns an item} - property Item[Index: Cardinal]: Pointer read GetItem write SetItem; - {Set the size of the list} - procedure SetSize(const Size: Cardinal); - {Returns owner} - property Owner: TPNGObject read fOwner; - public - {Returns number of items} - property Count: Cardinal read fCount write SetSize; - {Object being either created or destroyed} - constructor Create(AOwner: TPNGObject); - destructor Destroy; override; - end; - - {Forward declaration} - TChunk = class; - TChunkClass = class of TChunk; - - {Same as TPNGPointerList but providing typecasted values} - TPNGList = class(TPNGPointerList) - private - {Used with property Item} - function GetItem(Index: Cardinal): TChunk; - public - {Removes an item} - procedure RemoveChunk(Chunk: TChunk); overload; - {Add a new chunk using the class from the parameter} - function Add(ChunkClass: TChunkClass): TChunk; - {Returns pointer to the first chunk of class} - function ItemFromClass(ChunkClass: TChunkClass): TChunk; - {Returns a chunk item from the list} - property Item[Index: Cardinal]: TChunk read GetItem; - end; - - {$IFNDEF UseDelphi} - {The STREAMs bellow are only needed in case delphi provided ones is not} - {avaliable (UseDelphi trigger not set)} - {Object becomes handles} - TCanvas = THandle; - TBitmap = HBitmap; - {Trick to work} - TPersistent = TObject; - - {Base class for all streams} - TStream = class - protected - {Returning/setting size} - function GetSize: Longint; virtual; - procedure SetSize(const Value: Longint); virtual; abstract; - {Returns/set position} - function GetPosition: Longint; virtual; - procedure SetPosition(const Value: Longint); virtual; - public - {Returns/sets current position} - property Position: Longint read GetPosition write SetPosition; - {Property returns/sets size} - property Size: Longint read GetSize write SetSize; - {Allows reading/writing data} - function Read(var Buffer; Count: Longint): Cardinal; virtual; abstract; - function Write(const Buffer; Count: Longint): Cardinal; virtual; abstract; - {Copies from another Stream} - function CopyFrom(Source: TStream; - Count: Cardinal): Cardinal; virtual; - {Seeks a stream position} - function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract; - end; - - {File stream modes} - TFileStreamMode = (fsmRead, fsmWrite, fsmCreate); - TFileStreamModeSet = set of TFileStreamMode; - - {File stream for reading from files} - TFileStream = class(TStream) - private - {Opened mode} - Filemode: TFileStreamModeSet; - {Handle} - fHandle: THandle; - protected - {Set the size of the file} - procedure SetSize(const Value: Longint); override; - public - {Seeks a file position} - function Seek(Offset: Longint; Origin: Word): Longint; override; - {Reads/writes data from/to the file} - function Read(var Buffer; Count: Longint): Cardinal; override; - function Write(const Buffer; Count: Longint): Cardinal; override; - {Stream being created and destroy} - constructor Create(Filename: String; Mode: TFileStreamModeSet); - destructor Destroy; override; - end; - - {Stream for reading from resources} - TResourceStream = class(TStream) - constructor Create(Instance: HInst; const ResName: String; ResType:PChar); - private - {Variables for reading} - Size: Integer; - Memory: Pointer; - Position: Integer; - protected - {Set the size of the file} - procedure SetSize(const Value: Longint); override; - public - {Stream processing} - function Read(var Buffer; Count: Integer): Cardinal; override; - function Seek(Offset: Integer; Origin: Word): Longint; override; - function Write(const Buffer; Count: Longint): Cardinal; override; - end; - {$ENDIF} - - {Forward} - TChunkIHDR = class; - {Interlace method} - TInterlaceMethod = (imNone, imAdam7); - {Compression level type} - TCompressionLevel = 0..9; - {Filters type} - TFilter = (pfNone, pfSub, pfUp, pfAverage, pfPaeth); - TFilters = set of TFilter; - - {Png implementation object} - TPngObject = class{$IFDEF UseDelphi}(TGraphic){$ENDIF} - protected - {Gamma table values} - GammaTable, InverseGamma: Array[Byte] of Byte; - procedure InitializeGamma; - private - {Temporary palette} - TempPalette: HPalette; - {Filters to test to encode} - fFilters: TFilters; - {Compression level for ZLIB} - fCompressionLevel: TCompressionLevel; - {Maximum size for IDAT chunks} - fMaxIdatSize: Cardinal; - {Returns if image is interlaced} - fInterlaceMethod: TInterlaceMethod; - {Chunks object} - fChunkList: TPngList; - {Clear all chunks in the list} - procedure ClearChunks; - {Returns if header is present} - function HeaderPresent: Boolean; - {Returns linesize and byte offset for pixels} - procedure GetPixelInfo(var LineSize, Offset: Cardinal); - procedure SetMaxIdatSize(const Value: Cardinal); - function GetAlphaScanline(const LineIndex: Integer): pByteArray; - function GetScanline(const LineIndex: Integer): Pointer; - {$IFDEF Store16bits} - function GetExtraScanline(const LineIndex: Integer): Pointer; - {$ENDIF} - function GetTransparencyMode: TPNGTransparencyMode; - function GetTransparentColor: TColor; - procedure SetTransparentColor(const Value: TColor); - protected - {Returns the image palette} - function GetPalette: HPALETTE; {$IFDEF UseDelphi}override;{$ENDIF} - {Returns/sets image width and height} - function GetWidth: Integer; {$IFDEF UseDelphi}override;{$ENDIF} - function GetHeight: Integer; {$IFDEF UseDelphi}override; {$ENDIF} - procedure SetWidth(Value: Integer); {$IFDEF UseDelphi}override; {$ENDIF} - procedure SetHeight(Value: Integer); {$IFDEF UseDelphi}override;{$ENDIF} - {Assigns from another TPNGObject} - procedure AssignPNG(Source: TPNGObject); - {Returns if the image is empty} - function GetEmpty: Boolean; {$IFDEF UseDelphi}override; {$ENDIF} - {Used with property Header} - function GetHeader: TChunkIHDR; - {Draws using partial transparency} - procedure DrawPartialTrans(DC: HDC; Rect: TRect); - {$IFDEF UseDelphi} - {Returns if the image is transparent} - function GetTransparent: Boolean; override; - {$ENDIF} - {Returns a pixel} - function GetPixels(const X, Y: Integer): TColor; virtual; - procedure SetPixels(const X, Y: Integer; const Value: TColor); virtual; - public - {Generates alpha information} - procedure CreateAlpha; - {Removes the image transparency} - procedure RemoveTransparency; - {Transparent color} - property TransparentColor: TColor read GetTransparentColor write - SetTransparentColor; - {Add text chunk, TChunkTEXT, TChunkzTXT} - procedure AddtEXt(const Keyword, Text: String); - procedure AddzTXt(const Keyword, Text: String); - {$IFDEF UseDelphi} - {Saves to clipboard format (thanks to Antoine Pottern)} - procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; - var APalette: HPalette); override; - procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; - APalette: HPalette); override; - {$ENDIF} - {Calling errors} - procedure RaiseError(ExceptionClass: ExceptClass; Text: String); - {Returns a scanline from png} - property Scanline[const Index: Integer]: Pointer read GetScanline; - {$IFDEF Store16bits} - property ExtraScanline[const Index: Integer]: Pointer read GetExtraScanline; - {$ENDIF} - property AlphaScanline[const Index: Integer]: pByteArray read GetAlphaScanline; - {Returns pointer to the header} - property Header: TChunkIHDR read GetHeader; - {Returns the transparency mode used by this png} - property TransparencyMode: TPNGTransparencyMode read GetTransparencyMode; - {Assigns from another object} - procedure Assign(Source: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF} - {Assigns to another object} - procedure AssignTo(Dest: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF} - {Assigns from a windows bitmap handle} - procedure AssignHandle(Handle: HBitmap; Transparent: Boolean; - TransparentColor: ColorRef); - {Draws the image into a canvas} - procedure Draw(ACanvas: TCanvas; const Rect: TRect); - {$IFDEF UseDelphi}override;{$ENDIF} - {Width and height properties} - property Width: Integer read GetWidth; - property Height: Integer read GetHeight; - {Returns if the image is interlaced} - property InterlaceMethod: TInterlaceMethod read fInterlaceMethod - write fInterlaceMethod; - {Filters to test to encode} - property Filters: TFilters read fFilters write fFilters; - {Maximum size for IDAT chunks, default and minimum is 65536} - property MaxIdatSize: Cardinal read fMaxIdatSize write SetMaxIdatSize; - {Property to return if the image is empty or not} - property Empty: Boolean read GetEmpty; - {Compression level} - property CompressionLevel: TCompressionLevel read fCompressionLevel - write fCompressionLevel; - {Access to the chunk list} - property Chunks: TPngList read fChunkList; - {Object being created and destroyed} - constructor Create; {$IFDEF UseDelphi}override;{$ENDIF} - destructor Destroy; override; - {$IFNDEF UseDelphi}procedure LoadFromFile(const Filename: String);{$ENDIF} - {$IFNDEF UseDelphi}procedure SaveToFile(const Filename: String);{$ENDIF} - procedure LoadFromStream(Stream: TStream); {$IFDEF UseDelphi}override;{$ENDIF} - procedure SaveToStream(Stream: TStream); {$IFDEF UseDelphi}override;{$ENDIF} - {Loading the image from resources} - procedure LoadFromResourceName(Instance: HInst; const Name: String); - procedure LoadFromResourceID(Instance: HInst; ResID: Integer); - {Access to the png pixels} - property Pixels[const X, Y: Integer]: TColor read GetPixels write SetPixels; - {Palette property} - {$IFNDEF UseDelphi}property Palette: HPalette read GetPalette;{$ENDIF} - end; - - {Chunk name object} - TChunkName = Array[0..3] of Char; - - {Global chunk object} - TChunk = class - private - {Contains data} - fData: Pointer; - fDataSize: Cardinal; - {Stores owner} - fOwner: TPngObject; - {Stores the chunk name} - fName: TChunkName; - {Returns pointer to the TChunkIHDR} - function GetHeader: TChunkIHDR; - {Used with property index} - function GetIndex: Integer; - {Should return chunk class/name} - class function GetName: String; virtual; - {Returns the chunk name} - function GetChunkName: String; - public - {Returns index from list} - property Index: Integer read GetIndex; - {Returns pointer to the TChunkIHDR} - property Header: TChunkIHDR read GetHeader; - {Resize the data} - procedure ResizeData(const NewSize: Cardinal); - {Returns data and size} - property Data: Pointer read fData; - property DataSize: Cardinal read fDataSize; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); virtual; - {Returns owner} - property Owner: TPngObject read fOwner; - {Being destroyed/created} - constructor Create(Owner: TPngObject); virtual; - destructor Destroy; override; - {Returns chunk class/name} - property Name: String read GetChunkName; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; virtual; - {Saves the chunk to a stream} - function SaveData(Stream: TStream): Boolean; - function SaveToStream(Stream: TStream): Boolean; virtual; - end; - - {Chunk classes} - TChunkIEND = class(TChunk); {End chunk} - - {IHDR data} - pIHDRData = ^TIHDRData; - TIHDRData = packed record - Width, Height: Cardinal; - BitDepth, - ColorType, - CompressionMethod, - FilterMethod, - InterlaceMethod: Byte; - end; - - {Information header chunk} - TChunkIHDR = class(TChunk) - private - {Current image} - ImageHandle: HBitmap; - ImageDC: HDC; - - {Output windows bitmap} - HasPalette: Boolean; - BitmapInfo: TMaxBitmapInfo; - BytesPerRow: Integer; - {Stores the image bytes} - {$IFDEF Store16bits}ExtraImageData: Pointer;{$ENDIF} - ImageData: pointer; - ImageAlpha: Pointer; - - {Contains all the ihdr data} - IHDRData: TIHDRData; - protected - {Resizes the image data to fill the color type, bit depth, } - {width and height parameters} - procedure PrepareImageData; - {Release allocated ImageData memory} - procedure FreeImageData; - public - {Properties} - property Width: Cardinal read IHDRData.Width write IHDRData.Width; - property Height: Cardinal read IHDRData.Height write IHDRData.Height; - property BitDepth: Byte read IHDRData.BitDepth write IHDRData.BitDepth; - property ColorType: Byte read IHDRData.ColorType write IHDRData.ColorType; - property CompressionMethod: Byte read IHDRData.CompressionMethod - write IHDRData.CompressionMethod; - property FilterMethod: Byte read IHDRData.FilterMethod - write IHDRData.FilterMethod; - property InterlaceMethod: Byte read IHDRData.InterlaceMethod - write IHDRData.InterlaceMethod; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Destructor/constructor} - constructor Create(Owner: TPngObject); override; - destructor Destroy; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {Gamma chunk} - TChunkgAMA = class(TChunk) - private - {Returns/sets the value for the gamma chunk} - function GetValue: Cardinal; - procedure SetValue(const Value: Cardinal); - public - {Returns/sets gamma value} - property Gamma: Cardinal read GetValue write SetValue; - {Loading the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Being created} - constructor Create(Owner: TPngObject); override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {ZLIB Decompression extra information} - TZStreamRec2 = packed record - {From ZLIB} - ZLIB: TZStreamRec; - {Additional info} - Data: Pointer; - fStream : TStream; - end; - - {Palette chunk} - TChunkPLTE = class(TChunk) - private - {Number of items in the palette} - fCount: Integer; - {Contains the palette handle} - function GetPaletteItem(Index: Byte): TRGBQuad; - public - {Returns the color for each item in the palette} - property Item[Index: Byte]: TRGBQuad read GetPaletteItem; - {Returns the number of items in the palette} - property Count: Integer read fCount; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {Transparency information} - TChunktRNS = class(TChunk) - private - fBitTransparency: Boolean; - function GetTransparentColor: ColorRef; - {Returns the transparent color} - procedure SetTransparentColor(const Value: ColorRef); - public - {Palette values for transparency} - PaletteValues: Array[Byte] of Byte; - {Returns if it uses bit transparency} - property BitTransparency: Boolean read fBitTransparency; - {Returns the transparent color} - property TransparentColor: ColorRef read GetTransparentColor write - SetTransparentColor; - {Loads/saves the chunk from/to a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {Actual image information} - TChunkIDAT = class(TChunk) - private - {Holds another pointer to the TChunkIHDR} - Header: TChunkIHDR; - {Stores temporary image width and height} - ImageWidth, ImageHeight: Integer; - {Size in bytes of each line and offset} - Row_Bytes, Offset : Cardinal; - {Contains data for the lines} - Encode_Buffer: Array[0..5] of pByteArray; - Row_Buffer: Array[Boolean] of pByteArray; - {Variable to invert the Row_Buffer used} - RowUsed: Boolean; - {Ending position for the current IDAT chunk} - EndPos: Integer; - {Filter the current line} - procedure FilterRow; - {Filter to encode and returns the best filter} - function FilterToEncode: Byte; - {Reads ZLIB compressed data} - function IDATZlibRead(var ZLIBStream: TZStreamRec2; Buffer: Pointer; - Count: Integer; var EndPos: Integer; var crcfile: Cardinal): Integer; - {Compress and writes IDAT data} - procedure IDATZlibWrite(var ZLIBStream: TZStreamRec2; Buffer: Pointer; - const Length: Cardinal); - procedure FinishIDATZlib(var ZLIBStream: TZStreamRec2); - {Prepares the palette} - procedure PreparePalette; - protected - {Decode interlaced image} - procedure DecodeInterlacedAdam7(Stream: TStream; - var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); - {Decode non interlaced imaged} - procedure DecodeNonInterlaced(Stream: TStream; - var ZLIBStream: TZStreamRec2; const Size: Integer; - var crcfile: Cardinal); - protected - {Encode non interlaced images} - procedure EncodeNonInterlaced(Stream: TStream; - var ZLIBStream: TZStreamRec2); - {Encode interlaced images} - procedure EncodeInterlacedAdam7(Stream: TStream; - var ZLIBStream: TZStreamRec2); - protected - {Memory copy methods to decode} - procedure CopyNonInterlacedRGB8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedRGB16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedPalette148( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedPalette2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGray2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGrayscale16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedRGBAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedRGBAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGrayscaleAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyNonInterlacedGrayscaleAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGB8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGB16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedPalette2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGray2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - procedure CopyInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); - protected - {Memory copy methods to encode} - procedure EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedGrayscaleAlpha8(Src, Dest, Trans: pChar); - procedure EncodeNonInterlacedGrayscaleAlpha16(Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGB8(const Pass: Byte; Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGB16(const Pass: Byte; Src, Dest, Trans: pChar); - procedure EncodeInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans: pChar); - procedure EncodeInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans: pChar); - public - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - end; - - {Image last modification chunk} - TChunktIME = class(TChunk) - private - {Holds the variables} - fYear: Word; - fMonth, fDay, fHour, fMinute, fSecond: Byte; - public - {Returns/sets variables} - property Year: Word read fYear write fYear; - property Month: Byte read fMonth write fMonth; - property Day: Byte read fDay write fDay; - property Hour: Byte read fHour write fHour; - property Minute: Byte read fMinute write fMinute; - property Second: Byte read fSecond write fSecond; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - end; - - {Textual data} - TChunktEXt = class(TChunk) - private - fKeyword, fText: String; - public - {Keyword and text} - property Keyword: String read fKeyword write fKeyword; - property Text: String read fText write fText; - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - {Assigns from another TChunk} - procedure Assign(Source: TChunk); override; - end; - - {zTXT chunk} - TChunkzTXt = class(TChunktEXt) - {Loads the chunk from a stream} - function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; override; - {Saves the chunk to a stream} - function SaveToStream(Stream: TStream): Boolean; override; - end; - -{Here we test if it's c++ builder or delphi version 3 or less} -{$IFDEF VER110}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER100}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER93}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER90}{$DEFINE DelphiBuilder3Less}{$ENDIF} -{$IFDEF VER80}{$DEFINE DelphiBuilder3Less}{$ENDIF} - - -{Registers a new chunk class} -procedure RegisterChunk(ChunkClass: TChunkClass); -{Calculates crc} -function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer - {$ENDIF}; buf: pByteArray; len: Integer): Cardinal; -{Invert bytes using assembly} -function ByteSwap(const a: integer): integer; - -implementation - -var - ChunkClasses: TPngPointerList; - {Table of CRCs of all 8-bit messages} - crc_table: Array[0..255] of Cardinal; - {Flag: has the table been computed? Initially false} - crc_table_computed: Boolean; - -{Draw transparent image using transparent color} -procedure DrawTransparentBitmap(dc: HDC; srcBits: Pointer; - var srcHeader: TBitmapInfoHeader; - srcBitmapInfo: pBitmapInfo; Rect: TRect; cTransparentColor: COLORREF); -var - cColor: COLORREF; - bmAndBack, bmAndObject, bmAndMem: HBITMAP; - bmBackOld, bmObjectOld, bmMemOld: HBITMAP; - hdcMem, hdcBack, hdcObject, hdcTemp: HDC; - ptSize, orgSize: TPOINT; - OldBitmap, DrawBitmap: HBITMAP; -begin - hdcTemp := CreateCompatibleDC(dc); - // Select the bitmap - DrawBitmap := CreateDIBitmap(dc, srcHeader, CBM_INIT, srcBits, srcBitmapInfo^, - DIB_RGB_COLORS); - OldBitmap := SelectObject(hdcTemp, DrawBitmap); - - // Sizes - OrgSize.x := abs(srcHeader.biWidth); - OrgSize.y := abs(srcHeader.biHeight); - ptSize.x := Rect.Right - Rect.Left; // Get width of bitmap - ptSize.y := Rect.Bottom - Rect.Top; // Get height of bitmap - - // Create some DCs to hold temporary data. - hdcBack := CreateCompatibleDC(dc); - hdcObject := CreateCompatibleDC(dc); - hdcMem := CreateCompatibleDC(dc); - - // Create a bitmap for each DC. DCs are required for a number of - // GDI functions. - - // Monochrome DCs - bmAndBack := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); - bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); - - bmAndMem := CreateCompatibleBitmap(dc, ptSize.x, ptSize.y); - - // Each DC must select a bitmap object to store pixel data. - bmBackOld := SelectObject(hdcBack, bmAndBack); - bmObjectOld := SelectObject(hdcObject, bmAndObject); - bmMemOld := SelectObject(hdcMem, bmAndMem); - - // Set the background color of the source DC to the color. - // contained in the parts of the bitmap that should be transparent - cColor := SetBkColor(hdcTemp, cTransparentColor); - - // Create the object mask for the bitmap by performing a BitBlt - // from the source bitmap to a monochrome bitmap. - StretchBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, - orgSize.x, orgSize.y, SRCCOPY); - - // Set the background color of the source DC back to the original - // color. - SetBkColor(hdcTemp, cColor); - - // Create the inverse of the object mask. - BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, - NOTSRCCOPY); - - // Copy the background of the main DC to the destination. - BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, dc, Rect.Left, Rect.Top, - SRCCOPY); - - // Mask out the places where the bitmap will be placed. - BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND); - - // Mask out the transparent colored pixels on the bitmap. -// BitBlt(hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND); - StretchBlt(hdcTemp, 0, 0, OrgSize.x, OrgSize.y, hdcBack, 0, 0, - PtSize.x, PtSize.y, SRCAND); - - // XOR the bitmap with the background on the destination DC. - StretchBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, - OrgSize.x, OrgSize.y, SRCPAINT); - - // Copy the destination to the screen. - BitBlt(dc, Rect.Left, Rect.Top, ptSize.x, ptSize.y, hdcMem, 0, 0, - SRCCOPY); - - // Delete the memory bitmaps. - DeleteObject(SelectObject(hdcBack, bmBackOld)); - DeleteObject(SelectObject(hdcObject, bmObjectOld)); - DeleteObject(SelectObject(hdcMem, bmMemOld)); - DeleteObject(SelectObject(hdcTemp, OldBitmap)); - - // Delete the memory DCs. - DeleteDC(hdcMem); - DeleteDC(hdcBack); - DeleteDC(hdcObject); - DeleteDC(hdcTemp); -end; - -{Make the table for a fast CRC.} -procedure make_crc_table; -var - c: Cardinal; - n, k: Integer; -begin - - {fill the crc table} - for n := 0 to 255 do - begin - c := Cardinal(n); - for k := 0 to 7 do - begin - if Boolean(c and 1) then - c := $edb88320 xor (c shr 1) - else - c := c shr 1; - end; - crc_table[n] := c; - end; - - {The table has already being computated} - crc_table_computed := true; -end; - -{Update a running CRC with the bytes buf[0..len-1]--the CRC - should be initialized to all 1's, and the transmitted value - is the 1's complement of the final running CRC (see the - crc() routine below)).} -function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer - {$ENDIF}; buf: pByteArray; len: Integer): Cardinal; -var - c: Cardinal; - n: Integer; -begin - c := crc; - - {Create the crc table in case it has not being computed yet} - if not crc_table_computed then make_crc_table; - - {Update} - for n := 0 to len - 1 do - c := crc_table[(c XOR buf^[n]) and $FF] XOR (c shr 8); - - {Returns} - Result := c; -end; - -{$IFNDEF UseDelphi} - function FileExists(Filename: String): Boolean; - var - FindFile: THandle; - FindData: TWin32FindData; - begin - FindFile := FindFirstFile(PChar(Filename), FindData); - Result := FindFile <> INVALID_HANDLE_VALUE; - if Result then Windows.FindClose(FindFile); - end; - - -{$ENDIF} - -{$IFNDEF UseDelphi} - {Exception implementation} - constructor Exception.Create(Msg: String); - begin - end; -{$ENDIF} - -{Calculates the paeth predictor} -function PaethPredictor(a, b, c: Byte): Byte; -var - pa, pb, pc: Integer; -begin - { a = left, b = above, c = upper left } - pa := abs(b - c); { distances to a, b, c } - pb := abs(a - c); - pc := abs(a + b - c * 2); - - { return nearest of a, b, c, breaking ties in order a, b, c } - if (pa <= pb) and (pa <= pc) then - Result := a - else - if pb <= pc then - Result := b - else - Result := c; -end; - -{Invert bytes using assembly} -function ByteSwap(const a: integer): integer; -asm - bswap eax -end; -function ByteSwap16(inp:word): word; -asm - bswap eax - shr eax, 16 -end; - -{Calculates number of bytes for the number of pixels using the} -{color mode in the paramenter} -function BytesForPixels(const Pixels: Integer; const ColorType, - BitDepth: Byte): Integer; -begin - case ColorType of - {Palette and grayscale contains a single value, for palette} - {an value of size 2^bitdepth pointing to the palette index} - {and grayscale the value from 0 to 2^bitdepth with color intesity} - COLOR_GRAYSCALE, COLOR_PALETTE: - Result := (Pixels * BitDepth + 7) div 8; - {RGB contains 3 values R, G, B with size 2^bitdepth each} - COLOR_RGB: - Result := (Pixels * BitDepth * 3) div 8; - {Contains one value followed by alpha value booth size 2^bitdepth} - COLOR_GRAYSCALEALPHA: - Result := (Pixels * BitDepth * 2) div 8; - {Contains four values size 2^bitdepth, Red, Green, Blue and alpha} - COLOR_RGBALPHA: - Result := (Pixels * BitDepth * 4) div 8; - else - Result := 0; - end {case ColorType} -end; - -type - pChunkClassInfo = ^TChunkClassInfo; - TChunkClassInfo = record - ClassName: TChunkClass; - end; - -{Register a chunk type} -procedure RegisterChunk(ChunkClass: TChunkClass); -var - NewClass: pChunkClassInfo; -begin - {In case the list object has not being created yet} - if ChunkClasses = nil then ChunkClasses := TPngPointerList.Create(nil); - - {Add this new class} - new(NewClass); - NewClass^.ClassName := ChunkClass; - ChunkClasses.Add(NewClass); -end; - -{Free chunk class list} -procedure FreeChunkClassList; -var - i: Integer; -begin - if (ChunkClasses <> nil) then - begin - FOR i := 0 TO ChunkClasses.Count - 1 do - Dispose(pChunkClassInfo(ChunkClasses.Item[i])); - ChunkClasses.Free; - end; -end; - -{Registering of common chunk classes} -procedure RegisterCommonChunks; -begin - {Important chunks} - RegisterChunk(TChunkIEND); - RegisterChunk(TChunkIHDR); - RegisterChunk(TChunkIDAT); - RegisterChunk(TChunkPLTE); - RegisterChunk(TChunkgAMA); - RegisterChunk(TChunktRNS); - - {Not so important chunks} - RegisterChunk(TChunktIME); - RegisterChunk(TChunktEXt); - RegisterChunk(TChunkzTXt); -end; - -{Creates a new chunk of this class} -function CreateClassChunk(Owner: TPngObject; Name: TChunkName): TChunk; -var - i : Integer; - NewChunk: TChunkClass; -begin - {Looks for this chunk} - NewChunk := TChunk; {In case there is no registered class for this} - - {Looks for this class in all registered chunks} - if Assigned(ChunkClasses) then - FOR i := 0 TO ChunkClasses.Count - 1 DO - begin - if pChunkClassInfo(ChunkClasses.Item[i])^.ClassName.GetName = Name then - begin - NewChunk := pChunkClassInfo(ChunkClasses.Item[i])^.ClassName; - break; - end; - end; - - {Returns chunk class} - Result := NewChunk.Create(Owner); - Result.fName := Name; -end; - -{ZLIB support} - -const - ZLIBAllocate = High(Word); - -{Initializes ZLIB for decompression} -function ZLIBInitInflate(Stream: TStream): TZStreamRec2; -begin - {Fill record} - Fillchar(Result, SIZEOF(TZStreamRec2), #0); - - {Set internal record information} - with Result do - begin - GetMem(Data, ZLIBAllocate); - fStream := Stream; - end; - - {Init decompression} - InflateInit_(Result.zlib, zlib_version, SIZEOF(TZStreamRec)); -end; - -{Initializes ZLIB for compression} -function ZLIBInitDeflate(Stream: TStream; - Level: TCompressionlevel; Size: Cardinal): TZStreamRec2; -begin - {Fill record} - Fillchar(Result, SIZEOF(TZStreamRec2), #0); - - {Set internal record information} - with Result, ZLIB do - begin - GetMem(Data, Size); - fStream := Stream; - next_out := Data; - avail_out := Size; - end; - - {Inits compression} - deflateInit_(Result.zlib, Level, zlib_version, sizeof(TZStreamRec)); -end; - -{Terminates ZLIB for compression} -procedure ZLIBTerminateDeflate(var ZLIBStream: TZStreamRec2); -begin - {Terminates decompression} - DeflateEnd(ZLIBStream.zlib); - {Free internal record} - FreeMem(ZLIBStream.Data, ZLIBAllocate); -end; - -{Terminates ZLIB for decompression} -procedure ZLIBTerminateInflate(var ZLIBStream: TZStreamRec2); -begin - {Terminates decompression} - InflateEnd(ZLIBStream.zlib); - {Free internal record} - FreeMem(ZLIBStream.Data, ZLIBAllocate); -end; - -{Decompresses ZLIB into a memory address} -function DecompressZLIB(const Input: Pointer; InputSize: Integer; - var Output: Pointer; var OutputSize: Integer; - var ErrorOutput: String): Boolean; -var - StreamRec : TZStreamRec; - Buffer : Array[Byte] of Byte; - InflateRet: Integer; -begin - with StreamRec do - begin - {Initializes} - Result := True; - OutputSize := 0; - - {Prepares the data to decompress} - FillChar(StreamRec, SizeOf(TZStreamRec), #0); - InflateInit_(StreamRec, zlib_version, SIZEOF(TZStreamRec)); - next_in := Input; - avail_in := InputSize; - - {Decodes data} - repeat - {In case it needs an output buffer} - if (avail_out = 0) then - begin - next_out := @Buffer; - avail_out := SizeOf(Buffer); - end {if (avail_out = 0)}; - - {Decompress and put in output} - InflateRet := inflate(StreamRec, 0); - if (InflateRet = Z_STREAM_END) or (InflateRet = 0) then - begin - {Reallocates output buffer} - inc(OutputSize, total_out); - if Output = nil then - GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize); - {Copies the new data} - CopyMemory(Ptr(Longint(Output) + OutputSize - total_out), - @Buffer, total_out); - end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)} - {Now tests for errors} - else if InflateRet < 0 then - begin - Result := False; - ErrorOutput := StreamRec.msg; - InflateEnd(StreamRec); - Exit; - end {if InflateRet < 0} - until InflateRet = Z_STREAM_END; - - {Terminates decompression} - InflateEnd(StreamRec); - end {with StreamRec} - -end; - -{Compresses ZLIB into a memory address} -function CompressZLIB(Input: Pointer; InputSize, CompressionLevel: Integer; - var Output: Pointer; var OutputSize: Integer; - var ErrorOutput: String): Boolean; -var - StreamRec : TZStreamRec; - Buffer : Array[Byte] of Byte; - DeflateRet: Integer; -begin - with StreamRec do - begin - Result := True; {By default returns TRUE as everything might have gone ok} - OutputSize := 0; {Initialize} - {Prepares the data to compress} - FillChar(StreamRec, SizeOf(TZStreamRec), #0); - DeflateInit_(StreamRec, CompressionLevel,zlib_version, SIZEOF(TZStreamRec)); - - next_in := Input; - avail_in := InputSize; - - while avail_in > 0 do - begin - {When it needs new buffer to stores the compressed data} - if avail_out = 0 then - begin - {Restore buffer} - next_out := @Buffer; - avail_out := SizeOf(Buffer); - end {if avail_out = 0}; - - {Compresses} - DeflateRet := deflate(StreamRec, Z_FINISH); - - if (DeflateRet = Z_STREAM_END) or (DeflateRet = 0) then - begin - {Updates the output memory} - inc(OutputSize, total_out); - if Output = nil then - GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize); - - {Copies the new data} - CopyMemory(Ptr(Longint(Output) + OutputSize - total_out), - @Buffer, total_out); - end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)} - {Now tests for errors} - else if DeflateRet < 0 then - begin - Result := False; - ErrorOutput := StreamRec.msg; - DeflateEnd(StreamRec); - Exit; - end {if InflateRet < 0} - - end {while avail_in > 0}; - - {Finishes compressing} - DeflateEnd(StreamRec); - end {with StreamRec} - -end; - -{TPngPointerList implementation} - -{Object being created} -constructor TPngPointerList.Create(AOwner: TPNGObject); -begin - inherited Create; {Let ancestor work} - {Holds owner} - fOwner := AOwner; - {Memory pointer not being used yet} - fMemory := nil; - {No items yet} - fCount := 0; -end; - -{Removes value from the list} -function TPngPointerList.Remove(Value: Pointer): Pointer; -var - I, Position: Integer; -begin - {Gets item position} - Position := -1; - FOR I := 0 TO Count - 1 DO - if Value = Item[I] then Position := I; - {In case a match was found} - if Position >= 0 then - begin - Result := Item[Position]; {Returns pointer} - {Remove item and move memory} - Dec(fCount); - if Position < Integer(FCount) then - System.Move(fMemory^[Position + 1], fMemory^[Position], - (Integer(fCount) - Position) * SizeOf(Pointer)); - end {if Position >= 0} else Result := nil -end; - -{Add a new value in the list} -procedure TPngPointerList.Add(Value: Pointer); -begin - Count := Count + 1; - Item[Count - 1] := Value; -end; - - -{Object being destroyed} -destructor TPngPointerList.Destroy; -begin - {Release memory if needed} - if fMemory <> nil then - FreeMem(fMemory, fCount * sizeof(Pointer)); - - {Free things} - inherited Destroy; -end; - -{Returns one item from the list} -function TPngPointerList.GetItem(Index: Cardinal): Pointer; -begin - if (Index <= Count - 1) then - Result := fMemory[Index] - else - {In case it's out of bounds} - Result := nil; -end; - -{Inserts a new item in the list} -procedure TPngPointerList.Insert(Value: Pointer; Position: Cardinal); -begin - if (Position < Count) then - begin - {Increase item count} - SetSize(Count + 1); - {Move other pointers} - if Position < Count then - System.Move(fMemory^[Position], fMemory^[Position + 1], - (Count - Position - 1) * SizeOf(Pointer)); - {Sets item} - Item[Position] := Value; - end; -end; - -{Sets one item from the list} -procedure TPngPointerList.SetItem(Index: Cardinal; const Value: Pointer); -begin - {If index is in bounds, set value} - if (Index <= Count - 1) then - fMemory[Index] := Value -end; - -{This method resizes the list} -procedure TPngPointerList.SetSize(const Size: Cardinal); -begin - {Sets the size} - if (fMemory = nil) and (Size > 0) then - GetMem(fMemory, Size * SIZEOF(Pointer)) - else - if Size > 0 then {Only realloc if the new size is greater than 0} - ReallocMem(fMemory, Size * SIZEOF(Pointer)) - else - {In case user is resize to 0 items} - begin - FreeMem(fMemory); - fMemory := nil; - end; - {Update count} - fCount := Size; -end; - -{TPNGList implementation} - -{Removes an item} -procedure TPNGList.RemoveChunk(Chunk: TChunk); -begin - Remove(Chunk); - Chunk.Free -end; - -{Add a new item} -function TPNGList.Add(ChunkClass: TChunkClass): TChunk; -var - IHDR: TChunkIHDR; - IEND: TChunkIEND; - - IDAT: TChunkIDAT; - PLTE: TChunkPLTE; -begin - Result := nil; {Default result} - {Adding these is not allowed} - if (ChunkClass = TChunkIHDR) or (ChunkClass = TChunkIDAT) or - (ChunkClass = TChunkPLTE) or (ChunkClass = TChunkIEND) then - fOwner.RaiseError(EPngError, EPNGCannotAddChunkText) - {Two of these is not allowed} - else if ((ChunkClass = TChunkgAMA) and (ItemFromClass(TChunkgAMA) <> nil)) or - ((ChunkClass = TChunktRNS) and (ItemFromClass(TChunktRNS) <> nil)) then - fOwner.RaiseError(EPngError, EPNGCannotAddChunkText) - {There must have an IEND and IHDR chunk} - else if (ItemFromClass(TChunkIEND) = nil) or - (ItemFromClass(TChunkIHDR) = nil) then - fOwner.RaiseError(EPngError, EPNGCannotAddInvalidImageText) - else - begin - {Get common chunks} - IHDR := ItemFromClass(TChunkIHDR) as TChunkIHDR; - IEND := ItemFromClass(TChunkIEND) as TChunkIEND; - {Create new chunk} - Result := ChunkClass.Create(Owner); - {Add to the list} - if (ChunkClass = TChunkgAMA) then - Insert(Result, IHDR.Index + 1) - {Transparency chunk (fix by Ian Boyd)} - else if (ChunkClass = TChunktRNS) then - begin - {Transparecy chunk must be after PLTE; before IDAT} - IDAT := ItemFromClass(TChunkIDAT) as TChunkIDAT; - PLTE := ItemFromClass(TChunkPLTE) as TChunkPLTE; - - if Assigned(PLTE) then - Insert(Result, PLTE.Index + 1) - else if Assigned(IDAT) then - Insert(Result, IDAT.Index) - else - Insert(Result, IHDR.Index + 1) - end - else {All other chunks} - Insert(Result, IEND.Index); - end {if} -end; - -{Returns item from the list} -function TPNGList.GetItem(Index: Cardinal): TChunk; -begin - Result := inherited GetItem(Index); -end; - -{Returns first item from the list using the class from parameter} -function TPNGList.ItemFromClass(ChunkClass: TChunkClass): TChunk; -var - i: Integer; -begin - Result := nil; {Initial result} - FOR i := 0 TO Count - 1 DO - {Test if this item has the same class} - if Item[i] is ChunkClass then - begin - {Returns this item and exit} - Result := Item[i]; - break; - end {if} -end; - -{$IFNDEF UseDelphi} - - {TStream implementation} - - {Copies all from another stream} - function TStream.CopyFrom(Source: TStream; Count: Cardinal): Cardinal; - const - MaxBytes = $f000; - var - Buffer: PChar; - BufSize, N: Cardinal; - begin - {If count is zero, copy everything from Source} - if Count = 0 then - begin - Source.Seek(0, soFromBeginning); - Count := Source.Size; - end; - - Result := Count; {Returns the number of bytes readed} - {Allocates memory} - if Count > MaxBytes then BufSize := MaxBytes else BufSize := Count; - GetMem(Buffer, BufSize); - - {Copy memory} - while Count > 0 do - begin - if Count > BufSize then N := BufSize else N := Count; - Source.Read(Buffer^, N); - Write(Buffer^, N); - dec(Count, N); - end; - - {Deallocates memory} - FreeMem(Buffer, BufSize); - end; - -{Set current stream position} -procedure TStream.SetPosition(const Value: Longint); -begin - Seek(Value, soFromBeginning); -end; - -{Returns position} -function TStream.GetPosition: Longint; -begin - Result := Seek(0, soFromCurrent); -end; - - {Returns stream size} -function TStream.GetSize: Longint; - var - Pos: Cardinal; - begin - Pos := Seek(0, soFromCurrent); - Result := Seek(0, soFromEnd); - Seek(Pos, soFromCurrent); - end; - - {TFileStream implementation} - - {Filestream object being created} - constructor TFileStream.Create(Filename: String; Mode: TFileStreamModeSet); - {Makes file mode} - function OpenMode: DWORD; - begin - Result := 0; - if fsmRead in Mode then Result := GENERIC_READ; - if (fsmWrite in Mode) or (fsmCreate in Mode) then - Result := Result OR GENERIC_WRITE; - end; - const - IsCreate: Array[Boolean] of Integer = (OPEN_ALWAYS, CREATE_ALWAYS); - begin - {Call ancestor} - inherited Create; - - {Create handle} - fHandle := CreateFile(PChar(Filename), OpenMode, FILE_SHARE_READ or - FILE_SHARE_WRITE, nil, IsCreate[fsmCreate in Mode], 0, 0); - {Store mode} - FileMode := Mode; - end; - - {Filestream object being destroyed} - destructor TFileStream.Destroy; - begin - {Terminates file and close} - if FileMode = [fsmWrite] then - SetEndOfFile(fHandle); - CloseHandle(fHandle); - - {Call ancestor} - inherited Destroy; - end; - - {Writes data to the file} - function TFileStream.Write(const Buffer; Count: Longint): Cardinal; - begin - if not WriteFile(fHandle, Buffer, Count, Result, nil) then - Result := 0; - end; - - {Reads data from the file} - function TFileStream.Read(var Buffer; Count: Longint): Cardinal; - begin - if not ReadFile(fHandle, Buffer, Count, Result, nil) then - Result := 0; - end; - - {Seeks the file position} - function TFileStream.Seek(Offset: Integer; Origin: Word): Longint; - begin - Result := SetFilePointer(fHandle, Offset, nil, Origin); - end; - - {Sets the size of the file} - procedure TFileStream.SetSize(const Value: Longint); - begin - Seek(Value, soFromBeginning); - SetEndOfFile(fHandle); - end; - - {TResourceStream implementation} - - {Creates the resource stream} - constructor TResourceStream.Create(Instance: HInst; const ResName: String; - ResType: PChar); - var - ResID: HRSRC; - ResGlobal: HGlobal; - begin - {Obtains the resource ID} - ResID := FindResource(hInstance, PChar(ResName), RT_RCDATA); - if ResID = 0 then raise EPNGError.Create(''); - {Obtains memory and size} - ResGlobal := LoadResource(hInstance, ResID); - Size := SizeOfResource(hInstance, ResID); - Memory := LockResource(ResGlobal); - if (ResGlobal = 0) or (Memory = nil) then EPNGError.Create(''); - end; - - - {Setting resource stream size is not supported} - procedure TResourceStream.SetSize(const Value: Integer); - begin - end; - - {Writing into a resource stream is not supported} - function TResourceStream.Write(const Buffer; Count: Integer): Cardinal; - begin - Result := 0; - end; - - {Reads data from the stream} - function TResourceStream.Read(var Buffer; Count: Integer): Cardinal; - begin - //Returns data - CopyMemory(@Buffer, Ptr(Longint(Memory) + Position), Count); - //Update position - inc(Position, Count); - //Returns - Result := Count; - end; - - {Seeks data} - function TResourceStream.Seek(Offset: Integer; Origin: Word): Longint; - begin - {Move depending on the origin} - case Origin of - soFromBeginning: Position := Offset; - soFromCurrent: inc(Position, Offset); - soFromEnd: Position := Size + Offset; - end; - - {Returns the current position} - Result := Position; - end; - -{$ENDIF} - -{TChunk implementation} - -{Resizes the data} -procedure TChunk.ResizeData(const NewSize: Cardinal); -begin - fDataSize := NewSize; - ReallocMem(fData, NewSize + 1); -end; - -{Returns index from list} -function TChunk.GetIndex: Integer; -var - i: Integer; -begin - Result := -1; {Avoiding warnings} - {Searches in the list} - FOR i := 0 TO Owner.Chunks.Count - 1 DO - if Owner.Chunks.Item[i] = Self then - begin - {Found match} - Result := i; - exit; - end {for i} -end; - -{Returns pointer to the TChunkIHDR} -function TChunk.GetHeader: TChunkIHDR; -begin - Result := Owner.Chunks.Item[0] as TChunkIHDR; -end; - -{Assigns from another TChunk} -procedure TChunk.Assign(Source: TChunk); -begin - {Copy properties} - fName := Source.fName; - {Set data size and realloc} - ResizeData(Source.fDataSize); - - {Copy data (if there's any)} - if fDataSize > 0 then CopyMemory(fData, Source.fData, fDataSize); -end; - -{Chunk being created} -constructor TChunk.Create(Owner: TPngObject); -var - ChunkName: String; -begin - {Ancestor create} - inherited Create; - - {If it's a registered class, set the chunk name based on the class} - {name. For instance, if the class name is TChunkgAMA, the GAMA part} - {will become the chunk name} - ChunkName := Copy(ClassName, Length('TChunk') + 1, Length(ClassName)); - if Length(ChunkName) = 4 then CopyMemory(@fName[0], @ChunkName[1], 4); - - {Initialize data holder} - GetMem(fData, 1); - fDataSize := 0; - {Record owner} - fOwner := Owner; -end; - -{Chunk being destroyed} -destructor TChunk.Destroy; -begin - {Free data holder} - FreeMem(fData, fDataSize + 1); - {Let ancestor destroy} - inherited Destroy; -end; - -{Returns the chunk name 1} -function TChunk.GetChunkName: String; -begin - Result := fName -end; - -{Returns the chunk name 2} -class function TChunk.GetName: String; -begin - {For avoid writing GetName for each TChunk descendent, by default for} - {classes which don't declare GetName, it will look for the class name} - {to extract the chunk kind. Example, if the class name is TChunkIEND } - {this method extracts and returns IEND} - Result := Copy(ClassName, Length('TChunk') + 1, Length(ClassName)); -end; - -{Saves the data to the stream} -function TChunk.SaveData(Stream: TStream): Boolean; -var - ChunkSize, ChunkCRC: Cardinal; -begin - {First, write the size for the following data in the chunk} - ChunkSize := ByteSwap(DataSize); - Stream.Write(ChunkSize, 4); - {The chunk name} - Stream.Write(fName, 4); - {If there is data for the chunk, write it} - if DataSize > 0 then Stream.Write(Data^, DataSize); - {Calculates and write CRC} - ChunkCRC := update_crc($ffffffff, @fName[0], 4); - ChunkCRC := Byteswap(update_crc(ChunkCRC, Data, DataSize) xor $ffffffff); - Stream.Write(ChunkCRC, 4); - - {Returns that everything went ok} - Result := TRUE; -end; - -{Saves the chunk to the stream} -function TChunk.SaveToStream(Stream: TStream): Boolean; -begin - Result := SaveData(Stream) -end; - - -{Loads the chunk from a stream} -function TChunk.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -var - CheckCRC: Cardinal; - {$IFDEF CheckCRC}RightCRC: Cardinal;{$ENDIF} -begin - {Copies data from source} - ResizeData(Size); - if Size > 0 then Stream.Read(fData^, Size); - {Reads CRC} - Stream.Read(CheckCRC, 4); - CheckCrc := ByteSwap(CheckCRC); - - {Check if crc readed is valid} - {$IFDEF CheckCRC} - RightCRC := update_crc($ffffffff, @ChunkName[0], 4); - RightCRC := update_crc(RightCRC, fData, Size) xor $ffffffff; - Result := RightCRC = CheckCrc; - - {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; - -{TChunktIME implementation} - -{Chunk being loaded from a stream} -function TChunktIME.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -begin - {Let ancestor load the data} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result or (Size <> 7) then exit; {Size must be 7} - - {Reads data} - fYear := ((pByte(Longint(Data) )^) * 256)+ (pByte(Longint(Data) + 1)^); - fMonth := pByte(Longint(Data) + 2)^; - fDay := pByte(Longint(Data) + 3)^; - fHour := pByte(Longint(Data) + 4)^; - fMinute := pByte(Longint(Data) + 5)^; - fSecond := pByte(Longint(Data) + 6)^; -end; - -{Saving the chunk to a stream} -function TChunktIME.SaveToStream(Stream: TStream): Boolean; -begin - {Update data} - ResizeData(7); {Make sure the size is 7} - pWord(Data)^ := Year; - pByte(Longint(Data) + 2)^ := Month; - pByte(Longint(Data) + 3)^ := Day; - pByte(Longint(Data) + 4)^ := Hour; - pByte(Longint(Data) + 5)^ := Minute; - pByte(Longint(Data) + 6)^ := Second; - - {Let inherited save data} - Result := inherited SaveToStream(Stream); -end; - -{TChunkztXt implementation} - -{Loading the chunk from a stream} -function TChunkzTXt.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -var - ErrorOutput: String; - CompressionMethod: Byte; - Output: Pointer; - OutputSize: Integer; -begin - {Load data from stream and validate} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result or (Size < 4) then exit; - fKeyword := PChar(Data); {Get keyword and compression method bellow} - CompressionMethod := pByte(Longint(fKeyword) + Length(fKeyword))^; - fText := ''; - - {In case the compression is 0 (only one accepted by specs), reads it} - if CompressionMethod = 0 then - begin - Output := nil; - if DecompressZLIB(PChar(Longint(Data) + Length(fKeyword) + 2), - Size - Length(fKeyword) - 2, Output, OutputSize, ErrorOutput) then - begin - SetLength(fText, OutputSize); - CopyMemory(@fText[1], Output, OutputSize); - end {if DecompressZLIB(...}; - FreeMem(Output); - end {if CompressionMethod = 0} - -end; - -{Saving the chunk to a stream} -function TChunkztXt.SaveToStream(Stream: TStream): Boolean; -var - Output: Pointer; - OutputSize: Integer; - ErrorOutput: String; -begin - Output := nil; {Initializes output} - if fText = '' then fText := ' '; - - {Compresses the data} - if CompressZLIB(@fText[1], Length(fText), Owner.CompressionLevel, Output, - OutputSize, ErrorOutput) then - begin - {Size is length from keyword, plus a null character to divide} - {plus the compression method, plus the length of the text (zlib compressed)} - ResizeData(Length(fKeyword) + 2 + OutputSize); - - Fillchar(Data^, DataSize, #0); - {Copies the keyword data} - if Keyword <> '' then - CopyMemory(Data, @fKeyword[1], Length(Keyword)); - {Compression method 0 (inflate/deflate)} - pByte(Ptr(Longint(Data) + Length(Keyword) + 1))^ := 0; - if OutputSize > 0 then - CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 2), Output, OutputSize); - - {Let ancestor calculate crc and save} - Result := SaveData(Stream); - end {if CompressZLIB(...} else Result := False; - - {Frees output} - if Output <> nil then FreeMem(Output) -end; - -{TChunktEXt implementation} - -{Assigns from another text chunk} -procedure TChunktEXt.Assign(Source: TChunk); -begin - fKeyword := TChunktEXt(Source).fKeyword; - fText := TChunktEXt(Source).fText; -end; - -{Loading the chunk from a stream} -function TChunktEXt.LoadFromStream(Stream: TStream; - const ChunkName: TChunkName; Size: Integer): Boolean; -begin - {Load data from stream and validate} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result or (Size < 3) then exit; - {Get text} - fKeyword := PChar(Data); - SetLength(fText, Size - Length(fKeyword) - 1); - CopyMemory(@fText[1], Ptr(Longint(Data) + Length(fKeyword) + 1), - Length(fText)); -end; - -{Saving the chunk to a stream} -function TChunktEXt.SaveToStream(Stream: TStream): Boolean; -begin - {Size is length from keyword, plus a null character to divide} - {plus the length of the text} - ResizeData(Length(fKeyword) + 1 + Length(fText)); - Fillchar(Data^, DataSize, #0); - {Copy data} - if Keyword <> '' then - CopyMemory(Data, @fKeyword[1], Length(Keyword)); - if Text <> '' then - CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 1), @fText[1], - Length(Text)); - {Let ancestor calculate crc and save} - Result := inherited SaveToStream(Stream); -end; - - -{TChunkIHDR implementation} - -{Chunk being created} -constructor TChunkIHDR.Create(Owner: TPngObject); -begin - {Call inherited} - inherited Create(Owner); - {Prepare pointers} - ImageHandle := 0; - ImageDC := 0; -end; - -{Chunk being destroyed} -destructor TChunkIHDR.Destroy; -begin - {Free memory} - FreeImageData(); - - {Calls TChunk destroy} - inherited Destroy; -end; - -{Assigns from another IHDR chunk} -procedure TChunkIHDR.Assign(Source: TChunk); -begin - {Copy the IHDR data} - if Source is TChunkIHDR then - begin - {Copy IHDR values} - IHDRData := TChunkIHDR(Source).IHDRData; - - {Prepare to hold data by filling BitmapInfo structure and} - {resizing ImageData and ImageAlpha memory allocations} - PrepareImageData(); - - {Copy image data} - CopyMemory(ImageData, TChunkIHDR(Source).ImageData, - BytesPerRow * Integer(Height)); - CopyMemory(ImageAlpha, TChunkIHDR(Source).ImageAlpha, - Integer(Width) * Integer(Height)); - - {Copy palette colors} - BitmapInfo.bmiColors := TChunkIHDR(Source).BitmapInfo.bmiColors; - end - else - Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText); -end; - -{Release allocated image data} -procedure TChunkIHDR.FreeImageData; -begin - {Free old image data} - if ImageHandle <> 0 then DeleteObject(ImageHandle); - if ImageDC <> 0 then DeleteDC(ImageDC); - if ImageAlpha <> nil then FreeMem(ImageAlpha); - {$IFDEF Store16bits} - if ExtraImageData <> nil then FreeMem(ExtraImageData); - {$ENDIF} - ImageHandle := 0; ImageDC := 0; ImageAlpha := nil; ImageData := nil; -end; - -{Chunk being loaded from a stream} -function TChunkIHDR.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -begin - {Let TChunk load it} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - if not Result then Exit; - - {Now check values} - {Note: It's recommended by png specification to make sure that the size} - {must be 13 bytes to be valid, but some images with 14 bytes were found} - {which could be loaded by internet explorer and other tools} - if (fDataSize < SIZEOF(TIHdrData)) then - begin - {Ihdr must always have at least 13 bytes} - Result := False; - Owner.RaiseError(EPNGInvalidIHDR, EPNGInvalidIHDRText); - exit; - end; - - {Everything ok, reads IHDR} - IHDRData := pIHDRData(fData)^; - IHDRData.Width := ByteSwap(IHDRData.Width); - IHDRData.Height := ByteSwap(IHDRData.Height); - - {The width and height must not be larger than 65535 pixels} - if (IHDRData.Width > High(Word)) or (IHDRData.Height > High(Word)) then - begin - Result := False; - Owner.RaiseError(EPNGSizeExceeds, EPNGSizeExceedsText); - exit; - end {if IHDRData.Width > High(Word)}; - {Compression method must be 0 (inflate/deflate)} - if (IHDRData.CompressionMethod <> 0) then - begin - Result := False; - Owner.RaiseError(EPNGUnknownCompression, EPNGUnknownCompressionText); - exit; - end; - {Interlace must be either 0 (none) or 7 (adam7)} - if (IHDRData.InterlaceMethod <> 0) and (IHDRData.InterlaceMethod <> 1) then - begin - Result := False; - Owner.RaiseError(EPNGUnknownInterlace, EPNGUnknownInterlaceText); - exit; - end; - - {Updates owner properties} - Owner.InterlaceMethod := TInterlaceMethod(IHDRData.InterlaceMethod); - - {Prepares data to hold image} - PrepareImageData(); -end; - -{Saving the IHDR chunk to a stream} -function TChunkIHDR.SaveToStream(Stream: TStream): Boolean; -begin - {Ignore 2 bits images} - if BitDepth = 2 then BitDepth := 4; - - {It needs to do is update the data with the IHDR data} - {structure containing the write values} - ResizeData(SizeOf(TIHDRData)); - pIHDRData(fData)^ := IHDRData; - {..byteswap 4 byte types} - pIHDRData(fData)^.Width := ByteSwap(pIHDRData(fData)^.Width); - pIHDRData(fData)^.Height := ByteSwap(pIHDRData(fData)^.Height); - {..update interlace method} - pIHDRData(fData)^.InterlaceMethod := Byte(Owner.InterlaceMethod); - {..and then let the ancestor SaveToStream do the hard work} - Result := inherited SaveToStream(Stream); -end; - -{Resizes the image data to fill the color type, bit depth, } -{width and height parameters} -procedure TChunkIHDR.PrepareImageData(); - - {Set the bitmap info} - procedure SetInfo(const Bitdepth: Integer; const Palette: Boolean); - begin - - {Copy if the bitmap contain palette entries} - HasPalette := Palette; - {Initialize the structure with zeros} - fillchar(BitmapInfo, sizeof(BitmapInfo), #0); - {Fill the strucutre} - with BitmapInfo.bmiHeader do - begin - biSize := sizeof(TBitmapInfoHeader); - biHeight := Height; - biWidth := Width; - biPlanes := 1; - biBitCount := BitDepth; - biCompression := BI_RGB; - end {with BitmapInfo.bmiHeader} - end; -begin - {Prepare bitmap info header} - Fillchar(BitmapInfo, sizeof(TMaxBitmapInfo), #0); - {Release old image data} - FreeImageData(); - - {Obtain number of bits for each pixel} - case ColorType of - COLOR_GRAYSCALE, COLOR_PALETTE, COLOR_GRAYSCALEALPHA: - case BitDepth of - {These are supported by windows} - 1, 4, 8: SetInfo(BitDepth, TRUE); - {2 bits for each pixel is not supported by windows bitmap} - 2 : SetInfo(4, TRUE); - {Also 16 bits (2 bytes) for each pixel is not supported} - {and should be transormed into a 8 bit grayscale} - 16 : SetInfo(8, TRUE); - end; - {Only 1 byte (8 bits) is supported} - COLOR_RGB, COLOR_RGBALPHA: SetInfo(24, FALSE); - end {case ColorType}; - {Number of bytes for each scanline} - BytesPerRow := (((BitmapInfo.bmiHeader.biBitCount * Width) + 31) - and not 31) div 8; - - {Build array for alpha information, if necessary} - if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then - begin - GetMem(ImageAlpha, Integer(Width) * Integer(Height)); - FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #0); - end; - - {Build array for extra byte information} - {$IFDEF Store16bits} - if (BitDepth = 16) then - begin - GetMem(ExtraImageData, BytesPerRow * Integer(Height)); - FillChar(ExtraImageData^, BytesPerRow * Integer(Height), #0); - end; - {$ENDIF} - - {Creates the image to hold the data, CreateDIBSection does a better} - {work in allocating necessary memory} - ImageDC := CreateCompatibleDC(0); - ImageHandle := CreateDIBSection(ImageDC, pBitmapInfo(@BitmapInfo)^, - DIB_RGB_COLORS, ImageData, 0, 0); - - {Clears the old palette (if any)} - with Owner do - if TempPalette <> 0 then - begin - DeleteObject(TempPalette); - TempPalette := 0; - end {with Owner, if TempPalette <> 0}; - - {Build array and allocate bytes for each row} - zeromemory(ImageData, BytesPerRow * Integer(Height)); -end; - -{TChunktRNS implementation} - -{$IFNDEF UseDelphi} -function CompareMem(P1, P2: pByte; const Size: Integer): Boolean; -var i: Integer; -begin - Result := True; - for i := 1 to Size do - begin - if P1^ <> P2^ then Result := False; - inc(P1); inc(P2); - end {for i} -end; -{$ENDIF} - -{Sets the transpararent color} -procedure TChunktRNS.SetTransparentColor(const Value: ColorRef); -var - i: Byte; - LookColor: TRGBQuad; -begin - {Clears the palette values} - Fillchar(PaletteValues, SizeOf(PaletteValues), #0); - {Sets that it uses bit transparency} - fBitTransparency := True; - - - {Depends on the color type} - with Header do - case ColorType of - COLOR_GRAYSCALE: - begin - Self.ResizeData(2); - pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value)); - end; - COLOR_RGB: - begin - Self.ResizeData(6); - pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value)); - pWord(@PaletteValues[2])^ := ByteSwap16(GetGValue(Value)); - pWord(@PaletteValues[4])^ := ByteSwap16(GetBValue(Value)); - end; - COLOR_PALETTE: - begin - {Creates a RGBQuad to search for the color} - LookColor.rgbRed := GetRValue(Value); - LookColor.rgbGreen := GetGValue(Value); - LookColor.rgbBlue := GetBValue(Value); - {Look in the table for the entry} - for i := 0 to 255 do - if CompareMem(@BitmapInfo.bmiColors[i], @LookColor, 3) then - Break; - {Fill the transparency table} - Fillchar(PaletteValues, i, 255); - Self.ResizeData(i + 1) - - end - end {case / with}; - -end; - -{Returns the transparent color for the image} -function TChunktRNS.GetTransparentColor: ColorRef; -var - PaletteChunk: TChunkPLTE; - i: Integer; -begin - Result := 0; {Default: Unknown transparent color} - - {Depends on the color type} - with Header do - case ColorType of - COLOR_GRAYSCALE: - Result := RGB(PaletteValues[0], PaletteValues[0], - PaletteValues[0]); - COLOR_RGB: - Result := RGB(PaletteValues[1], PaletteValues[3], PaletteValues[5]); - COLOR_PALETTE: - begin - {Obtains the palette chunk} - PaletteChunk := Owner.Chunks.ItemFromClass(TChunkPLTE) as TChunkPLTE; - - {Looks for an entry with 0 transparency meaning that it is the} - {full transparent entry} - for i := 0 to Self.DataSize - 1 do - if PaletteValues[i] = 0 then - with PaletteChunk.GetPaletteItem(i) do - begin - Result := RGB(rgbRed, rgbGreen, rgbBlue); - break - end - end {COLOR_PALETTE} - end {case Header.ColorType}; -end; - -{Saving the chunk to a stream} -function TChunktRNS.SaveToStream(Stream: TStream): Boolean; -begin - {Copy palette into data buffer} - if DataSize <= 256 then - CopyMemory(fData, @PaletteValues[0], DataSize); - - Result := inherited SaveToStream(Stream); -end; - -{Assigns from another chunk} -procedure TChunktRNS.Assign(Source: TChunk); -begin - CopyMemory(@PaletteValues[0], @TChunkTrns(Source).PaletteValues[0], 256); - fBitTransparency := TChunkTrns(Source).fBitTransparency; - inherited Assign(Source); -end; - -{Loads the chunk from a stream} -function TChunktRNS.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; - Size: Integer): Boolean; -var - i, Differ255: Integer; -begin - {Let inherited load} - Result := inherited LoadFromStream(Stream, ChunkName, Size); - - if not Result then Exit; - - {Make sure size is correct} - if Size > 256 then Owner.RaiseError(EPNGInvalidPalette, - EPNGInvalidPaletteText); - - {The unset items should have value 255} - Fillchar(PaletteValues[0], 256, 255); - {Copy the other values} - CopyMemory(@PaletteValues[0], fData, Size); - - {Create the mask if needed} - case Header.ColorType of - {Mask for grayscale and RGB} - COLOR_RGB, COLOR_GRAYSCALE: fBitTransparency := True; - COLOR_PALETTE: - begin - Differ255 := 0; {Count the entries with a value different from 255} - {Tests if it uses bit transparency} - for i := 0 to Size - 1 do - if PaletteValues[i] <> 255 then inc(Differ255); - - {If it has one value different from 255 it is a bit transparency} - fBitTransparency := (Differ255 = 1); - end {COLOR_PALETTE} - end {case Header.ColorType}; - -end; - -{Prepares the image palette} -procedure TChunkIDAT.PreparePalette; -var - Entries: Word; - j : Integer; -begin - {In case the image uses grayscale, build a grayscale palette} - with Header do - if (ColorType = COLOR_GRAYSCALE) or (ColorType = COLOR_GRAYSCALEALPHA) then - begin - {Calculate total number of palette entries} - Entries := (1 shl Byte(BitmapInfo.bmiHeader.biBitCount)); - - FOR j := 0 TO Entries - 1 DO - with BitmapInfo.bmiColors[j] do - begin - - {Calculate each palette entry} - rgbRed := fOwner.GammaTable[MulDiv(j, 255, Entries - 1)]; - rgbGreen := rgbRed; - rgbBlue := rgbRed; - end {with BitmapInfo.bmiColors[j]} - end {if ColorType = COLOR_GRAYSCALE..., with Header} -end; - -{Reads from ZLIB} -function TChunkIDAT.IDATZlibRead(var ZLIBStream: TZStreamRec2; - Buffer: Pointer; Count: Integer; var EndPos: Integer; - var crcfile: Cardinal): Integer; -var - ProcResult : Integer; - IDATHeader : Array[0..3] of char; - IDATCRC : Cardinal; -begin - {Uses internal record pointed by ZLIBStream to gather information} - with ZLIBStream, ZLIBStream.zlib do - begin - {Set the buffer the zlib will read into} - next_out := Buffer; - avail_out := Count; - - {Decode until it reach the Count variable} - while avail_out > 0 do - begin - {In case it needs more data and it's in the end of a IDAT chunk,} - {it means that there are more IDAT chunks} - if (fStream.Position = EndPos) and (avail_out > 0) and - (avail_in = 0) then - begin - {End this chunk by reading and testing the crc value} - fStream.Read(IDATCRC, 4); - - {$IFDEF CheckCRC} - if crcfile xor $ffffffff <> Cardinal(ByteSwap(IDATCRC)) then - begin - Result := -1; - Owner.RaiseError(EPNGInvalidCRC, EPNGInvalidCRCText); - exit; - end; - {$ENDIF} - - {Start reading the next chunk} - fStream.Read(EndPos, 4); {Reads next chunk size} - fStream.Read(IDATHeader[0], 4); {Next chunk header} - {It must be a IDAT chunk since image data is required and PNG} - {specification says that multiple IDAT chunks must be consecutive} - if IDATHeader <> 'IDAT' then - begin - Owner.RaiseError(EPNGMissingMultipleIDAT, EPNGMissingMultipleIDATText); - result := -1; - exit; - end; - - {Calculate chunk name part of the crc} - {$IFDEF CheckCRC} - crcfile := update_crc($ffffffff, @IDATHeader[0], 4); - {$ENDIF} - EndPos := fStream.Position + ByteSwap(EndPos); - end; - - - {In case it needs compressed data to read from} - if avail_in = 0 then - begin - {In case it's trying to read more than it is avaliable} - if fStream.Position + ZLIBAllocate > EndPos then - avail_in := fStream.Read(Data^, EndPos - fStream.Position) - else - avail_in := fStream.Read(Data^, ZLIBAllocate); - {Update crc} - {$IFDEF CheckCRC} - crcfile := update_crc(crcfile, Data, avail_in); - {$ENDIF} - - {In case there is no more compressed data to read from} - if avail_in = 0 then - begin - Result := Count - avail_out; - Exit; - end; - - {Set next buffer to read and record current position} - next_in := Data; - - end {if avail_in = 0}; - - ProcResult := inflate(zlib, 0); - - {In case the result was not sucessfull} - if (ProcResult < 0) then - begin - Result := -1; - Owner.RaiseError(EPNGZLIBError, - EPNGZLIBErrorText + zliberrors[procresult]); - exit; - end; - - end {while avail_out > 0}; - - end {with}; - - {If everything gone ok, it returns the count bytes} - Result := Count; -end; - -{TChunkIDAT implementation} - -const - {Adam 7 interlacing values} - RowStart: array[0..6] of Integer = (0, 0, 4, 0, 2, 0, 1); - ColumnStart: array[0..6] of Integer = (0, 4, 0, 2, 0, 1, 0); - RowIncrement: array[0..6] of Integer = (8, 8, 8, 4, 4, 2, 2); - ColumnIncrement: array[0..6] of Integer = (8, 8, 4, 4, 2, 2, 1); - -{Copy interlaced images with 1 byte for R, G, B} -procedure TChunkIDAT.CopyInterlacedRGB8(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); - repeat - {Copy this row} - 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, 3); - inc(Dest, ColumnIncrement[Pass] * 3 - 3); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy interlaced images with 2 bytes for R, G, B} -procedure TChunkIDAT.CopyInterlacedRGB16(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); - repeat - {Copy this row} - Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); - Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - Byte(Dest^) := Owner.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, 6); - inc(Dest, ColumnIncrement[Pass] * 3 - 3); - inc(Col, ColumnIncrement[Pass]); - until Col >= ImageWidth; -end; - -{Copy ímages with palette using bit depths 1, 4 or 8} -procedure TChunkIDAT.CopyInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: 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; - Dest2: PChar; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - repeat - {Copy data} - CurBit := StartBit[Header.BitDepth]; - repeat - {Adjust pointer to pixel byte bounds} - Dest2 := pChar(Longint(Dest) + (Header.BitDepth * Col) div 8); - {Copy data} - Byte(Dest2^) := Byte(Dest2^) or - ( ((Byte(Src^) shr CurBit) and BitTable[Header.BitDepth]) - shl (StartBit[Header.BitDepth] - (Col * Header.BitDepth mod 8))); - - {Move to next column} - inc(Col, ColumnIncrement[Pass]); - {Will read next bits} - dec(CurBit, Header.BitDepth); - until CurBit < 0; - - {Move to next byte in source} - inc(Src); - until Col >= ImageWidth; -end; - -{Copy ímages with palette using bit depth 2} -procedure TChunkIDAT.CopyInterlacedPalette2(const Pass: Byte; Src, Dest, - Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - CurBit, Col: Integer; - Dest2: PChar; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - repeat - {Copy data} - CurBit := 6; - repeat - {Adjust pointer to pixel byte bounds} - Dest2 := pChar(Longint(Dest) + Col div 2); - {Copy data} - Byte(Dest2^) := Byte(Dest2^) or (((Byte(Src^) shr CurBit) and $3) - shl (4 - (4 * Col) 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 ímages with grayscale using bit depth 2} -procedure TChunkIDAT.CopyInterlacedGray2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); -var - CurBit, Col: Integer; - Dest2: PChar; -begin - {Get first column and enter in loop} - Col := ColumnStart[Pass]; - repeat - {Copy data} - CurBit := 6; - repeat - {Adjust pointer to pixel byte bounds} - 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 ímages 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, ZLIBAllocate); - - {Restore buffer} - next_out := Data; - avail_out := ZLIBAllocate; - 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, ZLIBAllocate - avail_out); - {Re-update buffer} - next_out := Data; - avail_out := ZLIBAllocate; - end; - - if avail_out < ZLIBAllocate then - {Writes final IDAT} - WriteIDAT(fStream, Data, ZLIBAllocate - 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; - inc(PalColor); {Move to next palette entry} - 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 - {Assigns contents from another TPNGObject} - 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: Cardinal); -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); -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; - - {Transparency/palette chunks} - TransparencyChunk: TChunktRNS; - PaletteChunk: TChunkPLTE; - TransValue, PaletteIndex: Byte; - CurBit: Integer; - Data: PByte; - - {Buffer bitmap modification} - BytesPerRowDest, - BytesPerRowSrc, - BytesPerRowAlpha: Integer; - ImageSource, - AlphaSource : pByteArray; - ImageData : pPixelLine; - i, j : Integer; -begin - {Prepare to create the bitmap} - Fillchar(BitmapInfo, sizeof(BitmapInfo), #0); - BitmapInfoHeader.biWidth := Header.Width; - BitmapInfoHeader.biHeight := -1 * Header.Height; - 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} - StretchBlt(BufferDC, 0, 0, Header.Width, Header.height, DC, Rect.Left, - Rect.Top, Header.Width, Header.Height, SRCCOPY); - - {Obtain number of bytes for each row} - BytesPerRowAlpha := Header.Width; - BytesPerRowDest := (((BitmapInfo.bmiHeader.biBitCount * Width) + 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); - - case Header.BitmapInfo.bmiHeader.biBitCount of - {R, G, B images} - 24: - FOR j := 1 TO Header.Height DO - begin - {Process all the pixels in this line} - FOR i := 0 TO Header.Width - 1 DO - with ImageData[i] do - begin - rgbRed := (255+ImageSource[2+i*3] * AlphaSource[i] + rgbRed * (255 - - AlphaSource[i])) shr 8; - rgbGreen := (255+ImageSource[1+i*3] * AlphaSource[i] + rgbGreen * - (255 - AlphaSource[i])) shr 8; - rgbBlue := (255+ImageSource[i*3] * AlphaSource[i] + rgbBlue * - (255 - AlphaSource[i])) shr 8; - end; - - {Move pointers} - Longint(ImageData) := Longint(ImageData) + BytesPerRowDest; - Longint(ImageSource) := Longint(ImageSource) - BytesPerRowSrc; - Longint(AlphaSource) := Longint(AlphaSource) + BytesPerRowAlpha; - end; - {Palette images with 1 byte for each pixel} - 1,4,8: if Header.ColorType = COLOR_GRAYSCALEALPHA then - FOR j := 1 TO Header.Height DO - begin - {Process all the pixels in this line} - FOR i := 0 TO Header.Width - 1 DO - with ImageData[i], Header.BitmapInfo do begin - rgbRed := (255 + ImageSource[i] * AlphaSource[i] + - rgbRed * (255 - AlphaSource[i])) shr 8; - rgbGreen := (255 + ImageSource[i] * AlphaSource[i] + - rgbGreen * (255 - AlphaSource[i])) shr 8; - rgbBlue := (255 + ImageSource[i] * AlphaSource[i] + - rgbBlue * (255 - AlphaSource[i])) shr 8; - end; - - {Move pointers} - Longint(ImageData) := Longint(ImageData) + BytesPerRowDest; - Longint(ImageSource) := Longint(ImageSource) - BytesPerRowSrc; - Longint(AlphaSource) := Longint(AlphaSource) + BytesPerRowAlpha; - 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 Header.Height DO - begin - {Process all the pixels in this line} - i := 0; Data := @ImageSource[0]; - repeat - CurBit := 0; - - 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(Header.Width); - - {Move pointers} - Longint(ImageData) := Longint(ImageData) + BytesPerRowDest; - Longint(ImageSource) := Longint(ImageSource) - BytesPerRowSrc; - end - end {Palette images} - end {case Header.BitmapInfo.bmiHeader.biBitCount}; - - {Draws the new bitmap on the foreground} - StretchBlt(DC, Rect.Left, Rect.Top, Header.Width, Header.Height, BufferDC, - 0, 0, Header.Width, Header.Height, 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 (Chunks.Count = 0) or not (Chunks.GetItem(0) is TChunkIHDR) 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 - 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 {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 - {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); - {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}; - - {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(TChunkText) 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 - ByteData := GammaTable[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 in [0..Width - 1]) and (Y in [0..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 in [0..Width - 1]) and (Y in [0..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. - - diff --git a/Game/Code/lib/PngImage/pnglang.pas b/Game/Code/lib/PngImage/pnglang.pas deleted file mode 100644 index 7a9c5078..00000000 --- a/Game/Code/lib/PngImage/pnglang.pas +++ /dev/null @@ -1,301 +0,0 @@ -{Portable Network Graphics Delphi Language Info (24 July 2002)} - -{Feel free to change the text bellow to adapt to your language} -{Also if you have a translation to other languages and want to} -{share it, send me: gubadaud@terra.com.br } -unit pnglang; - -interface - -{$DEFINE English} -{.$DEFINE Portuguese} -{.$DEFINE German} -{.$DEFINE French} -{.$DEFINE Slovenian} - -{Language strings for english} -resourcestring - {$IFDEF English} - EPngInvalidCRCText = 'This "Portable Network Graphics" image is not valid ' + - 'because it contains invalid pieces of data (crc error)'; - EPNGInvalidIHDRText = 'The "Portable Network Graphics" image could not be ' + - 'loaded because one of its main piece of data (ihdr) might be corrupted'; - EPNGMissingMultipleIDATText = 'This "Portable Network Graphics" image is ' + - 'invalid because it has missing image parts.'; - EPNGZLIBErrorText = 'Could not decompress the image because it contains ' + - 'invalid compressed data.'#13#10 + ' Description: '; - EPNGInvalidPaletteText = 'The "Portable Network Graphics" image contains ' + - 'an invalid palette.'; - EPNGInvalidFileHeaderText = 'The file being readed is not a valid '+ - '"Portable Network Graphics" image because it contains an invalid header.' + - ' This file may be corruped, try obtaining it again.'; - EPNGIHDRNotFirstText = 'This "Portable Network Graphics" image is not ' + - 'supported or it might be invalid.'#13#10 + '(IHDR chunk is not the first)'; - EPNGNotExistsText = 'The png file could not be loaded because it does not ' + - 'exists.'; - EPNGSizeExceedsText = 'This "Portable Network Graphics" image is not ' + - 'supported because either it''s width or height exceeds the maximum ' + - 'size, which is 65535 pixels length.'; - EPNGUnknownPalEntryText = 'There is no such palette entry.'; - EPNGMissingPaletteText = 'This "Portable Network Graphics" could not be ' + - 'loaded because it uses a color table which is missing.'; - EPNGUnknownCriticalChunkText = 'This "Portable Network Graphics" image ' + - 'contains an unknown critical part which could not be decoded.'; - EPNGUnknownCompressionText = 'This "Portable Network Graphics" image is ' + - 'encoded with an unknown compression scheme which could not be decoded.'; - EPNGUnknownInterlaceText = 'This "Portable Network Graphics" image uses ' + - 'an unknown interlace scheme which could not be decoded.'; - EPNGCannotAssignChunkText = 'The chunks must be compatible to be assigned.'; - EPNGUnexpectedEndText = 'This "Portable Network Graphics" image is invalid ' + - 'because the decoder found an unexpected end of the file.'; - EPNGNoImageDataText = 'This "Portable Network Graphics" image contains no ' + - 'data.'; - EPNGCannotChangeSizeText = 'The "Portable Network Graphics" image can not ' + - 'be resize by changing width and height properties. Try assigning the ' + - 'image from a bitmap.'; - EPNGCannotAddChunkText = 'The program tried to add a existent critical ' + - 'chunk to the current image which is not allowed.'; - EPNGCannotAddInvalidImageText = 'It''s not allowed to add a new chunk ' + - 'because the current image is invalid.'; - EPNGCouldNotLoadResourceText = 'The png image could not be loaded from the ' + - 'resource ID.'; - EPNGOutMemoryText = 'Some operation could not be performed because the ' + - 'system is out of resources. Close some windows and try again.'; - EPNGCannotChangeTransparentText = 'Setting bit transparency color is not ' + - 'allowed for png images containing alpha value for each pixel ' + - '(COLOR_RGBALPHA and COLOR_GRAYSCALEALPHA)'; - EPNGHeaderNotPresentText = 'This operation is not valid because the ' + - 'current image contains no valid header.'; - {$ENDIF} - {$IFDEF Portuguese} - EPngInvalidCRCText = 'Essa imagem "Portable Network Graphics" não é válida ' + - 'porque contém chunks inválidos de dados (erro crc)'; - EPNGInvalidIHDRText = 'A imagem "Portable Network Graphics" não pode ser ' + - 'carregada porque um dos seus chunks importantes (ihdr) pode estar '+ - 'inválido'; - EPNGMissingMultipleIDATText = 'Essa imagem "Portable Network Graphics" é ' + - 'inválida porque tem chunks de dados faltando.'; - EPNGZLIBErrorText = 'Não foi possível descomprimir os dados da imagem ' + - 'porque ela contém dados inválidos.'#13#10 + ' Descrição: '; - EPNGInvalidPaletteText = 'A imagem "Portable Network Graphics" contém ' + - 'uma paleta inválida.'; - EPNGInvalidFileHeaderText = 'O arquivo sendo lido não é uma imagem '+ - '"Portable Network Graphics" válida porque contém um cabeçalho inválido.' + - ' O arquivo pode estar corrompida, tente obter ela novamente.'; - EPNGIHDRNotFirstText = 'Essa imagem "Portable Network Graphics" não é ' + - 'suportada ou pode ser inválida.'#13#10 + '(O chunk IHDR não é o ' + - 'primeiro)'; - EPNGNotExistsText = 'A imagem png não pode ser carregada porque ela não ' + - 'existe.'; - EPNGSizeExceedsText = 'Essa imagem "Portable Network Graphics" não é ' + - 'suportada porque a largura ou a altura ultrapassam o tamanho máximo, ' + - 'que é de 65535 pixels de diâmetro.'; - EPNGUnknownPalEntryText = 'Não existe essa entrada de paleta.'; - EPNGMissingPaletteText = 'Essa imagem "Portable Network Graphics" não pode ' + - 'ser carregada porque usa uma paleta que está faltando.'; - EPNGUnknownCriticalChunkText = 'Essa imagem "Portable Network Graphics" ' + - 'contém um chunk crítico desconheçido que não pode ser decodificado.'; - EPNGUnknownCompressionText = 'Essa imagem "Portable Network Graphics" está ' + - 'codificada com um esquema de compressão desconheçido e não pode ser ' + - 'decodificada.'; - EPNGUnknownInterlaceText = 'Essa imagem "Portable Network Graphics" usa um ' + - 'um esquema de interlace que não pode ser decodificado.'; - EPNGCannotAssignChunkText = 'Os chunk devem ser compatíveis para serem ' + - 'copiados.'; - EPNGUnexpectedEndText = 'Essa imagem "Portable Network Graphics" é ' + - 'inválida porque o decodificador encontrou um fim inesperado.'; - EPNGNoImageDataText = 'Essa imagem "Portable Network Graphics" não contém ' + - 'dados.'; - EPNGCannotChangeSizeText = 'A imagem "Portable Network Graphics" não pode ' + - 'ser redimensionada mudando as propriedades width e height. Tente ' + - 'copiar a imagem de um bitmap usando a função assign.'; - EPNGCannotAddChunkText = 'O programa tentou adicionar um chunk crítico ' + - 'já existente para a imagem atual, oque não é permitido.'; - EPNGCannotAddInvalidImageText = 'Não é permitido adicionar um chunk novo ' + - 'porque a imagem atual é inválida.'; - EPNGCouldNotLoadResourceText = 'A imagem png não pode ser carregada apartir' + - ' do resource.'; - EPNGOutMemoryText = 'Uma operação não pode ser completada porque o sistema ' + - 'está sem recursos. Fecha algumas janelas e tente novamente.'; - EPNGCannotChangeTransparentText = 'Definir transparência booleana não é ' + - 'permitido para imagens png contendo informação alpha para cada pixel ' + - '(COLOR_RGBALPHA e COLOR_GRAYSCALEALPHA)'; - EPNGHeaderNotPresentText = 'Essa operação não é válida porque a ' + - 'imagem atual não contém um cabeçalho válido.'; - {$ENDIF} - {Language strings for German} - {$IFDEF German} - EPngInvalidCRCText = 'Dieses "Portable Network Graphics" Image ist ' + - 'ungültig, weil Teile der Daten ungültig sind (CRC-Fehler).'; - EPNGInvalidIHDRText = 'Dieses "Portable Network Graphics" Image konnte ' + - 'nicht geladen werden, weil eine der Hauptdaten (IHDR) beschädigt ' + - 'sein könnte.'; - EPNGMissingMultipleIDATText = 'Dieses "Portable Network Graphics" Image ' + - 'ist ungültig, weil Grafikdaten fehlen.'; - EPNGZLIBErrorText = 'Die Grafik konnte nicht entpackt werden, weil sie ' + - 'fehlerhafte komprimierte Daten enthält.'#13#10 + ' Beschreibung: '; - EPNGInvalidPaletteText = 'Das "Portable Network Graphics" Image enthält ' + - 'eine ungültige Palette.'; - EPNGInvalidFileHeaderText = 'Die Datei, die gelesen wird, ist kein ' + - 'gültiges "Portable Network Graphics" Image, da es keinen gültigen ' + - 'Header enthält. Die Datei könnte beschädigt sein, versuchen Sie, ' + - 'eine neue Kopie zu bekommen.'; - EPNGIHDRNotFirstText = 'Dieses "Portable Network Graphics" Image wird ' + - 'nicht unterstützt bzw. es könnte ungültig sein.'#13#10 + - '(Der IHDR-Chunk ist nicht der erste Chunk in der Datei).'; - EPNGNotExistsText = 'Die PNG Datei konnte nicht geladen werden, da sie ' + - 'nicht existiert.'; - EPNGSizeExceedsText = 'Dieses "Portable Network Graphics" Image wird nicht ' + - 'unterstützt, weil entweder seine Breite oder seine Höhe das Maximum von ' + - '65535 Pixeln überschreitet.'; - EPNGUnknownPalEntryText = 'Es gibt keinen solchen Palettenwert.'; - EPNGMissingPaletteText = 'Dieses "Portable Network Graphics" Image konnte ' + - 'nicht geladen werden, weil die benötigte Farbtabelle fehlt.'; - EPNGUnknownCriticalChunkText = 'Dieses "Portable Network Graphics" Image ' + - 'enhält einen unbekannten kritischen Teil, welcher nicht entschlüsselt ' + - 'werden kann.'; - EPNGUnknownCompressionText = 'Dieses "Portable Network Graphics" Image ' + - 'wurde mit einem unbekannten Komprimierungsalgorithmus kodiert, welcher ' + - 'nicht entschlüsselt werden kann.'; - EPNGUnknownInterlaceText = 'Dieses "Portable Network Graphics" Image ' + - 'benutzt ein unbekanntes Interlace-Schema, welcher nicht entschlüsselt ' + - 'werden kann.'; - EPNGCannotAssignChunkText = 'Die Chunks müssen kompatibel sein, um ' + - 'zugewiesen werden zu können.'; - EPNGUnexpectedEndText = 'Dieses "Portable Network Graphics" Image ist ' + - 'ungültig, der Dekoder stieß unerwarteterweise auf das Ende der Datei.'; - EPNGNoImageDataText = 'Dieses "Portable Network Graphics" Image enthält ' + - 'keine Daten.'; - EPNGCannotChangeSizeText = 'Das "Portable Network Graphics" Image kann ' + - 'nicht durch Ändern der Eigenschaften Width und Height in seinen ' + - 'Abmessungen geändert werden. Versuchen Sie das Image von einer Bitmap ' + - 'aus zuzuweisen.'; - EPNGCannotAddChunkText = 'Das Programm versucht einen existierenden ' + - 'kritischen Chunk zum aktuellen Image hinzuzufügen. Dies ist nicht ' + - 'zulässig.'; - EPNGCannotAddInvalidImageText = 'Es ist nicht zulässig, dem aktuellen ' + - 'Image einen neuen Chunk hinzuzufügen, da es ungültig ist.'; - EPNGCouldNotLoadResourceText = 'Das PNG Image konnte nicht von den ' + - 'Resourcendaten geladen werden.'; - EPNGOutMemoryText = 'Es stehen nicht genügend Resourcen im System zur ' + - 'Verfügung, um die Operation auszuführen. Schließen Sie einige Fenster '+ - 'und versuchen Sie es erneut.'; - EPNGCannotChangeTransparentText = 'Das Setzen der Bit-' + - 'Transparent-Farbe ist fuer PNG-Images die Alpha-Werte fuer jedes ' + - 'Pixel enthalten (COLOR_RGBALPHA und COLOR_GRAYSCALEALPHA) nicht ' + - 'zulaessig'; - EPNGHeaderNotPresentText = 'Die Datei, die gelesen wird, ist kein ' + - 'gültiges "Portable Network Graphics" Image, da es keinen gültigen ' + - 'Header enthält.'; - {$ENDIF} - {Language strings for French} - {$IFDEF French} - EPngInvalidCRCText = 'Cette image "Portable Network Graphics" n''est pas valide ' + - 'car elle contient des données invalides (erreur crc)'; - EPNGInvalidIHDRText = 'Cette image "Portable Network Graphics" n''a pu être ' + - 'chargée car l''une de ses principale donnée (ihdr) doit être corrompue'; - EPNGMissingMultipleIDATText = 'Cette image "Portable Network Graphics" est ' + - 'invalide car elle contient des parties d''image manquantes.'; - EPNGZLIBErrorText = 'Impossible de décompresser l''image car elle contient ' + - 'des données compressées invalides.'#13#10 + ' Description: '; - EPNGInvalidPaletteText = 'L''image "Portable Network Graphics" contient ' + - 'une palette invalide.'; - EPNGInvalidFileHeaderText = 'Le fichier actuellement lu est une image '+ - '"Portable Network Graphics" invalide car elle contient un en-tête invalide.' + - ' Ce fichier doit être corrompu, essayer de l''obtenir à nouveau.'; - EPNGIHDRNotFirstText = 'Cette image "Portable Network Graphics" n''est pas ' + - 'supportée ou doit être invalide.'#13#10 + '(la partie IHDR n''est pas la première)'; - EPNGNotExistsText = 'Le fichier png n''a pu être chargé car il n''éxiste pas.'; - EPNGSizeExceedsText = 'Cette image "Portable Network Graphics" n''est pas supportée ' + - 'car sa longueur ou sa largeur excède la taille maximale, qui est de 65535 pixels.'; - EPNGUnknownPalEntryText = 'Il n''y a aucune entrée pour cette palette.'; - EPNGMissingPaletteText = 'Cette image "Portable Network Graphics" n''a pu être ' + - 'chargée car elle utilise une table de couleur manquante.'; - EPNGUnknownCriticalChunkText = 'Cette image "Portable Network Graphics" ' + - 'contient une partie critique inconnue qui n'' pu être décodée.'; - EPNGUnknownCompressionText = 'Cette image "Portable Network Graphics" est ' + - 'encodée à l''aide d''un schémas de compression inconnu qui ne peut être décodé.'; - EPNGUnknownInterlaceText = 'Cette image "Portable Network Graphics" utilise ' + - 'un schémas d''entrelacement inconnu qui ne peut être décodé.'; - EPNGCannotAssignChunkText = 'Ce morceau doit être compatible pour être assigné.'; - EPNGUnexpectedEndText = 'Cette image "Portable Network Graphics" est invalide ' + - 'car le decodeur est arrivé à une fin de fichier non attendue.'; - EPNGNoImageDataText = 'Cette image "Portable Network Graphics" ne contient pas de ' + - 'données.'; - EPNGCannotChangeSizeText = 'Cette image "Portable Network Graphics" ne peut pas ' + - 'être retaillée en changeant ses propriétés width et height. Essayer d''assigner l''image depuis ' + - 'un bitmap.'; - EPNGCannotAddChunkText = 'Le programme a essayé d''ajouter un morceau critique existant ' + - 'à l''image actuelle, ce qui n''est pas autorisé.'; - EPNGCannotAddInvalidImageText = 'Il n''est pas permis d''ajouter un nouveau morceau ' + - 'car l''image actuelle est invalide.'; - EPNGCouldNotLoadResourceText = 'L''image png n''a pu être chargée depuis ' + - 'l''ID ressource.'; - EPNGOutMemoryText = 'Certaines opérations n''ont pu être effectuée car le ' + - 'système n''a plus de ressources. Fermez quelques fenêtres et essayez à nouveau.'; - EPNGCannotChangeTransparentText = 'Définir le bit de transparence n''est pas ' + - 'permis pour des images png qui contiennent une valeur alpha pour chaque pixel ' + - '(COLOR_RGBALPHA et COLOR_GRAYSCALEALPHA)'; - EPNGHeaderNotPresentText = 'Cette opération n''est pas valide car l''image ' + - 'actuelle ne contient pas de header valide.'; - EPNGAlphaNotSupportedText = 'Le type de couleur de l''image "Portable Network Graphics" actuelle ' + - 'contient déjà des informations alpha ou il ne peut être converti.'; - {$ENDIF} - {Language strings for slovenian} - {$IFDEF Slovenian} - EPngInvalidCRCText = 'Ta "Portable Network Graphics" slika je neveljavna, ' + - 'ker vsebuje neveljavne dele podatkov (CRC napaka).'; - EPNGInvalidIHDRText = 'Slike "Portable Network Graphics" ni bilo možno ' + - 'naložiti, ker je eden od glavnih delov podatkov (IHDR) verjetno pokvarjen.'; - EPNGMissingMultipleIDATText = 'Ta "Portable Network Graphics" slika je ' + - 'naveljavna, ker manjkajo deli slike.'; - EPNGZLIBErrorText = 'Ne morem raztegniti slike, ker vsebuje ' + - 'neveljavne stisnjene podatke.'#13#10 + ' Opis: '; - EPNGInvalidPaletteText = 'Slika "Portable Network Graphics" vsebuje ' + - 'neveljavno barvno paleto.'; - EPNGInvalidFileHeaderText = 'Datoteka za branje ni veljavna '+ - '"Portable Network Graphics" slika, ker vsebuje neveljavno glavo.' + - ' Datoteka je verjetno pokvarjena, poskusite jo ponovno naložiti.'; - EPNGIHDRNotFirstText = 'Ta "Portable Network Graphics" slika ni ' + - 'podprta ali pa je neveljavna.'#13#10 + '(IHDR del datoteke ni prvi).'; - EPNGNotExistsText = 'Ne morem naložiti png datoteke, ker ta ne ' + - 'obstaja.'; - EPNGSizeExceedsText = 'Ta "Portable Network Graphics" slika ni ' + - 'podprta, ker ali njena širina ali višina presega najvecjo možno vrednost ' + - '65535 pik.'; - EPNGUnknownPalEntryText = 'Slika nima vnešene take barvne palete.'; - EPNGMissingPaletteText = 'Te "Portable Network Graphics" ne morem ' + - 'naložiti, ker uporablja manjkajoco barvno paleto.'; - EPNGUnknownCriticalChunkText = 'Ta "Portable Network Graphics" slika ' + - 'vsebuje neznan kriticni del podatkov, ki ga ne morem prebrati.'; - EPNGUnknownCompressionText = 'Ta "Portable Network Graphics" slika je ' + - 'kodirana z neznano kompresijsko shemo, ki je ne morem prebrati.'; - EPNGUnknownInterlaceText = 'Ta "Portable Network Graphics" slika uporablja ' + - 'neznano shemo za preliv, ki je ne morem prebrati.'; - EPNGCannotAssignChunkText = Košcki morajo biti med seboj kompatibilni za prireditev vrednosti.'; - EPNGUnexpectedEndText = 'Ta "Portable Network Graphics" slika je neveljavna, ' + - 'ker je bralnik prišel do nepricakovanega konca datoteke.'; - EPNGNoImageDataText = 'Ta "Portable Network Graphics" ne vsebuje nobenih ' + - 'podatkov.'; - EPNGCannotChangeSizeText = 'Te "Portable Network Graphics" sliki ne morem ' + - 'spremeniti velikosti s spremembo lastnosti višine in širine. Poskusite ' + - 'sliko prirediti v bitno sliko.'; - EPNGCannotAddChunkText = 'Program je poskusil dodati obstojeci kriticni ' + - 'kos podatkov k trenutni sliki, kar ni dovoljeno.'; - EPNGCannotAddInvalidImageText = 'Ni dovoljeno dodati nov kos podatkov, ' + - 'ker trenutna slika ni veljavna.'; - EPNGCouldNotLoadResourceText = 'Ne morem naložiti png slike iz ' + - 'skladišca.'; - EPNGOutMemoryText = 'Ne morem izvesti operacije, ker je ' + - 'sistem ostal brez resorjev. Zaprite nekaj oken in poskusite znova.'; - EPNGCannotChangeTransparentText = 'Ni dovoljeno nastaviti prosojnosti posamezne barve ' + - 'za png slike, ki vsebujejo alfa prosojno vrednost za vsako piko ' + - '(COLOR_RGBALPHA and COLOR_GRAYSCALEALPHA)'; - EPNGHeaderNotPresentText = 'Ta operacija ni veljavna, ker ' + - 'izbrana slika ne vsebuje veljavne glave.'; - {$ENDIF} - - -implementation - -end. diff --git a/Game/Code/lib/PngImage/pngzlib.pas b/Game/Code/lib/PngImage/pngzlib.pas deleted file mode 100644 index 3155946a..00000000 --- a/Game/Code/lib/PngImage/pngzlib.pas +++ /dev/null @@ -1,172 +0,0 @@ -{Portable Network Graphics Delphi ZLIB linking (16 May 2002) } - -{This unit links ZLIB to pngimage unit in order to implement } -{the library. It's now using the new ZLIB version, 1.1.4 } -{Note: The .obj files must be located in the subdirectory \obj} - -unit pngzlib; - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} - -interface - -type - - TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; - TFree = procedure (AppData, Block: Pointer); - - // Internal structure. Ignore. - TZStreamRec = packed record - next_in: PChar; // next input byte - avail_in: Integer; // number of bytes available at next_in - total_in: Integer; // total nb of input bytes read so far - - next_out: PChar; // next output byte should be put here - avail_out: Integer; // remaining free space at next_out - total_out: Integer; // total nb of bytes output so far - - msg: PChar; // last error message, NULL if no error - internal: Pointer; // not visible by applications - - zalloc: TAlloc; // used to allocate the internal state - zfree: TFree; // used to free the internal state - AppData: Pointer; // private data object passed to zalloc and zfree - - data_type: Integer; // best guess about the data type: ascii or binary - adler: Integer; // adler32 value of the uncompressed data - reserved: Integer; // reserved for future use - end; - -function inflateInit_(var strm: TZStreamRec; version: PChar; recsize: Integer): Integer; // forward; -function inflate(var strm: TZStreamRec; flush: Integer): Integer; //forward; -function inflateEnd(var strm: TZStreamRec): Integer; //forward; -function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; recsize: Integer): Integer; //forward; -function deflate(var strm: TZStreamRec; flush: Integer): Integer; //forward; -function deflateEnd(var strm: TZStreamRec): Integer; //forward; - -const - zlib_version = '1.1.4'; - -function adler32(adler: Integer; buf: PChar; len: Integer): Integer; - - -const - Z_NO_FLUSH = 0; - Z_PARTIAL_FLUSH = 1; - Z_SYNC_FLUSH = 2; - Z_FULL_FLUSH = 3; - Z_FINISH = 4; - - Z_OK = 0; - Z_STREAM_END = 1; - Z_NEED_DICT = 2; - Z_ERRNO = (-1); - Z_STREAM_ERROR = (-2); - Z_DATA_ERROR = (-3); - Z_MEM_ERROR = (-4); - Z_BUF_ERROR = (-5); - Z_VERSION_ERROR = (-6); - - Z_NO_COMPRESSION = 0; - Z_BEST_SPEED = 1; - Z_BEST_COMPRESSION = 9; - Z_DEFAULT_COMPRESSION = (-1); - - Z_FILTERED = 1; - Z_HUFFMAN_ONLY = 2; - Z_DEFAULT_STRATEGY = 0; - - Z_BINARY = 0; - Z_ASCII = 1; - Z_UNKNOWN = 2; - - Z_DEFLATED = 8; - - _z_errmsg: array[0..9] of PChar = ( - 'need dictionary', // Z_NEED_DICT (2) - 'stream end', // Z_STREAM_END (1) - '', // Z_OK (0) - 'file error', // Z_ERRNO (-1) - 'stream error', // Z_STREAM_ERROR (-2) - 'data error', // Z_DATA_ERROR (-3) - 'insufficient memory', // Z_MEM_ERROR (-4) - 'buffer error', // Z_BUF_ERROR (-5) - 'incompatible version', // Z_VERSION_ERROR (-6) - '' - ); - -implementation - -{$IFNDef FPC} - {$L obj\deflate.obj} - {$L obj\trees.obj} - {$L obj\inflate.obj} - {$L obj\inftrees.obj} - {$L obj\adler32.obj} - {$L obj\infblock.obj} - {$L obj\infcodes.obj} - {$L obj\infutil.obj} - {$L obj\inffast.obj} -{$ENDIF} - -procedure _tr_init; external; -procedure _tr_tally; external; -procedure _tr_flush_block; external; -procedure _tr_align; external; -procedure _tr_stored_block; external; -function adler32; external; -procedure inflate_blocks_new; external; -procedure inflate_blocks; external; -procedure inflate_blocks_reset; external; -procedure inflate_blocks_free; external; -procedure inflate_set_dictionary; external; -procedure inflate_trees_bits; external; -procedure inflate_trees_dynamic; external; -procedure inflate_trees_fixed; external; -procedure inflate_codes_new; external; -procedure inflate_codes; external; -procedure inflate_codes_free; external; -procedure _inflate_mask; external; -procedure inflate_flush; external; -procedure inflate_fast; external; - -procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl; -begin - FillChar(P^, count, B); -end; - -procedure _memcpy(dest, source: Pointer; count: Integer);cdecl; -begin - Move(source^, dest^, count); -end; - - -// deflate compresses data -function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; - recsize: Integer): Integer; external; -function deflate(var strm: TZStreamRec; flush: Integer): Integer; external; -function deflateEnd(var strm: TZStreamRec): Integer; external; - -// inflate decompresses data -function inflateInit_(var strm: TZStreamRec; version: PChar; recsize: Integer): Integer; external; -function inflate(var strm: TZStreamRec; flush: Integer): Integer; external; -function inflateEnd(var strm: TZStreamRec): Integer; external; -function inflateReset(var strm: TZStreamRec): Integer; external; - - -function zcalloc(AppData: Pointer; Items, Size: Integer): Pointer; -begin - GetMem(Result, Items*Size); -end; - -procedure zcfree(AppData, Block: Pointer); -begin - FreeMem(Block); -end; - -end. - - - diff --git a/Game/Code/lib/libpng/png.pas b/Game/Code/lib/libpng/png.pas new file mode 100644 index 00000000..f4424a2a --- /dev/null +++ b/Game/Code/lib/libpng/png.pas @@ -0,0 +1,980 @@ +(* + * libpng pascal headers + * Version: 1.2.12 + *) + +{$IFDEF FPC} + {$ifndef NO_SMART_LINK} + {$smartlink on} + {$endif} +{$ENDIF} +unit png; + +interface + +{$IFDEF FPC} + {$MODE DELPHI} + {$PACKRECORDS C} +{$ENDIF} + +uses + {$IFDEF MSWINDOWS} + Windows, + {$ENDIF} + {$IFDEF UNIX} + baseunix, + {$ENDIF} + zlib; + +const +{$ifdef MSWINDOWS} + // use libpng12-0 (Version 1.2.18), delivered wih SDL_Image + LibPng = 'libpng12-0'; // 'libpng13'; + // matching lib version for libpng13.dll, needed for initialization + PNG_LIBPNG_VER_STRING='1.2.12'; + // define the compiler that was used to built the DLL (necessary for jmp_buf) + // SDL_Image was compiled with GCC + //{$define MSVC_DLL} // MS Visual C++ + {$define GCC_DLL} // GCC +{$else} + LibPng = 'png'; + // matching lib version for libpng, needed for initialization + PNG_LIBPNG_VER_STRING='1.2.12'; +{$endif} + + +{$ifdef MSWINDOWS} +const + // JB_LEN (#elements in jmp_buf) depends on the compiler used to compile the DLL + // MSVC++: 16 (x86/AMD64), GCC: 52 + {$if Defined(MSVC_DLL)} + JB_LEN = 16; + {$elseif Defined(GCC_DLL)} + JB_LEN = 52; + {$else} + JB_LEN = 0; + {$ifend} +{$endif} + +type + {$IFNDEF FPC} + // defines for Delphi + size_t = longword; + {$ENDIF} + + {$ifdef MSWINDOWS} + {$if JB_LEN > 0} + jmp_buf = array[0..JB_LEN-1] of integer; + // the png_struct cannot be accessed if the size of jmp_buf is unknown + {$define UsePngStruct} + {$ifend} + // Do NOT use time_t on windows! It might be 32 or 64bit, depending on the compiler and system. + // MSVS-2005 starts using 64bit for time_t on x86 by default, but GCC uses just 32bit. + //time_t = longint; + {$endif} + + z_stream = TZStream; + + png_uint_32 = dword; + png_int_32 = longint; + png_uint_16 = word; + png_int_16 = smallint; + png_byte = byte; + ppng_uint_32 = ^png_uint_32; + ppng_int_32 = ^png_int_32; + ppng_uint_16 = ^png_uint_16; + ppng_int_16 = ^png_int_16; + ppng_byte = ^png_byte; + pppng_uint_32 = ^ppng_uint_32; + pppng_int_32 = ^ppng_int_32; + pppng_uint_16 = ^ppng_uint_16; + pppng_int_16 = ^ppng_int_16; + pppng_byte = ^ppng_byte; + png_size_t = size_t; + png_fixed_point = png_int_32; + ppng_fixed_point = ^png_fixed_point; + pppng_fixed_point = ^ppng_fixed_point; + png_voidp = pointer; + png_bytep = Ppng_byte; + ppng_bytep = ^png_bytep; + png_uint_32p = Ppng_uint_32; + png_int_32p = Ppng_int_32; + png_uint_16p = Ppng_uint_16; + ppng_uint_16p = ^png_uint_16p; + png_int_16p = Ppng_int_16; + png_const_charp = {const} Pchar; + png_charp = Pchar; + ppng_charp = ^png_charp; + png_fixed_point_p = Ppng_fixed_point; + png_FILE_p = Pointer; + png_doublep = Pdouble; + png_bytepp = PPpng_byte; + png_uint_32pp = PPpng_uint_32; + png_int_32pp = PPpng_int_32; + png_uint_16pp = PPpng_uint_16; + png_int_16pp = PPpng_int_16; + png_const_charpp = {const} PPchar; + png_charpp = PPchar; + ppng_charpp = ^png_charpp; + png_fixed_point_pp = PPpng_fixed_point; + PPDouble = ^PDouble; + png_doublepp = PPdouble; + PPPChar = ^PPCHar; + png_charppp = PPPchar; + Pcharf = Pchar; + PPcharf = ^Pcharf; + png_zcharp = Pcharf; + png_zcharpp = PPcharf; + png_zstreamp = Pzstream; + +const + (* Maximum positive integer used in PNG is (2^31)-1 *) + PNG_UINT_31_MAX = (png_uint_32($7fffffff)); + PNG_UINT_32_MAX = (png_uint_32(-1)); + PNG_SIZE_MAX = (png_size_t(-1)); + {$if defined(PNG_1_0_X) or defined (PNG_1_2_X)} + (* PNG_MAX_UINT is deprecated; use PNG_UINT_31_MAX instead. *) + PNG_MAX_UINT = PNG_UINT_31_MAX; + {$ifend} + + (* These describe the color_type field in png_info. *) + (* color type masks *) + PNG_COLOR_MASK_PALETTE = 1; + PNG_COLOR_MASK_COLOR = 2; + PNG_COLOR_MASK_ALPHA = 4; + + (* color types. Note that not all combinations are legal *) + PNG_COLOR_TYPE_GRAY = 0; + PNG_COLOR_TYPE_PALETTE = (PNG_COLOR_MASK_COLOR or PNG_COLOR_MASK_PALETTE); + PNG_COLOR_TYPE_RGB = (PNG_COLOR_MASK_COLOR); + PNG_COLOR_TYPE_RGB_ALPHA = (PNG_COLOR_MASK_COLOR or PNG_COLOR_MASK_ALPHA); + PNG_COLOR_TYPE_GRAY_ALPHA = (PNG_COLOR_MASK_ALPHA); + (* aliases *) + PNG_COLOR_TYPE_RGBA = PNG_COLOR_TYPE_RGB_ALPHA; + PNG_COLOR_TYPE_GA = PNG_COLOR_TYPE_GRAY_ALPHA; + + (* This is for compression type. PNG 1.0-1.2 only define the single type. *) + PNG_COMPRESSION_TYPE_BASE = 0; (* Deflate method 8, 32K window *) + PNG_COMPRESSION_TYPE_DEFAULT = PNG_COMPRESSION_TYPE_BASE; + + (* This is for filter type. PNG 1.0-1.2 only define the single type. *) + PNG_FILTER_TYPE_BASE = 0; (* Single row per-byte filtering *) + PNG_INTRAPIXEL_DIFFERENCING = 64; (* Used only in MNG datastreams *) + PNG_FILTER_TYPE_DEFAULT = PNG_FILTER_TYPE_BASE; + + (* These are for the interlacing type. These values should NOT be changed. *) + PNG_INTERLACE_NONE = 0; (* Non-interlaced image *) + PNG_INTERLACE_ADAM7 = 1; (* Adam7 interlacing *) + PNG_INTERLACE_LAST = 2; (* Not a valid value *) + + (* These are for the oFFs chunk. These values should NOT be changed. *) + PNG_OFFSET_PIXEL = 0; (* Offset in pixels *) + PNG_OFFSET_MICROMETER = 1; (* Offset in micrometers (1/10^6 meter) *) + PNG_OFFSET_LAST = 2; (* Not a valid value *) + + (* These are for the pCAL chunk. These values should NOT be changed. *) + PNG_EQUATION_LINEAR = 0; (* Linear transformation *) + PNG_EQUATION_BASE_E = 1; (* Exponential base e transform *) + PNG_EQUATION_ARBITRARY = 2; (* Arbitrary base exponential transform *) + PNG_EQUATION_HYPERBOLIC = 3; (* Hyperbolic sine transformation *) + PNG_EQUATION_LAST = 4; (* Not a valid value *) + + (* These are for the sCAL chunk. These values should NOT be changed. *) + PNG_SCALE_UNKNOWN = 0; (* unknown unit (image scale) *) + PNG_SCALE_METER = 1; (* meters per pixel *) + PNG_SCALE_RADIAN = 2; (* radians per pixel *) + PNG_SCALE_LAST = 3; (* Not a valid value *) + + (* These are for the pHYs chunk. These values should NOT be changed. *) + PNG_RESOLUTION_UNKNOWN = 0; (* pixels/unknown unit (aspect ratio) *) + PNG_RESOLUTION_METER = 1; (* pixels/meter *) + PNG_RESOLUTION_LAST = 2; (* Not a valid value *) + + (* These are for the sRGB chunk. These values should NOT be changed. *) + PNG_sRGB_INTENT_PERCEPTUAL = 0; + PNG_sRGB_INTENT_RELATIVE = 1; + PNG_sRGB_INTENT_SATURATION = 2; + PNG_sRGB_INTENT_ABSOLUTE = 3; + PNG_sRGB_INTENT_LAST = 4; (* Not a valid value *) + + (* This is for text chunks *) + PNG_KEYWORD_MAX_LENGTH = 79; + + (* Maximum number of entries in PLTE/sPLT/tRNS arrays *) + PNG_MAX_PALETTE_LENGTH = 256; + + (* These determine if an ancillary chunk's data has been successfully read + * from the PNG header, or if the application has filled in the corresponding + * data in the info_struct to be written into the output file. The values + * of the PNG_INFO_ defines should NOT be changed. + *) + PNG_INFO_gAMA = $0001; + PNG_INFO_sBIT = $0002; + PNG_INFO_cHRM = $0004; + PNG_INFO_PLTE = $0008; + PNG_INFO_tRNS = $0010; + PNG_INFO_bKGD = $0020; + PNG_INFO_hIST = $0040; + PNG_INFO_pHYs = $0080; + PNG_INFO_oFFs = $0100; + PNG_INFO_tIME = $0200; + PNG_INFO_pCAL = $0400; + PNG_INFO_sRGB = $0800; (* GR-P, 0.96a *) + PNG_INFO_iCCP = $1000; (* ESR, 1.0.6 *) + PNG_INFO_sPLT = $2000; (* ESR, 1.0.6 *) + PNG_INFO_sCAL = $4000; (* ESR, 1.0.6 *) + PNG_INFO_IDAT = $8000; (* ESR, 1.0.6 *) + + +{$IFDEF FPC} +{$IF Defined(Linux)} +var + png_libpng_ver : array[0..11] of char; cvar; external; + png_pass_start : array[0..6] of integer; cvar; external; + png_pass_inc : array[0..6] of integer; cvar; external; + png_pass_ystart : array[0..6] of integer; cvar; external; + png_pass_yinc : array[0..6] of integer; cvar; external; + png_pass_mask : array[0..6] of integer; cvar; external; + png_pass_dsp_mask : array[0..6] of integer; cvar; external; +{$ELSEIF Defined(Darwin)} +var + png_libpng_ver : array[0..11] of char; external LibPng name 'png_libpng_ver'; + png_pass_start : array[0..6] of integer; external LibPng name 'png_pass_start'; + png_pass_inc : array[0..6] of integer; external LibPng name 'png_pass_inc'; + png_pass_ystart : array[0..6] of integer; external LibPng name 'png_pass_ystart'; + png_pass_yinc : array[0..6] of integer; external LibPng name 'png_pass_yinc'; + png_pass_mask : array[0..6] of integer; external LibPng name 'png_pass_mask'; + png_pass_dsp_mask : array[0..6] of integer; external LibPng name 'png_pass_dsp_mask'; +{$IFEND} +{$ENDIF} + +type + (* Three color definitions. The order of the red, green, and blue, (and the + * exact size) is not important, although the size of the fields need to + * be png_byte or png_uint_16 (as defined below). + *) + png_color = record + red : png_byte; + green : png_byte; + blue : png_byte; + end; + ppng_color = ^png_color; + pppng_color = ^ppng_color; + png_color_struct = png_color; + png_colorp = Ppng_color; + ppng_colorp = ^png_colorp; + png_colorpp = PPpng_color; + + png_color_16 = record + index : png_byte; (* used for palette files *) + red : png_uint_16; (* for use in red green blue files *) + green : png_uint_16; + blue : png_uint_16; + gray : png_uint_16; (* for use in grayscale files *) + end; + ppng_color_16 = ^png_color_16 ; + pppng_color_16 = ^ppng_color_16 ; + png_color_16_struct = png_color_16; + png_color_16p = Ppng_color_16; + ppng_color_16p = ^png_color_16p; + png_color_16pp = PPpng_color_16; + + png_color_8 = record + red : png_byte; (* for use in red green blue files *) + green : png_byte; + blue : png_byte; + gray : png_byte; (* for use in grayscale files *) + alpha : png_byte; (* for alpha channel files *) + end; + ppng_color_8 = ^png_color_8; + pppng_color_8 = ^ppng_color_8; + png_color_8_struct = png_color_8; + png_color_8p = Ppng_color_8; + ppng_color_8p = ^png_color_8p; + png_color_8pp = PPpng_color_8; + + (* + * The following two structures are used for the in-core representation + * of sPLT chunks. + *) + png_sPLT_entry = record + red : png_uint_16; + green : png_uint_16; + blue : png_uint_16; + alpha : png_uint_16; + frequency : png_uint_16; + end; + ppng_sPLT_entry = ^png_sPLT_entry; + pppng_sPLT_entry = ^ppng_sPLT_entry; + png_sPLT_entry_struct = png_sPLT_entry; + png_sPLT_entryp = Ppng_sPLT_entry; + png_sPLT_entrypp = PPpng_sPLT_entry; + + (* When the depth of the sPLT palette is 8 bits, the color and alpha samples + * occupy the LSB of their respective members, and the MSB of each member + * is zero-filled. The frequency member always occupies the full 16 bits. + *) + + png_sPLT_t = record + name : png_charp; (* palette name *) + depth : png_byte; (* depth of palette samples *) + entries : png_sPLT_entryp; (* palette entries *) + nentries : png_int_32; (* number of palette entries *) + end; + ppng_sPLT_t = ^png_sPLT_t; + pppng_sPLT_t = ^ppng_sPLT_t; + png_sPLT_struct = png_sPLT_t; + png_sPLT_tp = Ppng_sPLT_t; + png_sPLT_tpp = PPpng_sPLT_t; + + (* png_text holds the contents of a text/ztxt/itxt chunk in a PNG file, + * and whether that contents is compressed or not. The "key" field + * points to a regular zero-terminated C string. The "text", "lang", and + * "lang_key" fields can be regular C strings, empty strings, or NULL pointers. + * However, the * structure returned by png_get_text() will always contain + * regular zero-terminated C strings (possibly empty), never NULL pointers, + * so they can be safely used in printf() and other string-handling functions. + *) + png_text = record + compression : integer; (* compression value: + -1: tEXt, none + 0: zTXt, deflate + 1: iTXt, none + 2: iTXt, deflate *) + key : png_charp; (* keyword, 1-79 character description of "text" *) + text : png_charp; (* comment, may be an empty string (ie "") + or a NULL pointer *) + text_length : png_size_t; (* length of the text string *) + end; + ppng_text = ^png_text; + pppng_text = ^ppng_text; + png_text_struct = png_text; + png_textp = Ppng_text; + ppng_textp = ^png_textp; + png_textpp = PPpng_text; + + (* png_time is a way to hold the time in an machine independent way. + * Two conversions are provided, both from time_t and struct tm. There + * is no portable way to convert to either of these structures, as far + * as I know. If you know of a portable way, send it to me. As a side + * note - PNG has always been Year 2000 compliant! + *) + png_time = record + year : png_uint_16; (* full year, as in, 1995 *) + month : png_byte; (* month of year, 1 - 12 *) + day : png_byte; (* day of month, 1 - 31 *) + hour : png_byte; (* hour of day, 0 - 23 *) + minute : png_byte; (* minute of hour, 0 - 59 *) + second : png_byte; (* second of minute, 0 - 60 (for leap seconds) *) + end; + ppng_time = ^png_time; + pppng_time = ^ppng_time; + png_time_struct = png_time; + png_timep = Ppng_time; + PPNG_TIMEP = ^PNG_TIMEP; + png_timepp = PPpng_time; + +const + PNG_CHUNK_NAME_LENGTH = 5; +type + (* png_unknown_chunk is a structure to hold queued chunks for which there is + * no specific support. The idea is that we can use this to queue + * up private chunks for output even though the library doesn't actually + * know about their semantics. + *) + png_unknown_chunk = record + name : array[0..PNG_CHUNK_NAME_LENGTH-1] of png_byte; + data : Ppng_byte; + size : png_size_t; + + (* libpng-using applications should NOT directly modify this byte. *) + location : png_byte; (* mode of operation at read time *) + end; + ppng_unknown_chunk = ^png_unknown_chunk; + pppng_unknown_chunk = ^ppng_unknown_chunk; + png_unknown_chunk_t = png_unknown_chunk; + png_unknown_chunkp = Ppng_unknown_chunk; + png_unknown_chunkpp = PPpng_unknown_chunk; + + (* png_info is a structure that holds the information in a PNG file so + * that the application can find out the characteristics of the image. + * If you are reading the file, this structure will tell you what is + * in the PNG file. If you are writing the file, fill in the information + * you want to put into the PNG file, then call png_write_info(). + * The names chosen should be very close to the PNG specification, so + * consult that document for information about the meaning of each field. + * + * With libpng < 0.95, it was only possible to directly set and read the + * the values in the png_info_struct, which meant that the contents and + * order of the values had to remain fixed. With libpng 0.95 and later, + * however, there are now functions that abstract the contents of + * png_info_struct from the application, so this makes it easier to use + * libpng with dynamic libraries, and even makes it possible to use + * libraries that don't have all of the libpng ancillary chunk-handing + * functionality. + * + * In any case, the order of the parameters in png_info_struct should NOT + * be changed for as long as possible to keep compatibility with applications + * that use the old direct-access method with png_info_struct. + * + * The following members may have allocated storage attached that should be + * cleaned up before the structure is discarded: palette, trans, text, + * pcal_purpose, pcal_units, pcal_params, hist, iccp_name, iccp_profile, + * splt_palettes, scal_unit, row_pointers, and unknowns. By default, these + * are automatically freed when the info structure is deallocated, if they were + * allocated internally by libpng. This behavior can be changed by means + * of the png_data_freer() function. + * + * More allocation details: all the chunk-reading functions that + * change these members go through the corresponding png_set_* + * functions. A function to clear these members is available: see + * png_free_data(). The png_set_* functions do not depend on being + * able to point info structure members to any of the storage they are + * passed (they make their own copies), EXCEPT that the png_set_text + * functions use the same storage passed to them in the text_ptr or + * itxt_ptr structure argument, and the png_set_rows and png_set_unknowns + * functions do not make their own copies. + *) + png_info = record + width : png_uint_32; (* width of image in pixels (from IHDR) *) + height : png_uint_32; (* height of image in pixels (from IHDR) *) + valid : png_uint_32; (* valid chunk data (see PNG_INFO_ below) *) + rowbytes : png_uint_32; (* bytes needed to hold an untransformed row *) + palette : png_colorp; (* array of color values (valid & PNG_INFO_PLTE) *) + num_palette : png_uint_16; (* number of color entries in "palette" (PLTE) *) + num_trans : png_uint_16; (* number of transparent palette color (tRNS) *) + bit_depth : png_byte; (* 1, 2, 4, 8, or 16 bits/channel (from IHDR) *) + color_type : png_byte; (* see PNG_COLOR_TYPE_ below (from IHDR) *) + (* The following three should have been named *_method not *_type *) + compression_type : png_byte; (* must be PNG_COMPRESSION_TYPE_BASE (IHDR) *) + filter_type : png_byte; (* must be PNG_FILTER_TYPE_BASE (from IHDR) *) + interlace_type : png_byte; (* One of PNG_INTERLACE_NONE, PNG_INTERLACE_ADAM7 *) + + (* The following is informational only on read, and not used on writes. *) + channels : png_byte; (* number of data channels per pixel (1, 2, 3, 4) *) + pixel_depth : png_byte; (* number of bits per pixel *) + spare_byte : png_byte; (* to align the data, and for future use *) + signature : array[0..7] of png_byte; (* magic bytes read by libpng from start of file *) + + (* The rest of the data is optional. If you are reading, check the + * valid field to see if the information in these are valid. If you + * are writing, set the valid field to those chunks you want written, + * and initialize the appropriate fields below. + *) + + gamma : single; + srgb_intent : png_byte; + num_text : integer; + max_text : integer; + text : png_textp; + mod_time : png_time; + sig_bit : png_color_8; + trans : png_bytep; + trans_values : png_color_16; + background : png_color_16; + x_offset : png_int_32; + y_offset : png_int_32; + offset_unit_type : png_byte; + x_pixels_per_unit : png_uint_32; + y_pixels_per_unit : png_uint_32; + phys_unit_type : png_byte; + hist : png_uint_16p; + x_white : single; + y_white : single; + x_red : single; + y_red : single; + x_green : single; + y_green : single; + x_blue : single; + y_blue : single; + pcal_purpose : png_charp; + pcal_X0 : png_int_32; + pcal_X1 : png_int_32; + pcal_units : png_charp; + pcal_params : png_charpp; + pcal_type : png_byte; + pcal_nparams : png_byte; + free_me : png_uint_32; + unknown_chunks : png_unknown_chunkp; + unknown_chunks_num : png_size_t; + iccp_name : png_charp; + iccp_profile : png_charp; + iccp_proflen : png_uint_32; + iccp_compression : png_byte; + splt_palettes : png_sPLT_tp; + splt_palettes_num : png_uint_32; + scal_unit : png_byte; + scal_pixel_width : double; + scal_pixel_height : double; + scal_s_width : png_charp; + scal_s_height : png_charp; + row_pointers : png_bytepp; + int_gamma : png_fixed_point; + int_x_white : png_fixed_point; + int_y_white : png_fixed_point; + int_x_red : png_fixed_point; + int_y_red : png_fixed_point; + int_x_green : png_fixed_point; + int_y_green : png_fixed_point; + int_x_blue : png_fixed_point; + int_y_blue : png_fixed_point; + end; + ppng_info = ^png_info; + pppng_info = ^ppng_info; + png_info_struct = png_info; + png_infop = Ppng_info; + png_infopp = PPpng_info; + + (* This is used for the transformation routines, as some of them + * change these values for the row. It also should enable using + * the routines for other purposes. + *) + png_row_info = record + width : png_uint_32; (* width of row *) + rowbytes : png_uint_32; (* number of bytes in row *) + color_type : png_byte; (* color type of row *) + bit_depth : png_byte; (* bit depth of row *) + channels : png_byte; (* number of channels (1, 2, 3, or 4) *) + pixel_depth : png_byte; (* bits per pixel (depth * channels) *) + end; + ppng_row_info = ^png_row_info; + pppng_row_info = ^ppng_row_info; + png_row_info_struct = png_row_info; + png_row_infop = Ppng_row_info; + png_row_infopp = PPpng_row_info; + png_structp = ^png_struct; + + + (* These are the function types for the I/O functions and for the functions + * that allow the user to override the default I/O functions with his or her + * own. The png_error_ptr type should match that of user-supplied warning + * and error functions, while the png_rw_ptr type should match that of the + * user read/write data functions. + *) + png_error_ptr = procedure(Arg1 : png_structp; Arg2 : png_const_charp);cdecl; + png_rw_ptr = procedure(Arg1 : png_structp; Arg2 : png_bytep; Arg3 : png_size_t);cdecl; + png_flush_ptr = procedure (Arg1 : png_structp) ;cdecl; + png_read_status_ptr = procedure (Arg1 : png_structp; Arg2 : png_uint_32; Arg3: integer);cdecl; + png_write_status_ptr = procedure (Arg1 : png_structp; Arg2:png_uint_32;Arg3 : integer) ;cdecl; + png_progressive_info_ptr = procedure (Arg1 : png_structp; Arg2 : png_infop) ;cdecl; + png_progressive_end_ptr = procedure (Arg1 : png_structp; Arg2 : png_infop) ;cdecl; + png_progressive_row_ptr = procedure (Arg1 : png_structp; Arg2 : png_bytep; Arg3 : png_uint_32; Arg4 : integer) ;cdecl; + png_user_transform_ptr = procedure (Arg1 : png_structp; Arg2 : png_row_infop; Arg3 : png_bytep) ;cdecl; + png_user_chunk_ptr = function (Arg1 : png_structp; Arg2 : png_unknown_chunkp): integer;cdecl; + png_unknown_chunk_ptr = procedure (Arg1 : png_structp);cdecl; + png_malloc_ptr = function (Arg1 : png_structp; Arg2 : png_size_t) : png_voidp ;cdecl; + png_free_ptr = procedure (Arg1 : png_structp; Arg2 : png_voidp) ; cdecl; + + png_struct_def = record + {$ifdef UsePngStruct} + jmpbuf : jmp_buf; (* used in png_error *) + error_fn : png_error_ptr; (* function for printing errors and aborting *) + warning_fn : png_error_ptr; (* function for printing warnings *) + error_ptr : png_voidp; (* user supplied struct for error functions *) + write_data_fn : png_rw_ptr; (* function for writing output data *) + read_data_fn : png_rw_ptr; (* function for reading input data *) + io_ptr : png_voidp; (* ptr to application struct for I/O functions *) + + read_user_transform_fn : png_user_transform_ptr; (* user read transform *) + + write_user_transform_fn : png_user_transform_ptr; (* user write transform *) + + (* These were added in libpng-1.0.2 *) + user_transform_ptr : png_voidp; (* user supplied struct for user transform *) + user_transform_depth : png_byte; (* bit depth of user transformed pixels *) + user_transform_channels : png_byte; (* channels in user transformed pixels *) + + mode : png_uint_32; (* tells us where we are in the PNG file *) + flags : png_uint_32; (* flags indicating various things to libpng *) + transformations : png_uint_32; (* which transformations to perform *) + + zstream : z_stream; (* pointer to decompression structure (below) *) + zbuf : png_bytep; (* buffer for zlib *) + zbuf_size : png_size_t; (* size of zbuf *) + zlib_level : integer; (* holds zlib compression level *) + zlib_method : integer; (* holds zlib compression method *) + zlib_window_bits : integer; (* holds zlib compression window bits *) + zlib_mem_level : integer; (* holds zlib compression memory level *) + zlib_strategy : integer; (* holds zlib compression strategy *) + + width : png_uint_32; (* width of image in pixels *) + height : png_uint_32; (* height of image in pixels *) + num_rows : png_uint_32; (* number of rows in current pass *) + usr_width : png_uint_32; (* width of row at start of write *) + rowbytes : png_uint_32; (* size of row in bytes *) + irowbytes : png_uint_32; (* size of current interlaced row in bytes *) + iwidth : png_uint_32; (* width of current interlaced row in pixels *) + row_number : png_uint_32; (* current row in interlace pass *) + prev_row : png_bytep; (* buffer to save previous (unfiltered) row *) + row_buf : png_bytep; (* buffer to save current (unfiltered) row *) + sub_row : png_bytep; (* buffer to save "sub" row when filtering *) + up_row : png_bytep; (* buffer to save "up" row when filtering *) + avg_row : png_bytep; (* buffer to save "avg" row when filtering *) + paeth_row : png_bytep; (* buffer to save "Paeth" row when filtering *) + row_info : png_row_info; (* used for transformation routines *) + + idat_size : png_uint_32; (* current IDAT size for read *) + crc : png_uint_32; (* current chunk CRC value *) + palette : png_colorp; (* palette from the input file *) + num_palette : png_uint_16; (* number of color entries in palette *) + num_trans : png_uint_16; (* number of transparency values *) + chunk_name : array[0..4] of png_byte; (* null-terminated name of current chunk *) + compression : png_byte; (* file compression type (always 0) *) + filter : png_byte; (* file filter type (always 0) *) + interlaced : png_byte; (* PNG_INTERLACE_NONE, PNG_INTERLACE_ADAM7 *) + pass : png_byte; (* current interlace pass (0 - 6) *) + do_filter : png_byte; (* row filter flags (see PNG_FILTER_ below ) *) + color_type : png_byte; (* color type of file *) + bit_depth : png_byte; (* bit depth of file *) + usr_bit_depth : png_byte; (* bit depth of users row *) + pixel_depth : png_byte; (* number of bits per pixel *) + channels : png_byte; (* number of channels in file *) + usr_channels : png_byte; (* channels at start of write *) + sig_bytes : png_byte; (* magic bytes read/written from start of file *) + + filler : png_uint_16; + + background_gamma_type : png_byte; + background_gamma : single; + background : png_color_16; + background_1 : png_color_16; + output_flush_fn : png_flush_ptr; + flush_dist : png_uint_32; + flush_rows : png_uint_32; + gamma_shift : integer; + gamma : single; + screen_gamma : single; + gamma_table : png_bytep; + gamma_from_1 : png_bytep; + gamma_to_1 : png_bytep; + gamma_16_table : png_uint_16pp; + gamma_16_from_1 : png_uint_16pp; + gamma_16_to_1 : png_uint_16pp; + sig_bit : png_color_8; + shift : png_color_8; + trans : png_bytep; + trans_values : png_color_16; + read_row_fn : png_read_status_ptr; + write_row_fn : png_write_status_ptr; + info_fn : png_progressive_info_ptr; + row_fn : png_progressive_row_ptr; + end_fn : png_progressive_end_ptr; + save_buffer_ptr : png_bytep; + save_buffer : png_bytep; + current_buffer_ptr : png_bytep; + current_buffer : png_bytep; + push_length : png_uint_32; + skip_length : png_uint_32; + save_buffer_size : png_size_t; + save_buffer_max : png_size_t; + buffer_size : png_size_t; + current_buffer_size : png_size_t; + process_mode : integer; + cur_palette : integer; + current_text_size : png_size_t; + current_text_left : png_size_t; + current_text : png_charp; + current_text_ptr : png_charp; + palette_lookup : png_bytep; + dither_index : png_bytep; + hist : png_uint_16p; + heuristic_method : png_byte; + num_prev_filters : png_byte; + prev_filters : png_bytep; + filter_weights : png_uint_16p; + inv_filter_weights : png_uint_16p; + filter_costs : png_uint_16p; + inv_filter_costs : png_uint_16p; + time_buffer : png_charp; + free_me : png_uint_32; + user_chunk_ptr : png_voidp; + read_user_chunk_fn : png_user_chunk_ptr; + num_chunk_list : integer; + chunk_list : png_bytep; + rgb_to_gray_status : png_byte; + rgb_to_gray_red_coeff : png_uint_16; + rgb_to_gray_green_coeff : png_uint_16; + rgb_to_gray_blue_coeff : png_uint_16; + empty_plte_permitted : png_byte; + int_gamma : png_fixed_point; + {$endif UsePngStruct} + end; + ppng_struct_def = ^png_struct_def; + pppng_struct_def = ^ppng_struct_def; + png_struct = png_struct_def; + ppng_struct = ^png_struct; + pppng_struct = ^ppng_struct; + + version_1_0_8 = png_structp; + png_structpp = PPpng_struct; + +function png_access_version_number:png_uint_32;cdecl; external LibPng; + +procedure png_set_sig_bytes(png_ptr:png_structp; num_bytes:integer);cdecl; external LibPng; +function png_sig_cmp(sig:png_bytep; start:png_size_t; num_to_check:png_size_t):integer;cdecl; external LibPng; +function png_check_sig(sig:png_bytep; num:integer):integer;cdecl; external LibPng; + +(* Allocate and initialize png_ptr struct for reading, and any other memory. *) +function png_create_read_struct(user_png_ver:png_const_charp; error_ptr:png_voidp; error_fn:png_error_ptr; warn_fn:png_error_ptr):png_structp;cdecl; external LibPng; + +(* Allocate and initialize png_ptr struct for writing, and any other memory *) +function png_create_write_struct(user_png_ver:png_const_charp; error_ptr:png_voidp; error_fn:png_error_ptr; warn_fn:png_error_ptr):png_structp;cdecl; external LibPng; + +function png_get_compression_buffer_size(png_ptr:png_structp):png_uint_32;cdecl; external LibPng; +procedure png_set_compression_buffer_size(png_ptr:png_structp; size:png_uint_32);cdecl; external LibPng; +function png_reset_zstream(png_ptr:png_structp):integer;cdecl; external LibPng; + +procedure png_write_chunk(png_ptr:png_structp; chunk_name:png_bytep; data:png_bytep; length:png_size_t);cdecl; external LibPng; +procedure png_write_chunk_start(png_ptr:png_structp; chunk_name:png_bytep; length:png_uint_32);cdecl; external LibPng; +procedure png_write_chunk_data(png_ptr:png_structp; data:png_bytep; length:png_size_t);cdecl; external LibPng; +procedure png_write_chunk_end(png_ptr:png_structp);cdecl; external LibPng; + +(* Allocate and initialize the info structure *) +function png_create_info_struct(png_ptr:png_structp):png_infop;cdecl; external LibPng; + +(* Initialize the info structure (old interface - DEPRECATED) *) +procedure png_info_init(info_ptr:png_infop);cdecl; external LibPng; + +(* Writes all the PNG information before the image. *) +procedure png_write_info_before_PLTE(png_ptr:png_structp; info_ptr:png_infop);cdecl; external LibPng; +procedure png_write_info(png_ptr:png_structp; info_ptr:png_infop);cdecl; external LibPng; + +(* read the information before the actual image data. *) +procedure png_read_info(png_ptr:png_structp; info_ptr:png_infop);cdecl; external LibPng; + +function png_convert_to_rfc1123(png_ptr:png_structp; ptime:png_timep):png_charp;cdecl; external LibPng; +procedure png_convert_from_struct_tm(ptime:png_timep; ttime:Pointer);cdecl; external LibPng; +{$IFDEF UNIX} +procedure png_convert_from_time_t(ptime:png_timep; ttime:time_t);cdecl; external LibPng; +{$ENDIF} +procedure png_set_expand(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_gray_1_2_4_to_8(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_palette_to_rgb(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_tRNS_to_alpha(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_bgr(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_gray_to_rgb(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_rgb_to_gray(png_ptr:png_structp; error_action:integer; red:double; green:double);cdecl; external LibPng; +procedure png_set_rgb_to_gray_fixed(png_ptr:png_structp; error_action:integer; red:png_fixed_point; green:png_fixed_point);cdecl; external LibPng; +function png_get_rgb_to_gray_status(png_ptr:png_structp):png_byte;cdecl; external LibPng; +procedure png_build_grayscale_palette(bit_depth:integer; palette:png_colorp);cdecl; external LibPng; +procedure png_set_strip_alpha(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_swap_alpha(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_invert_alpha(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_filler(png_ptr:png_structp; filler:png_uint_32; flags:integer);cdecl; external LibPng; +procedure png_set_swap(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_packing(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_packswap(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_shift(png_ptr:png_structp; true_bits:png_color_8p);cdecl; external LibPng; +function png_set_interlace_handling(png_ptr:png_structp):integer;cdecl; external LibPng; +procedure png_set_invert_mono(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_background(png_ptr:png_structp; background_color:png_color_16p; background_gamma_code:integer; need_expand:integer; background_gamma:double);cdecl; external LibPng; +procedure png_set_strip_16(png_ptr:png_structp);cdecl; external LibPng; +procedure png_set_dither(png_ptr:png_structp; palette:png_colorp; num_palette:integer; maximum_colors:integer; histogram:png_uint_16p; + full_dither:integer);cdecl; external LibPng; +procedure png_set_gamma(png_ptr:png_structp; screen_gamma:double; default_file_gamma:double);cdecl; external LibPng; +procedure png_permit_empty_plte(png_ptr:png_structp; empty_plte_permitted:integer);cdecl; external LibPng; +procedure png_set_flush(png_ptr:png_structp; nrows:integer);cdecl; external LibPng; +procedure png_write_flush(png_ptr:png_structp);cdecl; external LibPng; +procedure png_start_read_image(png_ptr:png_structp);cdecl; external LibPng; +procedure png_read_update_info(png_ptr:png_structp; info_ptr:png_infop);cdecl; external LibPng; + +(* read one or more rows of image data. *) +procedure png_read_rows(png_ptr:png_structp; row:png_bytepp; display_row:png_bytepp; num_rows:png_uint_32);cdecl; external LibPng; + +(* read a row of data. *) +procedure png_read_row(png_ptr:png_structp; row:png_bytep; display_row:png_bytep);cdecl; external LibPng; + +(* read the whole image into memory at once. *) +procedure png_read_image(png_ptr:png_structp; image:png_bytepp);cdecl; external LibPng; + +(* write a row of image data *) +procedure png_write_row(png_ptr:png_structp; row:png_bytep);cdecl; external LibPng; + +(* write a few rows of image data *) +procedure png_write_rows(png_ptr:png_structp; row:png_bytepp; num_rows:png_uint_32);cdecl; external LibPng; + +(* write the image data *) +procedure png_write_image(png_ptr:png_structp; image:png_bytepp);cdecl; external LibPng; + +(* writes the end of the PNG file. *) +procedure png_write_end(png_ptr:png_structp; info_ptr:png_infop);cdecl; external LibPng; + +(* read the end of the PNG file. *) +procedure png_read_end(png_ptr:png_structp; info_ptr:png_infop);cdecl; external LibPng; + +(* free any memory associated with the png_info_struct *) +procedure png_destroy_info_struct(png_ptr:png_structp; info_ptr_ptr:png_infopp);cdecl; external LibPng; + +(* free any memory associated with the png_struct and the png_info_structs *) +procedure png_destroy_read_struct(png_ptr_ptr:png_structpp; info_ptr_ptr:png_infopp; end_info_ptr_ptr:png_infopp);cdecl; external LibPng; + +(* free all memory used by the read (old method - NOT DLL EXPORTED) *) +procedure png_read_destroy(png_ptr:png_structp; info_ptr:png_infop; end_info_ptr:png_infop);cdecl; external LibPng; + +(* free any memory associated with the png_struct and the png_info_structs *) +procedure png_destroy_write_struct(png_ptr_ptr:png_structpp; info_ptr_ptr:png_infopp);cdecl; external LibPng; + +procedure png_write_destroy_info(info_ptr:png_infop);cdecl; external LibPng; +procedure png_write_destroy(png_ptr:png_structp);cdecl; external LibPng; + +procedure png_set_crc_action(png_ptr:png_structp; crit_action:integer; ancil_action:integer);cdecl; external LibPng; + +procedure png_set_filter(png_ptr:png_structp; method:integer; filters:integer);cdecl; external LibPng; +procedure png_set_filter_heuristics(png_ptr:png_structp; heuristic_method:integer; num_weights:integer; filter_weights:png_doublep; filter_costs:png_doublep);cdecl; external LibPng; + +procedure png_set_compression_level(png_ptr:png_structp; level:integer);cdecl; external LibPng; +procedure png_set_compression_mem_level(png_ptr:png_structp; mem_level:integer);cdecl; external LibPng; +procedure png_set_compression_strategy(png_ptr:png_structp; strategy:integer);cdecl; external LibPng; +procedure png_set_compression_window_bits(png_ptr:png_structp; window_bits:integer);cdecl; external LibPng; +procedure png_set_compression_method(png_ptr:png_structp; method:integer);cdecl; external LibPng; + +procedure png_init_io(png_ptr:png_structp; fp:png_FILE_p);cdecl; external LibPng; + +(* Replace the (error and abort), and warning functions with user + * supplied functions. If no messages are to be printed you must still + * write and use replacement functions. The replacement error_fn should + * still do a longjmp to the last setjmp location if you are using this + * method of error handling. If error_fn or warning_fn is NULL, the + * default function will be used. + *) +procedure png_set_error_fn(png_ptr:png_structp; error_ptr:png_voidp; error_fn:png_error_ptr; warning_fn:png_error_ptr);cdecl; external LibPng; + +(* Return the user pointer associated with the error functions *) +function png_get_error_ptr(png_ptr:png_structp):png_voidp;cdecl; external LibPng; + +(* Replace the default data output functions with a user supplied one(s). + * If buffered output is not used, then output_flush_fn can be set to NULL. + * If PNG_WRITE_FLUSH_SUPPORTED is not defined at libpng compile time + * output_flush_fn will be ignored (and thus can be NULL). + *) +procedure png_set_write_fn(png_ptr:png_structp; io_ptr:png_voidp; write_data_fn:png_rw_ptr; output_flush_fn:png_flush_ptr);cdecl; external LibPng; + +(* Replace the default data input function with a user supplied one. *) +procedure png_set_read_fn(png_ptr:png_structp; io_ptr:png_voidp; read_data_fn:png_rw_ptr);cdecl; external LibPng; + +(* Return the user pointer associated with the I/O functions *) +function png_get_io_ptr(png_ptr:png_structp):png_voidp;cdecl; external LibPng; + +procedure png_set_read_status_fn(png_ptr:png_structp; read_row_fn:png_read_status_ptr);cdecl; external LibPng; +procedure png_set_write_status_fn(png_ptr:png_structp; write_row_fn:png_write_status_ptr);cdecl; external LibPng; +procedure png_set_read_user_transform_fn(png_ptr:png_structp; read_user_transform_fn:png_user_transform_ptr);cdecl; external LibPng; +procedure png_set_write_user_transform_fn(png_ptr:png_structp; write_user_transform_fn:png_user_transform_ptr);cdecl; external LibPng; +procedure png_set_user_transform_info(png_ptr:png_structp; user_transform_ptr:png_voidp; user_transform_depth:integer; user_transform_channels:integer);cdecl; external LibPng; +function png_get_user_transform_ptr(png_ptr:png_structp):png_voidp;cdecl; external LibPng; +procedure png_set_read_user_chunk_fn(png_ptr:png_structp; user_chunk_ptr:png_voidp; read_user_chunk_fn:png_user_chunk_ptr);cdecl; external LibPng; +function png_get_user_chunk_ptr(png_ptr:png_structp):png_voidp;cdecl; external LibPng; +procedure png_set_progressive_read_fn(png_ptr:png_structp; progressive_ptr:png_voidp; info_fn:png_progressive_info_ptr; row_fn:png_progressive_row_ptr; end_fn:png_progressive_end_ptr);cdecl; external LibPng; +function png_get_progressive_ptr(png_ptr:png_structp):png_voidp;cdecl; external LibPng; +procedure png_process_data(png_ptr:png_structp; info_ptr:png_infop; buffer:png_bytep; buffer_size:png_size_t);cdecl; external LibPng; +procedure png_progressive_combine_row(png_ptr:png_structp; old_row:png_bytep; new_row:png_bytep);cdecl; external LibPng; +function png_malloc(png_ptr:png_structp; size:png_uint_32):png_voidp;cdecl; external LibPng; +procedure png_free(png_ptr:png_structp; ptr:png_voidp);cdecl; external LibPng; +procedure png_free_data(png_ptr:png_structp; info_ptr:png_infop; free_me:png_uint_32; num:integer);cdecl; external LibPng; +procedure png_data_freer(png_ptr:png_structp; info_ptr:png_infop; freer:integer; mask:png_uint_32);cdecl; external LibPng; +function png_memcpy_check(png_ptr:png_structp; s1:png_voidp; s2:png_voidp; size:png_uint_32):png_voidp;cdecl; external LibPng; +function png_memset_check(png_ptr:png_structp; s1:png_voidp; value:integer; size:png_uint_32):png_voidp;cdecl; external LibPng; +procedure png_error(png_ptr:png_structp; error:png_const_charp);cdecl; external LibPng; +procedure png_chunk_error(png_ptr:png_structp; error:png_const_charp);cdecl; external LibPng; +procedure png_warning(png_ptr:png_structp; message:png_const_charp);cdecl; external LibPng; +procedure png_chunk_warning(png_ptr:png_structp; message:png_const_charp);cdecl; external LibPng; +function png_get_valid(png_ptr:png_structp; info_ptr:png_infop; flag:png_uint_32):png_uint_32;cdecl; external LibPng; +function png_get_rowbytes(png_ptr:png_structp; info_ptr:png_infop):png_uint_32;cdecl; external LibPng; +function png_get_rows(png_ptr:png_structp; info_ptr:png_infop):png_bytepp;cdecl; external LibPng; +procedure png_set_rows(png_ptr:png_structp; info_ptr:png_infop; row_pointers:png_bytepp);cdecl; external LibPng; +function png_get_channels(png_ptr:png_structp; info_ptr:png_infop):png_byte;cdecl; external LibPng; +function png_get_image_width(png_ptr:png_structp; info_ptr:png_infop):png_uint_32;cdecl; external LibPng; +function png_get_image_height(png_ptr:png_structp; info_ptr:png_infop):png_uint_32;cdecl; external LibPng; +function png_get_bit_depth(png_ptr:png_structp; info_ptr:png_infop):png_byte;cdecl; external LibPng; +function png_get_color_type(png_ptr:png_structp; info_ptr:png_infop):png_byte;cdecl; external LibPng; +function png_get_filter_type(png_ptr:png_structp; info_ptr:png_infop):png_byte;cdecl; external LibPng; +function png_get_interlace_type(png_ptr:png_structp; info_ptr:png_infop):png_byte;cdecl; external LibPng; +function png_get_compression_type(png_ptr:png_structp; info_ptr:png_infop):png_byte;cdecl; external LibPng; +function png_get_pixels_per_meter(png_ptr:png_structp; info_ptr:png_infop):png_uint_32;cdecl; external LibPng; +function png_get_x_pixels_per_meter(png_ptr:png_structp; info_ptr:png_infop):png_uint_32;cdecl; external LibPng; +function png_get_y_pixels_per_meter(png_ptr:png_structp; info_ptr:png_infop):png_uint_32;cdecl; external LibPng; +function png_get_pixel_aspect_ratio(png_ptr:png_structp; info_ptr:png_infop):single;cdecl; external LibPng; +function png_get_x_offset_pixels(png_ptr:png_structp; info_ptr:png_infop):png_int_32;cdecl; external LibPng; +function png_get_y_offset_pixels(png_ptr:png_structp; info_ptr:png_infop):png_int_32;cdecl; external LibPng; +function png_get_x_offset_microns(png_ptr:png_structp; info_ptr:png_infop):png_int_32;cdecl; external LibPng; +function png_get_y_offset_microns(png_ptr:png_structp; info_ptr:png_infop):png_int_32;cdecl; external LibPng; +function png_get_signature(png_ptr:png_structp; info_ptr:png_infop):png_bytep;cdecl; external LibPng; + +function png_get_bKGD(png_ptr:png_structp; info_ptr:png_infop; background:Ppng_color_16p):png_uint_32;cdecl; external LibPng; +procedure png_set_bKGD(png_ptr:png_structp; info_ptr:png_infop; background:png_color_16p);cdecl; external LibPng; +function png_get_cHRM(png_ptr:png_structp; info_ptr:png_infop; white_x:Pdouble; white_y:Pdouble; red_x:Pdouble; + red_y:Pdouble; green_x:Pdouble; green_y:Pdouble; blue_x:Pdouble; blue_y:Pdouble):png_uint_32;cdecl; external LibPng; +function png_get_cHRM_fixed(png_ptr:png_structp; info_ptr:png_infop; int_white_x:Ppng_fixed_point; int_white_y:Ppng_fixed_point; int_red_x:Ppng_fixed_point; + int_red_y:Ppng_fixed_point; int_green_x:Ppng_fixed_point; int_green_y:Ppng_fixed_point; int_blue_x:Ppng_fixed_point; int_blue_y:Ppng_fixed_point):png_uint_32;cdecl; external LibPng; +procedure png_set_cHRM(png_ptr:png_structp; info_ptr:png_infop; white_x:double; white_y:double; red_x:double; + red_y:double; green_x:double; green_y:double; blue_x:double; blue_y:double);cdecl; external LibPng; +procedure png_set_cHRM_fixed(png_ptr:png_structp; info_ptr:png_infop; int_white_x:png_fixed_point; int_white_y:png_fixed_point; int_red_x:png_fixed_point; + int_red_y:png_fixed_point; int_green_x:png_fixed_point; int_green_y:png_fixed_point; int_blue_x:png_fixed_point; int_blue_y:png_fixed_point);cdecl; external LibPng; +function png_get_gAMA(png_ptr:png_structp; info_ptr:png_infop; file_gamma:Pdouble):png_uint_32;cdecl; external LibPng; +function png_get_gAMA_fixed(png_ptr:png_structp; info_ptr:png_infop; int_file_gamma:Ppng_fixed_point):png_uint_32;cdecl; external LibPng; +procedure png_set_gAMA(png_ptr:png_structp; info_ptr:png_infop; file_gamma:double);cdecl; external LibPng; +procedure png_set_gAMA_fixed(png_ptr:png_structp; info_ptr:png_infop; int_file_gamma:png_fixed_point);cdecl; external LibPng; +function png_get_hIST(png_ptr:png_structp; info_ptr:png_infop; hist:Ppng_uint_16p):png_uint_32;cdecl; external LibPng; +procedure png_set_hIST(png_ptr:png_structp; info_ptr:png_infop; hist:png_uint_16p);cdecl; external LibPng; +function png_get_IHDR(png_ptr:png_structp; info_ptr:png_infop; width:Ppng_uint_32; height:Ppng_uint_32; bit_depth:Pinteger; + color_type:Pinteger; interlace_type:Pinteger; compression_type:Pinteger; filter_type:Pinteger):png_uint_32;cdecl; external LibPng; +procedure png_set_IHDR(png_ptr:png_structp; info_ptr:png_infop; width:png_uint_32; height:png_uint_32; bit_depth:integer; + color_type:integer; interlace_type:integer; compression_type:integer; filter_type:integer);cdecl; external LibPng; +function png_get_oFFs(png_ptr:png_structp; info_ptr:png_infop; offset_x:Ppng_int_32; offset_y:Ppng_int_32; unit_type:Pinteger):png_uint_32;cdecl; external LibPng; +procedure png_set_oFFs(png_ptr:png_structp; info_ptr:png_infop; offset_x:png_int_32; offset_y:png_int_32; unit_type:integer);cdecl; external LibPng; +function png_get_pCAL(png_ptr:png_structp; info_ptr:png_infop; purpose:Ppng_charp; X0:Ppng_int_32; X1:Ppng_int_32; + atype:Pinteger; nparams:Pinteger; units:Ppng_charp; params:Ppng_charpp):png_uint_32;cdecl; external LibPng; +procedure png_set_pCAL(png_ptr:png_structp; info_ptr:png_infop; purpose:png_charp; X0:png_int_32; X1:png_int_32; + atype:integer; nparams:integer; units:png_charp; params:png_charpp);cdecl; external LibPng; +function png_get_pHYs(png_ptr:png_structp; info_ptr:png_infop; res_x:Ppng_uint_32; res_y:Ppng_uint_32; unit_type:Pinteger):png_uint_32;cdecl; external LibPng; +procedure png_set_pHYs(png_ptr:png_structp; info_ptr:png_infop; res_x:png_uint_32; res_y:png_uint_32; unit_type:integer);cdecl; external LibPng; +function png_get_PLTE(png_ptr:png_structp; info_ptr:png_infop; palette:Ppng_colorp; num_palette:Pinteger):png_uint_32;cdecl; external LibPng; +procedure png_set_PLTE(png_ptr:png_structp; info_ptr:png_infop; palette:png_colorp; num_palette:integer);cdecl; external LibPng; +function png_get_sBIT(png_ptr:png_structp; info_ptr:png_infop; sig_bit:Ppng_color_8p):png_uint_32;cdecl; external LibPng; +procedure png_set_sBIT(png_ptr:png_structp; info_ptr:png_infop; sig_bit:png_color_8p);cdecl; external LibPng; +function png_get_sRGB(png_ptr:png_structp; info_ptr:png_infop; intent:Pinteger):png_uint_32;cdecl; external LibPng; +procedure png_set_sRGB(png_ptr:png_structp; info_ptr:png_infop; intent:integer);cdecl; external LibPng; +procedure png_set_sRGB_gAMA_and_cHRM(png_ptr:png_structp; info_ptr:png_infop; intent:integer);cdecl; external LibPng; +function png_get_iCCP(png_ptr:png_structp; info_ptr:png_infop; name:png_charpp; compression_type:Pinteger; profile:png_charpp; + proflen:Ppng_uint_32):png_uint_32;cdecl; external LibPng; +procedure png_set_iCCP(png_ptr:png_structp; info_ptr:png_infop; name:png_charp; compression_type:integer; profile:png_charp; + proflen:png_uint_32);cdecl; external LibPng; +function png_get_sPLT(png_ptr:png_structp; info_ptr:png_infop; entries:png_sPLT_tpp):png_uint_32;cdecl; external LibPng; +procedure png_set_sPLT(png_ptr:png_structp; info_ptr:png_infop; entries:png_sPLT_tp; nentries:integer);cdecl; external LibPng; + +(* png_get_text also returns the number of text chunks in *num_text *) +function png_get_text(png_ptr:png_structp; info_ptr:png_infop; text_ptr:Ppng_textp; num_text:Pinteger):png_uint_32;cdecl; external LibPng; + +(* + * Note while png_set_text() will accept a structure whose text, + * language, and translated keywords are NULL pointers, the structure + * returned by png_get_text will always contain regular + * zero-terminated C strings. They might be empty strings but + * they will never be NULL pointers. + *) +procedure png_set_text(png_ptr:png_structp; info_ptr:png_infop; text_ptr:png_textp; num_text:integer);cdecl; external LibPng; + +function png_get_tIME(png_ptr:png_structp; info_ptr:png_infop; mod_time:Ppng_timep):png_uint_32;cdecl; external LibPng; +procedure png_set_tIME(png_ptr:png_structp; info_ptr:png_infop; mod_time:png_timep);cdecl; external LibPng; +function png_get_tRNS(png_ptr:png_structp; info_ptr:png_infop; trans:Ppng_bytep; num_trans:Pinteger; trans_values:Ppng_color_16p):png_uint_32;cdecl; external LibPng; +procedure png_set_tRNS(png_ptr:png_structp; info_ptr:png_infop; trans:png_bytep; num_trans:integer; trans_values:png_color_16p);cdecl; external LibPng; +function png_get_sCAL(png_ptr:png_structp; info_ptr:png_infop; aunit:Pinteger; width:Pdouble; height:Pdouble):png_uint_32;cdecl; external LibPng; +procedure png_set_sCAL(png_ptr:png_structp; info_ptr:png_infop; aunit:integer; width:double; height:double);cdecl; external LibPng; +procedure png_set_sCAL_s(png_ptr:png_structp; info_ptr:png_infop; aunit:integer; swidth:png_charp; sheight:png_charp);cdecl; external LibPng; + +procedure png_set_keep_unknown_chunks(png_ptr:png_structp; keep:integer; chunk_list:png_bytep; num_chunks:integer);cdecl; external LibPng; +procedure png_set_unknown_chunks(png_ptr:png_structp; info_ptr:png_infop; unknowns:png_unknown_chunkp; num_unknowns:integer);cdecl; external LibPng; +procedure png_set_unknown_chunk_location(png_ptr:png_structp; info_ptr:png_infop; chunk:integer; location:integer);cdecl; external LibPng; +function png_get_unknown_chunks(png_ptr:png_structp; info_ptr:png_infop; entries:png_unknown_chunkpp):png_uint_32;cdecl; external LibPng; + +procedure png_set_invalid(png_ptr:png_structp; info_ptr:png_infop; mask:integer);cdecl; external LibPng; + +procedure png_read_png(png_ptr:png_structp; info_ptr:png_infop; transforms:integer; params:png_voidp);cdecl; external LibPng; +procedure png_write_png(png_ptr:png_structp; info_ptr:png_infop; transforms:integer; params:png_voidp);cdecl; external LibPng; + +function png_get_header_ver(png_ptr:png_structp):png_charp;cdecl; external LibPng; +function png_get_header_version(png_ptr:png_structp):png_charp;cdecl; external LibPng; +function png_get_libpng_ver(png_ptr:png_structp):png_charp;cdecl; external LibPng; + +implementation + +end. diff --git a/Game/Code/lib/zlib/zlib.pas b/Game/Code/lib/zlib/zlib.pas new file mode 100644 index 00000000..8c8362ba --- /dev/null +++ b/Game/Code/lib/zlib/zlib.pas @@ -0,0 +1,207 @@ +(* + * zlib pascal headers + * This file is part of Free Pascal, released under the LGPL. + *) + +{$ifdef FPC} + {$ifndef NO_SMART_LINK} + {$smartlink on} + {$endif} +{$endif} +unit zlib; + +interface + +{$ifdef FPC} + {$mode objfpc} // Needed for array of const + {$PACKRECORDS C} +{$endif} + +const + ZLIB_VERSION = '1.2.3'; + +{$ifdef MSWINDOWS} + libz = 'zlib1'; +{$else} + libz = 'z'; +{$endif} + +type + { Compatible with paszlib } + Uint = Cardinal; + Ulong = Longword; + Ulongf = Longword; + Pulongf = ^Ulongf; + z_off_t = longint; + pbyte = ^byte; + pbytef = ^byte; + voidpf = pointer; + + TAllocfunc = function (opaque: voidpf; items: uInt; size: uInt): voidpf; cdecl; + TFreeFunc = procedure (opaque: voidpf; address: voidpf); cdecl; + + TInternalState = record + end; + PInternalState = ^TInternalstate; + + TZStream = record + next_in: pbytef; + avail_in: uInt; + total_in: uLong; + next_out: pbytef; + avail_out: uInt; + total_out: uLong; + msg: pchar; + state: PInternalState; + zalloc: TAllocFunc; + zfree: TFreeFunc; + opaque: voidpf; + data_type: integer; + adler: uLong; + reserved: uLong; + end; + TZStreamRec = TZStream; + PZstream = ^TZStream; + gzFile = pointer; + + +const + Z_NO_FLUSH = 0; + Z_PARTIAL_FLUSH = 1; + Z_SYNC_FLUSH = 2; + Z_FULL_FLUSH = 3; + Z_FINISH = 4; + Z_BLOCK = 5; + + Z_OK = 0; + Z_STREAM_END = 1; + Z_NEED_DICT = 2; + Z_ERRNO = -(1); + Z_STREAM_ERROR = -(2); + Z_DATA_ERROR = -(3); + Z_MEM_ERROR = -(4); + Z_BUF_ERROR = -(5); + Z_VERSION_ERROR = -(6); + + Z_NO_COMPRESSION = 0; + Z_BEST_SPEED = 1; + Z_BEST_COMPRESSION = 9; + Z_DEFAULT_COMPRESSION = -(1); + + Z_FILTERED = 1; + Z_HUFFMAN_ONLY = 2; + Z_RLE = 3; + Z_FIXED = 4; + Z_DEFAULT_STRATEGY = 0; + + Z_BINARY = 0; + Z_TEXT = 1; + Z_ASCII = Z_TEXT; + Z_UNKNOWN = 2; + + Z_DEFLATED = 8; + + Z_NULL = 0; + +function zlibVersionpchar(): pchar; cdecl; external libz name 'zlibVersion'; +function zlibVersion(): string; + +function deflate(var strm: TZStream; flush: integer): integer; cdecl; external libz name 'deflate'; +function deflateEnd(var strm: TZStream): integer; cdecl; external libz name 'deflateEnd'; +function inflate(var strm: TZStream; flush: integer): integer; cdecl; external libz name 'inflate'; +function inflateEnd(var strm: TZStream): integer; cdecl; external libz name 'inflateEnd'; +function deflateSetDictionary(var strm: TZStream; dictionary: pbytef; dictLength: uInt): integer; cdecl; external libz name 'deflateSetDictionary'; +function deflateCopy(var dest, source: TZstream): integer; cdecl; external libz name 'deflateCopy'; +function deflateReset(var strm: TZStream): integer; cdecl; external libz name 'deflateReset'; +function deflateParams(var strm: TZStream; level: integer; strategy: integer): integer; cdecl; external libz name 'deflateParams'; +//... +function inflateSetDictionary(var strm: TZStream; dictionary: pbytef; dictLength: uInt): integer; cdecl; external libz name 'inflateSetDictionary'; +function inflateSync(var strm: TZStream): integer; cdecl; external libz name 'inflateSync'; +//... +function inflateReset(var strm: TZStream): integer; cdecl; external libz name 'inflateReset'; + +function compress(dest: pbytef; destLen: puLongf; source : pbytef; sourceLen: uLong): integer; cdecl; external libz name 'compress'; +function compress2(dest: pbytef; destLen: puLongf; source : pbytef; sourceLen: uLong; level: integer): integer; cdecl; external libz name 'compress2'; +function uncompress(dest: pbytef; destLen: puLongf; source : pbytef; sourceLen: uLong): integer; cdecl; external libz name 'uncompress'; + +function gzopen(path: pchar; mode: pchar): gzFile; cdecl; external libz name 'gzopen'; +function gzdopen(fd: integer; mode: pchar): gzFile; cdecl; external libz name 'gzdopen'; +function gzsetparams(thefile: gzFile; level: integer; strategy: integer): integer; cdecl; external libz name 'gzsetparams'; +function gzread(thefile: gzFile; buf: pointer; len: cardinal): integer; cdecl; external libz name 'gzread'; +function gzwrite(thefile: gzFile; buf: pointer; len: cardinal): integer; cdecl; external libz name 'gzwrite'; +function gzprintf(thefile: gzFile; format: pbytef; args: array of const): integer; cdecl; external libz name 'gzprintf'; +function gzputs(thefile: gzFile; s: pbytef): integer; cdecl; external libz name 'gzputs'; +function gzgets(thefile: gzFile; buf: pbytef; len: integer): pchar; cdecl; external libz name 'gzgets'; +function gzputc(thefile: gzFile; c: integer): integer; cdecl; external libz name 'gzputc'; +function gzgetc(thefile: gzFile): integer; cdecl; external libz name 'gzgetc'; +function gzflush(thefile: gzFile; flush: integer): integer; cdecl; external libz name 'gzflush'; +function gzseek(thefile: gzFile; offset: z_off_t; whence: integer): z_off_t; cdecl; external libz name 'gzseek'; +function gzrewind(thefile: gzFile): integer; cdecl; external libz name 'gzrewind'; +function gztell(thefile: gzFile): z_off_t; cdecl; external libz name 'gztell'; +function gzeof(thefile: gzFile): integer; cdecl; external libz name 'gzeof'; +function gzclose(thefile: gzFile): integer; cdecl; external libz name 'gzclose'; +function gzerror(thefile: gzFile; var errnum: integer): pchar; cdecl; external libz name 'gzerror'; + +function adler32(adler: uLong; buf: pbytef; len: uInt): uLong; cdecl; external libz name 'adler32'; +function crc32(crc: uLong; buf: pbytef; len: uInt): uLong; cdecl; external libz name 'crc32'; + +function deflateInit_(var strm: TZStream; level: integer; version: pchar; stream_size: integer): integer; cdecl; external libz name 'deflateInit_'; +function deflateInit(var strm: TZStream; level : integer) : integer; +function inflateInit_(var strm: TZStream; version: pchar; stream_size: integer): integer; cdecl; external libz name 'inflateInit_'; +function inflateInit(var strm:TZStream) : integer; +function deflateInit2_(var strm: TZStream; level: integer; method: integer; windowBits: integer; memLevel: integer; strategy: integer; version: pchar; stream_size: integer): integer; cdecl; external libz name 'deflateInit2_'; +function deflateInit2(var strm: TZStream; level, method, windowBits, memLevel, strategy: integer): integer; +function inflateInit2_(var strm: TZStream; windowBits: integer; version: pchar; stream_size: integer): integer; cdecl; external libz name 'inflateInit2_'; +function inflateInit2(var strm: TZStream; windowBits: integer): integer; + +function zErrorpchar(err: integer): pchar; cdecl; external libz name 'zError'; +function zError(err: integer): string; +function inflateSyncPoint(z: PZstream): integer; cdecl; external libz name 'inflateSyncPoint'; +function get_crc_table(): pointer; cdecl; external libz name 'get_crc_table'; + +function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl; +procedure zlibFreeMem(AppData, Block: Pointer); cdecl; + +implementation + +function zlibversion(): string; +begin + zlibversion := string(zlibversionpchar); +end; + +function deflateInit(var strm: TZStream; level: integer) : integer; +begin + deflateInit := deflateInit_(strm, level, ZLIB_VERSION, sizeof(TZStream)); +end; + +function inflateInit(var strm: TZStream): integer; +begin + inflateInit := inflateInit_(strm, ZLIB_VERSION, sizeof(TZStream)); +end; + +function deflateInit2(var strm: TZStream; level, method, windowBits, memLevel, strategy: integer) : integer; +begin + deflateInit2 := deflateInit2_(strm, level, method, windowBits, memLevel, strategy, ZLIB_VERSION, sizeof(TZStream)); +end; + +function inflateInit2(var strm: TZStream; windowBits: integer): integer; +begin + inflateInit2 := inflateInit2_(strm, windowBits, ZLIB_VERSION, sizeof(TZStream)); +end; + +function zError(err: integer): string; +begin + zerror := string(zErrorpchar(err)); +end; + +function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl; +begin + Result := GetMemory(Items * Size); +end; + +procedure zlibFreeMem(AppData, Block: Pointer); cdecl; +begin + FreeMem(Block); +end; + +end. -- cgit v1.2.3