From d30f01ac648370211b6ca2f961ae03f03fbc291a Mon Sep 17 00:00:00 2001 From: Andreas Schneider Date: Sun, 8 May 2022 10:47:53 +0200 Subject: [PATCH] =?UTF-8?q?=E2=AC=86=EF=B8=8F=20Update=20Vampyre=20Imaging?= =?UTF-8?q?=20lib?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- Client/UfrmRadar.lfm | 22 +- Client/UfrmRadar.pas | 6 +- Imaging/Imaging.pas | 7750 +++++++++++++----------- Imaging/ImagingBitmap.pas | 1697 +++--- Imaging/ImagingCanvases.pas | 4291 +++++++------- Imaging/ImagingClasses.pas | 2092 +++---- Imaging/ImagingColors.pas | 475 +- Imaging/ImagingComponents.pas | 2672 +++++---- Imaging/ImagingDds.pas | 1993 ++++--- Imaging/ImagingExport.pas | 891 --- Imaging/ImagingFormats.pas | 8723 ++++++++++++++-------------- Imaging/ImagingGif.pas | 2514 ++++---- Imaging/ImagingIO.pas | 1243 ++-- Imaging/ImagingJpeg.pas | 1346 +++-- Imaging/ImagingNetworkGraphics.pas | 5272 +++++++++-------- Imaging/ImagingOpenGL.pas | 1871 +++--- Imaging/ImagingOptions.inc | 416 +- Imaging/ImagingPortableMaps.pas | 1981 +++---- Imaging/ImagingRadiance.pas | 480 ++ Imaging/ImagingTarga.pas | 1227 ++-- Imaging/ImagingTypes.pas | 1063 ++-- Imaging/ImagingUtility.pas | 2678 +++++---- Imaging/JpegLib/imjcapimin.pas | 801 ++- Imaging/JpegLib/imjcapistd.pas | 444 +- Imaging/JpegLib/imjccoefct.pas | 1042 ++-- Imaging/JpegLib/imjccolor.pas | 1063 ++-- Imaging/JpegLib/imjcdctmgr.pas | 1027 ++-- Imaging/JpegLib/imjchuff.pas | 2232 +++---- Imaging/JpegLib/imjcinit.pas | 190 +- Imaging/JpegLib/imjcmainct.pas | 686 +-- Imaging/JpegLib/imjcmarker.pas | 1448 ++--- Imaging/JpegLib/imjcmaster.pas | 1402 ++--- Imaging/JpegLib/imjcomapi.pas | 260 +- Imaging/JpegLib/imjconfig.inc | 250 +- Imaging/JpegLib/imjcparam.pas | 1402 ++--- Imaging/JpegLib/imjcphuff.pas | 1924 +++--- Imaging/JpegLib/imjcprepct.pas | 812 +-- Imaging/JpegLib/imjcsample.pas | 1262 ++-- Imaging/JpegLib/imjdapimin.pas | 1008 ++-- Imaging/JpegLib/imjdapistd.pas | 754 +-- Imaging/JpegLib/imjdcoefct.pas | 1790 +++--- Imaging/JpegLib/imjdcolor.pas | 1002 ++-- Imaging/JpegLib/imjdct.pas | 218 +- Imaging/JpegLib/imjddctmgr.pas | 658 ++- Imaging/JpegLib/imjdeferr.pas | 994 ++-- Imaging/JpegLib/imjdhuff.pas | 2409 ++++---- Imaging/JpegLib/imjdinput.pas | 832 +-- Imaging/JpegLib/imjdmainct.pas | 1220 ++-- Imaging/JpegLib/imjdmarker.pas | 5292 ++++++++--------- Imaging/JpegLib/imjdmaster.pas | 1358 ++--- Imaging/JpegLib/imjdmerge.pas | 1028 ++-- Imaging/JpegLib/imjdphuff.pas | 2122 +++---- Imaging/JpegLib/imjdpostct.pas | 682 +-- Imaging/JpegLib/imjdsample.pas | 1184 ++-- Imaging/JpegLib/imjerror.pas | 924 +-- Imaging/JpegLib/imjfdctflt.pas | 351 +- Imaging/JpegLib/imjfdctfst.pas | 474 +- Imaging/JpegLib/imjfdctint.pas | 594 +- Imaging/JpegLib/imjidctasm.pas | 1586 ++--- Imaging/JpegLib/imjidctflt.pas | 571 +- Imaging/JpegLib/imjidctfst.pas | 820 +-- Imaging/JpegLib/imjidctint.pas | 880 +-- Imaging/JpegLib/imjidctred.pas | 1050 ++-- Imaging/JpegLib/imjinclude.pas | 252 +- Imaging/JpegLib/imjmemmgr.pas | 2566 ++++---- Imaging/JpegLib/imjmemnobs.pas | 518 +- Imaging/JpegLib/imjmorecfg.pas | 466 +- Imaging/JpegLib/imjpeglib.pas | 2600 ++++----- Imaging/JpegLib/imjquant1.pas | 2018 +++---- Imaging/JpegLib/imjquant2.pas | 3102 +++++----- Imaging/JpegLib/imjutils.pas | 464 +- Imaging/JpegLib/readme.txt | 760 +-- Imaging/ZLib/dzlib.pas | 1045 ++-- Imaging/ZLib/imadler.pas | 228 +- Imaging/ZLib/iminfblock.pas | 1902 +++--- Imaging/ZLib/iminfcodes.pas | 1152 ++-- Imaging/ZLib/iminffast.pas | 636 +- Imaging/ZLib/iminftrees.pas | 1560 ++--- Imaging/ZLib/iminfutil.pas | 444 +- Imaging/ZLib/impaszlib.pas | 1040 ++-- Imaging/ZLib/imtrees.pas | 4496 +++++++------- Imaging/ZLib/imzconf.inc | 50 +- Imaging/ZLib/imzdeflate.pas | 4258 +++++++------- Imaging/ZLib/imzinflate.pas | 1500 ++--- Imaging/ZLib/imzutil.pas | 386 +- Imaging/ZLib/readme.txt | 256 +- UOLib/ULight.pas | 2 +- 87 files changed, 65044 insertions(+), 63406 deletions(-) delete mode 100644 Imaging/ImagingExport.pas create mode 100644 Imaging/ImagingRadiance.pas diff --git a/Client/UfrmRadar.lfm b/Client/UfrmRadar.lfm index e3f44af..6d90321 100644 --- a/Client/UfrmRadar.lfm +++ b/Client/UfrmRadar.lfm @@ -1,28 +1,30 @@ object frmRadarMap: TfrmRadarMap Left = 290 - Height = 450 + Height = 562 Top = 171 - Width = 599 + Width = 749 HorzScrollBar.Page = 478 VertScrollBar.Page = 359 ActiveControl = sbMain Caption = 'Radar Map (1:8)' - ClientHeight = 450 - ClientWidth = 599 + ClientHeight = 562 + ClientWidth = 749 + DesignTimePPI = 120 OnClose = FormClose OnCreate = FormCreate OnDestroy = FormDestroy OnResize = FormResize Position = poOwnerFormCenter ShowInTaskBar = stAlways + LCLVersion = '2.3.0.0' object pnlBottom: TPanel Left = 0 - Height = 26 - Top = 424 + Height = 32 + Top = 418 Width = 599 Align = alBottom BevelOuter = bvNone - ClientHeight = 26 + ClientHeight = 32 ClientWidth = 599 TabOrder = 0 object lblPosition: TLabel @@ -31,7 +33,7 @@ object frmRadarMap: TfrmRadarMap Top = 0 Width = 1 Align = alLeft - BorderSpacing.Left = 10 + BorderSpacing.Left = 12 Color = clDefault Layout = tlCenter ParentColor = False @@ -50,9 +52,9 @@ object frmRadarMap: TfrmRadarMap TabOrder = 1 object pbRadar: TPaintBox Left = 0 - Height = 252 + Height = 315 Top = 0 - Width = 365 + Width = 456 OnMouseDown = pbRadarMouseDown OnMouseLeave = pbRadarMouseLeave OnMouseMove = pbRadarMouseMove diff --git a/Client/UfrmRadar.pas b/Client/UfrmRadar.pas index 9d588ca..c89439f 100644 --- a/Client/UfrmRadar.pas +++ b/Client/UfrmRadar.pas @@ -113,7 +113,7 @@ begin SetLength(radarMap, FRadar.Width * FRadar.Height); for x := 0 to FRadar.Width - 1 do for y := 0 to FRadar.Height - 1 do - radarMap[x * FRadar.Height + y] := EncodeUOColor(PInteger(FRadar.PixelPointers[x, y])^); + radarMap[x * FRadar.Height + y] := EncodeUOColor(PInteger(FRadar.PixelPointer[x, y])^); radarMapFile := TFileStream.Create(GetAppConfigDir(False) + 'RadarMap.cache', fmCreate); @@ -213,7 +213,7 @@ begin begin x := ABuffer.ReadWord; y := ABuffer.ReadWord; - PInteger(FRadar.PixelPointers[x, y])^ := DecodeUOColor(ABuffer.ReadWord); + PInteger(FRadar.PixelPointer[x, y])^ := DecodeUOColor(ABuffer.ReadWord); RepaintRadar; end; end; @@ -225,7 +225,7 @@ var begin for x := 0 to FRadar.Width - 1 do for y := 0 to FRadar.Height - 1 do - PInteger(FRadar.PixelPointers[x, y])^ := DecodeUOColor(ARadarMap[x * FRadar.Height + y]); + PInteger(FRadar.PixelPointer[x, y])^ := DecodeUOColor(ARadarMap[x * FRadar.Height + y]); RepaintRadar; end; diff --git a/Imaging/Imaging.pas b/Imaging/Imaging.pas index 1a3737b..68946e7 100644 --- a/Imaging/Imaging.pas +++ b/Imaging/Imaging.pas @@ -1,1871 +1,2007 @@ -{ - $Id: Imaging.pas 173 2009-09-04 17:05:52Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit is heart of Imaging library. It contains basic functions for - manipulating image data as well as various image file format support.} -unit Imaging; - -{$I ImagingOptions.inc} - -interface - -uses - ImagingTypes, SysUtils, Classes; - -type - { Default Imaging excepton class.} - EImagingError = class(Exception); - - { Dynamic array of TImageData records.} - TDynImageDataArray = array of TImageData; - - -{ ------------------------------------------------------------------------ - Low Level Interface Functions - ------------------------------------------------------------------------} - -{ General Functions } - -{ Initializes image (all is set to zeroes). Call this for each image - before using it (before calling every other function) to be sure there - are no random-filled bytes (which would cause errors later).} -procedure InitImage(var Image: TImageData); -{ Creates empty image of given dimensions and format. Image is filled with - transparent black color (A=0, R=0, G=0, B=0).} -function NewImage(Width, Height: LongInt; Format: TImageFormat; - var Image: TImageData): Boolean; -{ Returns True if given TImageData record is valid.} -function TestImage(const Image: TImageData): Boolean; -{ Frees given image data. Ater this call image is in the same state - as after calling InitImage. If image is not valid (dost not pass TestImage - test) it is only zeroed by calling InitImage.} -procedure FreeImage(var Image: TImageData); -{ Call FreeImage() on all images in given dynamic array and sets its - length to zero.} -procedure FreeImagesInArray(var Images: TDynImageDataArray); -{ Returns True if all TImageData records in given array are valid. Returns False - if at least one is invalid or if array is empty.} -function TestImagesInArray(const Images: TDynImageDataArray): Boolean; -{ Checks given file for every supported image file format and if - the file is in one of them returns its string identifier - (which can be used in LoadFromStream/LoadFromMem type functions). - If file is not in any of the supported formats empty string is returned.} -function DetermineFileFormat(const FileName: string): string; -{ Checks given stream for every supported image file format and if - the stream is in one of them returns its string identifier - (which can be used in LoadFromStream/LoadFromMem type functions). - If stream is not in any of the supported formats empty string is returned.} -function DetermineStreamFormat(Stream: TStream): string; -{ Checks given memory for every supported image file format and if - the memory is in one of them returns its string identifier - (which can be used in LoadFromStream/LoadFromMem type functions). - If memory is not in any of the supported formats empty string is returned.} -function DetermineMemoryFormat(Data: Pointer; Size: LongInt): string; -{ Checks that an apropriate file format is supported purely from inspecting - the given file name's extension (not contents of the file itself). - The file need not exist.} -function IsFileFormatSupported(const FileName: string): Boolean; -{ Enumerates all registered image file formats. Descriptive name, - default extension, masks (like '*.jpg,*.jfif') and some capabilities - of each format are returned. To enumerate all formats start with Index at 0 and - call EnumFileFormats with given Index in loop until it returns False (Index is - automatically increased by 1 in function's body on successful call).} -function EnumFileFormats(var Index: LongInt; var Name, DefaultExt, Masks: string; - var CanSaveImages, IsMultiImageFormat: Boolean): Boolean; - -{ Loading Functions } - -{ Loads single image from given file.} -function LoadImageFromFile(const FileName: string; var Image: TImageData): Boolean; -{ Loads single image from given stream. If function fails stream position - is not changed.} -function LoadImageFromStream(Stream: TStream; var Image: TImageData): Boolean; -{ Loads single image from given memory location.} -function LoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; -{ Loads multiple images from given file.} -function LoadMultiImageFromFile(const FileName: string; - var Images: TDynImageDataArray): Boolean; -{ Loads multiple images from given stream. If function fails stream position - is not changed.} -function LoadMultiImageFromStream(Stream: TStream; - var Images: TDynImageDataArray): Boolean; -{ Loads multiple images from given memory location.} -function LoadMultiImageFromMemory(Data: Pointer; Size: LongInt; - var Images: TDynImageDataArray): Boolean; - -{ Saving Functions } - -{ Saves single image to given file.} -function SaveImageToFile(const FileName: string; const Image: TImageData): Boolean; -{ Saves single image to given stream. If function fails stream position - is not changed. Ext identifies desired image file format (jpg, png, dds, ...).} -function SaveImageToStream(const Ext: string; Stream: TStream; - const Image: TImageData): Boolean; -{ Saves single image to given memory location. Memory must be allocated and its - size is passed in Size parameter in which number of written bytes is returned. - Ext identifies desired image file format (jpg, png, dds, ...).} -function SaveImageToMemory(const Ext: string; Data: Pointer; var Size: LongInt; - const Image: TImageData): Boolean; -{ Saves multiple images to given file. If format supports - only single level images and there are multiple images to be saved, - they are saved as sequence of files img000.jpg, img001.jpg ....).} -function SaveMultiImageToFile(const FileName: string; - const Images: TDynImageDataArray): Boolean; -{ Saves multiple images to given stream. If format supports - only single level images and there are multiple images to be saved, - they are saved one after another to the stream. If function fails stream - position is not changed. Ext identifies desired image file format (jpg, png, dds, ...).} -function SaveMultiImageToStream(const Ext: string; Stream: TStream; - const Images: TDynImageDataArray): Boolean; -{ Saves multiple images to given memory location. If format supports - only single level images and there are multiple images to be saved, - they are saved one after another to the memory. Memory must be allocated and - its size is passed in Size parameter in which number of written bytes is returned. - Ext identifies desired image file format (jpg, png, dds, ...).} -function SaveMultiImageToMemory(const Ext: string; Data: Pointer; - var Size: LongInt; const Images: TDynImageDataArray): Boolean; - -{ Manipulation Functions } - -{ Creates identical copy of image data. Clone should be initialized - by InitImage or it should be vaild image which will be freed by CloneImage.} -function CloneImage(const Image: TImageData; var Clone: TImageData): Boolean; -{ Converts image to the given format.} -function ConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; -{ Flips given image. Reverses the image along its horizontal axis — the top - becomes the bottom and vice versa.} -function FlipImage(var Image: TImageData): Boolean; -{ Mirrors given image. Reverses the image along its vertical axis — the left - side becomes the right and vice versa.} -function MirrorImage(var Image: TImageData): Boolean; -{ Resizes given image to new dimensions. Nearest, bilinear, or bicubic filtering - can be used. Input Image must already be created - use NewImage to create new images.} -function ResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt; - Filter: TResizeFilter): Boolean; -{ Swaps SrcChannel and DstChannel color or alpha channels of image. - Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to - identify channels.} -function SwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean; -{ Reduces the number of colors of the Image. Currently MaxColors must be in - range <2, 4096>. Color reduction works also for alpha channel. Note that for - large images and big number of colors it can be very slow. - Output format of the image is the same as input format.} -function ReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; -{ Generates mipmaps for image. Levels is the number of desired mipmaps levels - with zero (or some invalid number) meaning all possible levels.} -function GenerateMipMaps(const Image: TImageData; Levels: LongInt; - var MipMaps: TDynImageDataArray): Boolean; -{ Maps image to existing palette producing image in ifIndex8 format. - Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes. - As resulting image is in 8bit indexed format Entries must be lower or - equal to 256.} -function MapImageToPalette(var Image: TImageData; Pal: PPalette32; - Entries: LongInt): Boolean; -{ Splits image into XChunks x YChunks subimages. Default size of each chunk is - ChunkWidth x ChunkHeight. If PreserveSize si True chunks at the edges of - the image are also ChunkWidth x ChunkHeight sized and empty space is filled - with Fill pixels. After calling this function XChunks contains number of - chunks along x axis and YChunks along y axis. To access chunk [X, Y] use this - index: Chunks[Y * XChunks + X].} -function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray; - ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt; - PreserveSize: Boolean; Fill: Pointer): Boolean; -{ Creates palette with MaxColors based on the colors of images in Images array. - Use it when you want to convert several images to indexed format using - single palette for all of them. If ConvertImages is True images in array - are converted to indexed format using resulting palette. if it is False - images are left intact and only resulting palatte is returned in Pal. - Pal must be allocated to have at least MaxColors entries.} -function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32; - MaxColors: LongInt; ConvertImages: Boolean): Boolean; -{ Rotates image by Angle degrees counterclockwise. All angles are allowed.} -function RotateImage(var Image: TImageData; Angle: Single): Boolean; - -{ Drawing/Pixel functions } - -{ Copies rectangular part of SrcImage to DstImage. No blending is performed - - alpha is simply copied to destination image. Operates also with - negative X and Y coordinates. - Note that copying is fastest for images in the same data format - (and slowest for images in special formats).} -function CopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt; - var DstImage: TImageData; DstX, DstY: LongInt): Boolean; -{ Fills given rectangle of image with given pixel fill data. Fill should point - to the pixel in the same format as the given image is in.} -function FillRect(var Image: TImageData; X, Y, Width, Height: LongInt; FillColor: Pointer): Boolean; -{ Replaces pixels with OldPixel in the given rectangle by NewPixel. - OldPixel and NewPixel should point to the pixels in the same format - as the given image is in.} -function ReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt; - OldColor, NewColor: Pointer): Boolean; -{ Stretches the contents of the source rectangle to the destination rectangle - with optional resampling. No blending is performed - alpha is - simply copied/resampled to destination image. Note that stretching is - fastest for images in the same data format (and slowest for - images in special formats).} -function StretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, - SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, - DstHeight: LongInt; Filter: TResizeFilter): Boolean; -{ Copies pixel of Image at [X, Y] to memory pointed at by Pixel. Doesn't - work with special formats.} -procedure GetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); -{ Copies pixel from memory pointed at by Pixel to Image at position [X, Y]. - Doesn't work with special formats.} -procedure SetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); -{ Function for getting pixel colors. Native pixel is read from Image and - then translated to 32 bit ARGB. Works for all image formats (except special) - so it is not very fast.} -function GetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; -{ Procedure for setting pixel colors. Input 32 bit ARGB color is translated to - native format and then written to Image. Works for all image formats (except special) - so it is not very fast.} -procedure SetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); -{ Function for getting pixel colors. Native pixel is read from Image and - then translated to FP ARGB. Works for all image formats (except special) - so it is not very fast.} -function GetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; -{ Procedure for setting pixel colors. Input FP ARGB color is translated to - native format and then written to Image. Works for all image formats (except special) - so it is not very fast.} -procedure SetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); - -{ Palette Functions } - -{ Allocates new palette with Entries ARGB color entries.} -procedure NewPalette(Entries: LongInt; var Pal: PPalette32); -{ Frees given palette.} -procedure FreePalette(var Pal: PPalette32); -{ Copies Count palette entries from SrcPal starting at index SrcIdx to - DstPal at index DstPal.} -procedure CopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt); -{ Returns index of color in palette or index of nearest color if exact match - is not found. Pal must have at least Entries color entries.} -function FindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt; -{ Creates grayscale palette where each color channel has the same value. - Pal must have at least Entries color entries.} -procedure FillGrayscalePalette(Pal: PPalette32; Entries: LongInt); -{ Creates palette with given bitcount for each channel. - 2^(RBits + GBits + BBits) should be equl to Entries. Examples: - (3, 3, 2) will create palette with all possible colors of R3G3B2 format - and (8, 0, 0) will create palette with 256 shades of red. - Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes.} -procedure FillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits, - BBits: Byte; Alpha: Byte = $FF); -{ Swaps SrcChannel and DstChannel color or alpha channels of palette. - Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to - identify channels. Pal must be allocated to at least - Entries * SizeOf(TColor32Rec) bytes.} -procedure SwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel, - DstChannel: LongInt); - -{ Options Functions } - -{ Sets value of integer option specified by OptionId parameter. - Option Ids are constans starting ImagingXXX.} -function SetOption(OptionId, Value: LongInt): Boolean; -{ Returns value of integer option specified by OptionId parameter. If OptionId is - invalid, InvalidOption is returned. Option Ids are constans - starting ImagingXXX.} -function GetOption(OptionId: LongInt): LongInt; -{ Pushes current values of all options on the stack. Returns True - if successfull (max stack depth is 8 now). } -function PushOptions: Boolean; -{ Pops back values of all options from the top of the stack. Returns True - if successfull (max stack depth is 8 now). } -function PopOptions: Boolean; - -{ Image Format Functions } - -{ Returns short information about given image format.} -function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean; -{ Returns size in bytes of Width x Height area of pixels. Works for all formats.} -function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; - -{ IO Functions } - -{ User can set his own file IO functions used when loading from/saving to - files by this function.} -procedure SetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc: - TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: - TSeekProc; TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); -{ Sets file IO functions to Imaging default.} -procedure ResetFileIO; - - -{ ------------------------------------------------------------------------ - Other Imaging Stuff - ------------------------------------------------------------------------} - -type - { Set of TImageFormat enum.} - TImageFormats = set of TImageFormat; - - { Record containg set of IO functions internaly used by image loaders/savers.} - TIOFunctions = record - OpenRead: TOpenReadProc; - OpenWrite: TOpenWriteProc; - Close: TCloseProc; - Eof: TEofProc; - Seek: TSeekProc; - Tell: TTellProc; - Read: TReadProc; - Write: TWriteProc; - end; - PIOFunctions = ^TIOFunctions; - - { Base class for various image file format loaders/savers which - descend from this class. If you want to add support for new image file - format the best way is probably to look at TImageFileFormat descendants' - implementations that are already part of Imaging.} - {$TYPEINFO ON} - TImageFileFormat = class(TObject) - private - FExtensions: TStringList; - FMasks: TStringList; - { Does various checks and actions before LoadData method is called.} - function PrepareLoad(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstFrame: Boolean): Boolean; - { Processes some actions according to result of LoadData.} - function PostLoadCheck(var Images: TDynImageDataArray; LoadResult: Boolean): Boolean; - { Helper function to be called in SaveData methods of descendants (ensures proper - index and sets FFirstIdx and FLastIdx for multi-images).} - function PrepareSave(Handle: TImagingHandle; const Images: TDynImageDataArray; - var Index: LongInt): Boolean; - protected - FName: string; - FCanLoad: Boolean; - FCanSave: Boolean; - FIsMultiImageFormat: Boolean; - FSupportedFormats: TImageFormats; - FFirstIdx, FLastIdx: LongInt; - { Defines filename masks for this image file format. AMasks should be - in format '*.ext1,*.ext2,umajo.*'.} - procedure AddMasks(const AMasks: string); - function GetFormatInfo(Format: TImageFormat): TImageFormatInfo; - { Returns set of TImageData formats that can be saved in this file format - without need for conversion.} - function GetSupportedFormats: TImageFormats; virtual; - { Method which must be overrided in descendants if they' are be capable - of loading images. Images are already freed and length is set to zero - whenever this method gets called. Also Handle is assured to be valid - and contains data that passed TestFormat method's check.} - function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstFrame: Boolean): Boolean; virtual; - { Method which must be overrided in descendants if they are be capable - of saving images. Images are checked to have length >0 and - that they contain valid images. For single-image file formats - Index contain valid index to Images array (to image which should be saved). - Multi-image formats should use FFirstIdx and FLastIdx fields to - to get all images that are to be saved.} - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; virtual; - { This method is called internaly by MakeCompatible when input image - is in format not supported by this file format. Image is clone of - MakeCompatible's input and Info is its extended format info.} - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); virtual; - { Returns True if given image is supported for saving by this file format. - Most file formats don't need to override this method. It checks - (in this base class) if Image's format is in SupportedFromats set. - But you may override it if you want further checks - (proper widht and height for example).} - function IsSupported(const Image: TImageData): Boolean; virtual; - public - constructor Create; virtual; - destructor Destroy; override; - - { Loads images from file source.} - function LoadFromFile(const FileName: string; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean = False): Boolean; - { Loads images from stream source.} - function LoadFromStream(Stream: TStream; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean = False): Boolean; - { Loads images from memory source.} - function LoadFromMemory(Data: Pointer; Size: LongInt; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean = False): Boolean; - - { Saves images to file. If format supports only single level images and - there are multiple images to be saved, they are saved as sequence of - independent images (for example SaveToFile saves sequence of - files img000.jpg, img001.jpg ....).} - function SaveToFile(const FileName: string; const Images: TDynImageDataArray; - OnlyFirstLevel: Boolean = False): Boolean; - { Saves images to stream. If format supports only single level images and - there are multiple images to be saved, they are saved as sequence of - independent images.} - function SaveToStream(Stream: TStream; const Images: TDynImageDataArray; - OnlyFirstLevel: Boolean = False): Boolean; - { Saves images to memory. If format supports only single level images and - there are multiple images to be saved, they are saved as sequence of - independent images. Data must be already allocated and their size passed - as Size parameter, number of written bytes is then returned in the same - parameter.} - function SaveToMemory(Data: Pointer; var Size: LongInt; - const Images: TDynImageDataArray; OnlyFirstLevel: Boolean = False): Boolean; - - { Makes Image compatible with this file format (that means it is in one - of data formats in Supported formats set). If input is already - in supported format then Compatible just use value from input - (Compatible := Image) so must not free it after you are done with it - (image bits pointer points to input image's bits). - If input is not in supported format then it is cloned to Compatible - and concerted to one of supported formats (which one dependeds on - this file format). If image is cloned MustBeFreed is set to True - to indicated that you must free Compatible after you are done with it.} - function MakeCompatible(const Image: TImageData; var Compatible: TImageData; - out MustBeFreed: Boolean): Boolean; - { Returns True if data located in source identified by Handle - represent valid image in current format.} - function TestFormat(Handle: TImagingHandle): Boolean; virtual; - { Resturns True if the given FileName matches filter for this file format. - For most formats it just checks filename extensions. - It uses filename masks in from Masks property so it can recognize - filenames like this 'umajoXXXumajo.j0j' if one of themasks is - 'umajo*umajo.j?j'.} - function TestFileName(const FileName: string): Boolean; - { Descendants use this method to check if their options (registered with - constant Ids for SetOption/GetOption interface or accessible as properties - of descendants) have valid values and make necessary changes.} - procedure CheckOptionsValidity; virtual; - - { Description of this format.} - property Name: string read FName; - { Indicates whether images in this format can be loaded.} - property CanLoad: Boolean read FCanLoad; - { Indicates whether images in this format can be saved.} - property CanSave: Boolean read FCanSave; - { Indicates whether images in this format can contain multiple image levels.} - property IsMultiImageFormat: Boolean read FIsMultiImageFormat; - { List of filename extensions for this format.} - property Extensions: TStringList read FExtensions; - { List of filename mask that are used to associate filenames - with TImageFileFormat descendants. Typical mask looks like - '*.bmp' or 'texture.*' (supports file formats which use filename instead - of extension to identify image files).} - property Masks: TStringList read FMasks; - { Set of TImageFormats supported by saving functions of this format. Images - can be saved only in one those formats.} - property SupportedFormats: TImageFormats read GetSupportedFormats; - end; - {$TYPEINFO OFF} - - { Class reference for TImageFileFormat class} - TImageFileFormatClass = class of TImageFileFormat; - -{ Returns symbolic name of given format.} -function GetFormatName(Format: TImageFormat): string; -{ Returns string with information about given Image.} -function ImageToStr(const Image: TImageData): string; -{ Returns Imaging version string in format 'Major.Minor.Patch'.} -function GetVersionStr: string; -{ If Condition is True then TruePart is retured, otherwise FalsePart is returned.} -function IffFormat(Condition: Boolean; const TruePart, FalsePart: TImageFormat): TImageFormat; -{ Registers new image loader/saver so it can be used by LoadFrom/SaveTo - functions.} -procedure RegisterImageFileFormat(AClass: TImageFileFormatClass); -{ Registers new option so it can be used by SetOption and GetOption functions. - Returns True if registration was succesful - that is Id is valid and is - not already taken by another option.} -function RegisterOption(OptionId: LongInt; Variable: PLongInt): Boolean; -{ Returns image format loader/saver according to given extension - or nil if not found.} -function FindImageFileFormatByExt(const Ext: string): TImageFileFormat; -{ Returns image format loader/saver according to given filename - or nil if not found.} -function FindImageFileFormatByName(const FileName: string): TImageFileFormat; -{ Returns image format loader/saver based on its class - or nil if not found or not registered.} -function FindImageFileFormatByClass(AClass: TImageFileFormatClass): TImageFileFormat; -{ Returns number of registered image file format loaders/saver.} -function GetFileFormatCount: LongInt; -{ Returns image file format loader/saver at given index. Index must be - in range [0..GetFileFormatCount - 1] otherwise nil is returned.} -function GetFileFormatAtIndex(Index: LongInt): TImageFileFormat; -{ Returns filter string for usage with open and save picture dialogs - which contains all registered image file formats. - Set OpenFileFilter to True if you want filter for open dialog - and to False if you want save dialog filter (formats that cannot save to files - are not added then). - For open dialog filter for all known graphic files - (like All(*.jpg;*.png;....) is added too at the first index.} -function GetImageFileFormatsFilter(OpenFileFilter: Boolean): string; -{ Returns file extension (without dot) of image format selected - by given filter index. Used filter string is defined by GetImageFileFormatsFilter - function. This function can be used with save dialogs (with filters created - by GetImageFileFormatsFilter) to get the extension of file format selected - in dialog quickly. Index is in range 1..N (as FilterIndex property - of TOpenDialog/TSaveDialog)} -function GetFilterIndexExtension(Index: LongInt; OpenFileFilter: Boolean): string; -{ Returns filter index of image file format of file specified by FileName. Used filter - string is defined by GetImageFileFormatsFilter function. - Returned index is in range 1..N (as FilterIndex property of TOpenDialog/TSaveDialog)} -function GetFileNameFilterIndex(const FileName: string; OpenFileFilter: Boolean): LongInt; -{ Returns current IO functions.} -function GetIO: TIOFunctions; -{ Raises EImagingError with given message.} -procedure RaiseImaging(const Msg: string; const Args: array of const); - -implementation - -uses -{$IFNDEF DONT_LINK_BITMAP} - ImagingBitmap, -{$ENDIF} -{$IFNDEF DONT_LINK_JPEG} - ImagingJpeg, -{$ENDIF} -{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)} - ImagingNetworkGraphics, -{$IFEND} -{$IFNDEF DONT_LINK_GIF} - ImagingGif, -{$ENDIF} -{$IFNDEF DONT_LINK_DDS} - ImagingDds, -{$ENDIF} -{$IFNDEF DONT_LINK_TARGA} - ImagingTarga, -{$ENDIF} -{$IFNDEF DONT_LINK_PNM} - ImagingPortableMaps, -{$ENDIF} -{$IFNDEF DONT_LINK_EXTRAS} - ImagingExtras, -{$ENDIF} - ImagingFormats, ImagingUtility, ImagingIO; - -resourcestring - SImagingTitle = 'Vampyre Imaging Library'; - SExceptMsg = 'Exception Message'; - SAllFilter = 'All Images'; - SUnknownFormat = 'Unknown and unsupported format'; - SErrorFreeImage = 'Error while freeing image. %s'; - SErrorCloneImage = 'Error while cloning image. %s'; - SErrorFlipImage = 'Error while flipping image. %s'; - SErrorMirrorImage = 'Error while mirroring image. %s'; - SErrorResizeImage = 'Error while resizing image. %s'; - SErrorSwapImage = 'Error while swapping channels of image. %s'; - SFileFormatCanNotLoad = 'Image Format "%s" does not support loading images.'; - SFileFormatCanNotSave = 'Image Format "%s" does not support saving images.'; - SErrorNewImage = 'Error while creating image data with params: Width=%d ' + - 'Height=%d Format=%s.'; - SErrorConvertImage = 'Error while converting image to format "%s". %s'; - SImageInfo = 'Image @%p info: Width = %dpx, Height = %dpx, ' + - 'Format = %s, Size = %.0n %s, Bits @%p, Palette @%p.'; - SImageInfoInvalid = 'Access violation encountered when getting info on ' + - 'image at address %p.'; - SFileNotValid = 'File "%s" is not valid image in "%s" format.'; - SStreamNotValid = 'Stream %p does not contain valid image in "%s" format.'; - SMemoryNotValid = 'Memory %p (%d Bytes) does not contain valid image ' + - 'in "%s" format.'; - SErrorLoadingFile = 'Error while loading images from file "%s" (file format: %s).'; - SErrorLoadingStream = 'Error while loading images from stream %p (file format: %s).'; - SErrorLoadingMemory = 'Error while loading images from memory %p (%d Bytes) (file format: %s).'; - SErrorSavingFile = 'Error while saving images to file "%s" (file format: %s).'; - SErrorSavingStream = 'Error while saving images to stream %p (file format: %s).'; - SErrorSavingMemory = 'Error while saving images to memory %p (%d Bytes) (file format: %s).'; - SErrorFindColor = 'Error while finding color in palette @%p with %d entries.'; - SErrorGrayscalePalette = 'Error while filling grayscale palette @%p with %d entries.'; - SErrorCustomPalette = 'Error while filling custom palette @%p with %d entries.'; - SErrorSwapPalette = 'Error while swapping channels of palette @%p with %d entries.'; - SErrorReduceColors = 'Error while reducing number of colors of image to %d. %s'; - SErrorGenerateMipMaps = 'Error while generating %d mipmap levels for image %s'; - SImagesNotValid = 'One or more images are not valid.'; - SErrorCopyRect = 'Error while copying rect from image %s to image %s.'; - SErrorMapImage = 'Error while mapping image %s to palette.'; - SErrorFillRect = 'Error while filling rectangle X:%d Y:%d W:%d H:%d in image %s'; - SErrorSplitImage = 'Error while splitting image %s to %dx%d sized chunks.'; - SErrorMakePaletteForImages = 'Error while making %d color palette for %d images.'; - SErrorNewPalette = 'Error while creating new palette with %d entries'; - SErrorFreePalette = 'Error while freeing palette @%p'; - SErrorCopyPalette = 'Error while copying %d entries from palette @%p to @%p'; - SErrorReplaceColor = 'Error while replacing colors in rectangle X:%d Y:%d W:%d H:%d of image %s'; - SErrorRotateImage = 'Error while rotating image %s by %.2n degrees'; - SErrorStretchRect = 'Error while stretching rect from image %s to image %s.'; - SErrorEmptyStream = 'Input stream has no data. Check Position property.'; - -const - // initial size of array with options information - InitialOptions = 256; - // max depth of the option stack - OptionStackDepth = 8; - // do not change the default format now, its too late - DefaultImageFormat: TImageFormat = ifA8R8G8B8; - -type - TOptionArray = array of PLongInt; - TOptionValueArray = array of LongInt; - - TOptionStack = class(TObject) - private - FStack: array[0..OptionStackDepth - 1] of TOptionValueArray; - FPosition: LongInt; - public - constructor Create; - destructor Destroy; override; - function Push: Boolean; - function Pop: Boolean; - end; - -var - // currently set IO functions - IO: TIOFunctions; - // list with all registered TImageFileFormat classes - ImageFileFormats: TList = nil; - // array with registered options (pointers to their values) - Options: TOptionArray = nil; - // array containing addional infomation about every image format - ImageFormatInfos: TImageFormatInfoArray; - // stack used by PushOptions/PopOtions functions - OptionStack: TOptionStack = nil; -var - // variable for ImagingColorReduction option - ColorReductionMask: LongInt = $FF; - // variable for ImagingLoadOverrideFormat option - LoadOverrideFormat: TImageFormat = ifUnknown; - // variable for ImagingSaveOverrideFormat option - SaveOverrideFormat: TImageFormat = ifUnknown; - // variable for ImagingSaveOverrideFormat option - MipMapFilter: TSamplingFilter = sfLinear; - - -{ Internal unit functions } - -{ Modifies option value to be in the allowed range. Works only - for options registered in this unit.} -function CheckOptionValue(OptionId, Value: LongInt): LongInt; forward; -{ Sets IO functions to file IO.} -procedure SetFileIO; forward; -{ Sets IO functions to stream IO.} -procedure SetStreamIO; forward; -{ Sets IO functions to memory IO.} -procedure SetMemoryIO; forward; -{ Inits image format infos array.} -procedure InitImageFormats; forward; -{ Freew image format infos array.} -procedure FreeImageFileFormats; forward; -{ Creates options array and stack.} -procedure InitOptions; forward; -{ Frees options array and stack.} -procedure FreeOptions; forward; - -{$IFDEF USE_INLINE} -{ Those inline functions are copied here from ImagingFormats - because Delphi 9/10 cannot inline them if they are declared in - circularly dependent units.} - -procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); inline; -begin - case BytesPerPixel of - 1: PByte(Dest)^ := PByte(Src)^; - 2: PWord(Dest)^ := PWord(Src)^; - 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^; - 4: PLongWord(Dest)^ := PLongWord(Src)^; - 6: PColor48Rec(Dest)^ := PColor48Rec(Src)^; - 8: PInt64(Dest)^ := PInt64(Src)^; - 16: PColorFPRec(Dest)^ := PColorFPRec(Src)^; - end; -end; - -function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; inline; -begin - case BytesPerPixel of - 1: Result := PByte(PixelA)^ = PByte(PixelB)^; - 2: Result := PWord(PixelA)^ = PWord(PixelB)^; - 3: Result := (PWord(PixelA)^ = PWord(PixelB)^) and - (PColor24Rec(PixelA).R = PColor24Rec(PixelB).R); - 4: Result := PLongWord(PixelA)^ = PLongWord(PixelB)^; - 6: Result := (PLongWord(PixelA)^ = PLongWord(PixelB)^) and - (PColor48Rec(PixelA).R = PColor48Rec(PixelB).R); - 8: Result := PInt64(PixelA)^ = PInt64(PixelB)^; - 16: Result := (PFloatHelper(PixelA).Data2 = PFloatHelper(PixelB).Data2) and - (PFloatHelper(PixelA).Data1 = PFloatHelper(PixelB).Data1); - else - Result := False; - end; -end; -{$ENDIF} - -{ ------------------------------------------------------------------------ - Low Level Interface Functions - ------------------------------------------------------------------------} - -{ General Functions } - -procedure InitImage(var Image: TImageData); -begin - FillChar(Image, SizeOf(Image), 0); -end; - -function NewImage(Width, Height: LongInt; Format: TImageFormat; var Image: - TImageData): Boolean; -var - FInfo: PImageFormatInfo; -begin - Assert((Width > 0) and (Height >0)); - Assert(IsImageFormatValid(Format)); - Result := False; - FreeImage(Image); - try - Image.Width := Width; - Image.Height := Height; - // Select default data format if selected - if (Format = ifDefault) then - Image.Format := DefaultImageFormat - else - Image.Format := Format; - // Get extended format info - FInfo := ImageFormatInfos[Image.Format]; - if FInfo = nil then - begin - InitImage(Image); - Exit; - end; - // Check image dimensions and calculate its size in bytes - FInfo.CheckDimensions(FInfo.Format, Image.Width, Image.Height); - Image.Size := FInfo.GetPixelsSize(FInfo.Format, Image.Width, Image.Height); - if Image.Size = 0 then - begin - InitImage(Image); - Exit; - end; - // Image bits are allocated and set to zeroes - GetMem(Image.Bits, Image.Size); - FillChar(Image.Bits^, Image.Size, 0); - // Palette is allocated and set to zeroes - if FInfo.PaletteEntries > 0 then - begin - GetMem(Image.Palette, FInfo.PaletteEntries * SizeOf(TColor32Rec)); - FillChar(Image.Palette^, FInfo.PaletteEntries * SizeOf(TColor32Rec), 0); - end; - Result := TestImage(Image); - except - RaiseImaging(SErrorNewImage, [Width, Height, GetFormatName(Format)]); - end; -end; - -function TestImage(const Image: TImageData): Boolean; -begin - try - Result := (LongInt(Image.Format) >= LongInt(Low(TImageFormat))) and - (LongInt(Image.Format) <= LongInt(High(TImageFormat))) and - (ImageFormatInfos[Image.Format] <> nil) and - (Assigned(ImageFormatInfos[Image.Format].GetPixelsSize) and - (ImageFormatInfos[Image.Format].GetPixelsSize(Image.Format, - Image.Width, Image.Height) = Image.Size)); - except - // Possible int overflows or other errors - Result := False; - end; -end; - -procedure FreeImage(var Image: TImageData); -begin - try - if TestImage(Image) then - begin - FreeMemNil(Image.Bits); - FreeMemNil(Image.Palette); - end; - InitImage(Image); - except - RaiseImaging(SErrorFreeImage, [ImageToStr(Image)]); - end; -end; - -procedure FreeImagesInArray(var Images: TDynImageDataArray); -var - I: LongInt; -begin - if Length(Images) > 0 then - begin - for I := 0 to Length(Images) - 1 do - FreeImage(Images[I]); - SetLength(Images, 0); - end; -end; - -function TestImagesInArray(const Images: TDynImageDataArray): Boolean; -var - I: LongInt; -begin - if Length(Images) > 0 then - begin - Result := True; - for I := 0 to Length(Images) - 1 do - begin - Result := Result and TestImage(Images[I]); - if not Result then - Break; - end; - end - else - Result := False; -end; - -function DetermineFileFormat(const FileName: string): string; -var - I: LongInt; - Fmt: TImageFileFormat; - Handle: TImagingHandle; -begin - Assert(FileName <> ''); - Result := ''; - SetFileIO; - try - Handle := IO.OpenRead(PChar(FileName)); - try - // First file format according to FileName and test if the data in - // file is really in that format - for I := 0 to ImageFileFormats.Count - 1 do - begin - Fmt := TImageFileFormat(ImageFileFormats[I]); - if Fmt.TestFileName(FileName) and Fmt.TestFormat(Handle) then - begin - Result := Fmt.Extensions[0]; - Exit; - end; - end; - // No file format was found with filename search so try data-based search - for I := 0 to ImageFileFormats.Count - 1 do - begin - Fmt := TImageFileFormat(ImageFileFormats[I]); - if Fmt.TestFormat(Handle) then - begin - Result := Fmt.Extensions[0]; - Exit; - end; - end; - finally - IO.Close(Handle); - end; - except - Result := ''; - end; -end; - -function DetermineStreamFormat(Stream: TStream): string; -var - I: LongInt; - Fmt: TImageFileFormat; - Handle: TImagingHandle; -begin - Assert(Stream <> nil); - Result := ''; - SetStreamIO; - try - Handle := IO.OpenRead(Pointer(Stream)); - try - for I := 0 to ImageFileFormats.Count - 1 do - begin - Fmt := TImageFileFormat(ImageFileFormats[I]); - if Fmt.TestFormat(Handle) then - begin - Result := Fmt.Extensions[0]; - Exit; - end; - end; - finally - IO.Close(Handle); - end; - except - Result := ''; - end; -end; - -function DetermineMemoryFormat(Data: Pointer; Size: LongInt): string; -var - I: LongInt; - Fmt: TImageFileFormat; - Handle: TImagingHandle; - IORec: TMemoryIORec; -begin - Assert((Data <> nil) and (Size > 0)); - Result := ''; - SetMemoryIO; - IORec.Data := Data; - IORec.Position := 0; - IORec.Size := Size; - try - Handle := IO.OpenRead(@IORec); - try - for I := 0 to ImageFileFormats.Count - 1 do - begin - Fmt := TImageFileFormat(ImageFileFormats[I]); - if Fmt.TestFormat(Handle) then - begin - Result := Fmt.Extensions[0]; - Exit; - end; - end; - finally - IO.Close(Handle); - end; - except - Result := ''; - end; -end; - -function IsFileFormatSupported(const FileName: string): Boolean; -begin - Result := FindImageFileFormatByName(FileName) <> nil; -end; - -function EnumFileFormats(var Index: LongInt; var Name, DefaultExt, Masks: string; - var CanSaveImages, IsMultiImageFormat: Boolean): Boolean; -var - FileFmt: TImageFileFormat; -begin - FileFmt := GetFileFormatAtIndex(Index); - Result := FileFmt <> nil; - if Result then - begin - Name := FileFmt.Name; - DefaultExt := FileFmt.Extensions[0]; - Masks := FileFmt.Masks.DelimitedText; - CanSaveImages := FileFmt.CanSave; - IsMultiImageFormat := FileFmt.IsMultiImageFormat; - Inc(Index); - end - else - begin - Name := ''; - DefaultExt := ''; - Masks := ''; - CanSaveImages := False; - IsMultiImageFormat := False; - end; -end; - -{ Loading Functions } - -function LoadImageFromFile(const FileName: string; var Image: TImageData): - Boolean; -var - Format: TImageFileFormat; - IArray: TDynImageDataArray; - I: LongInt; -begin - Assert(FileName <> ''); - Result := False; - Format := FindImageFileFormatByExt(DetermineFileFormat(FileName)); - if Format <> nil then - begin - FreeImage(Image); - Result := Format.LoadFromFile(FileName, IArray, True); - if Result and (Length(IArray) > 0) then - begin - Image := IArray[0]; - for I := 1 to Length(IArray) - 1 do - FreeImage(IArray[I]); - end - else - Result := False; - end; -end; - -function LoadImageFromStream(Stream: TStream; var Image: TImageData): Boolean; -var - Format: TImageFileFormat; - IArray: TDynImageDataArray; - I: LongInt; -begin - Assert(Stream <> nil); - if Stream.Size - Stream.Position = 0 then - RaiseImaging(SErrorEmptyStream, []); - Result := False; - Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream)); - if Format <> nil then - begin - FreeImage(Image); - Result := Format.LoadFromStream(Stream, IArray, True); - if Result and (Length(IArray) > 0) then - begin - Image := IArray[0]; - for I := 1 to Length(IArray) - 1 do - FreeImage(IArray[I]); - end - else - Result := False; - end; -end; - -function LoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; -var - Format: TImageFileFormat; - IArray: TDynImageDataArray; - I: LongInt; -begin - Assert((Data <> nil) and (Size > 0)); - Result := False; - Format := FindImageFileFormatByExt(DetermineMemoryFormat(Data, Size)); - if Format <> nil then - begin - FreeImage(Image); - Result := Format.LoadFromMemory(Data, Size, IArray, True); - if Result and (Length(IArray) > 0) then - begin - Image := IArray[0]; - for I := 1 to Length(IArray) - 1 do - FreeImage(IArray[I]); - end - else - Result := False; - end; -end; - -function LoadMultiImageFromFile(const FileName: string; var Images: - TDynImageDataArray): Boolean; -var - Format: TImageFileFormat; -begin - Assert(FileName <> ''); - Result := False; - Format := FindImageFileFormatByExt(DetermineFileFormat(FileName)); - if Format <> nil then - begin - FreeImagesInArray(Images); - Result := Format.LoadFromFile(FileName, Images); - end; -end; - -function LoadMultiImageFromStream(Stream: TStream; var Images: TDynImageDataArray): Boolean; -var - Format: TImageFileFormat; -begin - Assert(Stream <> nil); - if Stream.Size - Stream.Position = 0 then - RaiseImaging(SErrorEmptyStream, []); - Result := False; - Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream)); - if Format <> nil then - begin - FreeImagesInArray(Images); - Result := Format.LoadFromStream(Stream, Images); - end; -end; - -function LoadMultiImageFromMemory(Data: Pointer; Size: LongInt; - var Images: TDynImageDataArray): Boolean; -var - Format: TImageFileFormat; -begin - Assert((Data <> nil) and (Size > 0)); - Result := False; - Format := FindImageFileFormatByExt(DetermineMemoryFormat(Data, Size)); - if Format <> nil then - begin - FreeImagesInArray(Images); - Result := Format.LoadFromMemory(Data, Size, Images); - end; -end; - -{ Saving Functions } - -function SaveImageToFile(const FileName: string; const Image: TImageData): Boolean; -var - Format: TImageFileFormat; - IArray: TDynImageDataArray; -begin - Assert(FileName <> ''); - Result := False; - Format := FindImageFileFormatByName(FileName); - if Format <> nil then - begin - SetLength(IArray, 1); - IArray[0] := Image; - Result := Format.SaveToFile(FileName, IArray, True); - end; -end; - -function SaveImageToStream(const Ext: string; Stream: TStream; - const Image: TImageData): Boolean; -var - Format: TImageFileFormat; - IArray: TDynImageDataArray; -begin - Assert((Ext <> '') and (Stream <> nil)); - Result := False; - Format := FindImageFileFormatByExt(Ext); - if Format <> nil then - begin - SetLength(IArray, 1); - IArray[0] := Image; - Result := Format.SaveToStream(Stream, IArray, True); - end; -end; - -function SaveImageToMemory(const Ext: string; Data: Pointer; var Size: LongInt; - const Image: TImageData): Boolean; -var - Format: TImageFileFormat; - IArray: TDynImageDataArray; -begin - Assert((Ext <> '') and (Data <> nil) and (Size > 0)); - Result := False; - Format := FindImageFileFormatByExt(Ext); - if Format <> nil then - begin - SetLength(IArray, 1); - IArray[0] := Image; - Result := Format.SaveToMemory(Data, Size, IArray, True); - end; -end; - -function SaveMultiImageToFile(const FileName: string; - const Images: TDynImageDataArray): Boolean; -var - Format: TImageFileFormat; -begin - Assert(FileName <> ''); - Result := False; - Format := FindImageFileFormatByName(FileName); - if Format <> nil then - Result := Format.SaveToFile(FileName, Images); -end; - -function SaveMultiImageToStream(const Ext: string; Stream: TStream; - const Images: TDynImageDataArray): Boolean; -var - Format: TImageFileFormat; -begin - Assert((Ext <> '') and (Stream <> nil)); - Result := False; - Format := FindImageFileFormatByExt(Ext); - if Format <> nil then - Result := Format.SaveToStream(Stream, Images); -end; - -function SaveMultiImageToMemory(const Ext: string; Data: Pointer; - var Size: LongInt; const Images: TDynImageDataArray): Boolean; -var - Format: TImageFileFormat; -begin - Assert((Ext <> '') and (Data <> nil) and (Size > 0)); - Result := False; - Format := FindImageFileFormatByExt(Ext); - if Format <> nil then - Result := Format.SaveToMemory(Data, Size, Images); -end; - -{ Manipulation Functions } - -function CloneImage(const Image: TImageData; var Clone: TImageData): Boolean; -var - Info: PImageFormatInfo; -begin - Result := False; - if TestImage(Image) then - try - if TestImage(Clone) and (Image.Bits <> Clone.Bits) then - FreeImage(Clone) - else - InitImage(Clone); - - Info := ImageFormatInfos[Image.Format]; - Clone.Width := Image.Width; - Clone.Height := Image.Height; - Clone.Format := Image.Format; - Clone.Size := Image.Size; - - if Info.PaletteEntries > 0 then - begin - GetMem(Clone.Palette, Info.PaletteEntries * SizeOf(TColor32Rec)); - Move(Image.Palette^, Clone.Palette^, Info.PaletteEntries * - SizeOf(TColor32Rec)); - end; - - GetMem(Clone.Bits, Clone.Size); - Move(Image.Bits^, Clone.Bits^, Clone.Size); - Result := True; - except - RaiseImaging(SErrorCloneImage, [ImageToStr(Image)]); - end; -end; - -function ConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; -var - NewData: Pointer; - NewPal: PPalette32; - NewSize, NumPixels: LongInt; - SrcInfo, DstInfo: PImageFormatInfo; -begin - Assert(IsImageFormatValid(DestFormat)); - Result := False; - if TestImage(Image) then - with Image do - try - // If default format is set we use DefaultImageFormat - if DestFormat = ifDefault then - DestFormat := DefaultImageFormat; - SrcInfo := ImageFormatInfos[Format]; - DstInfo := ImageFormatInfos[DestFormat]; - if SrcInfo = DstInfo then - begin - // There is nothing to convert - src is alredy in dest format - Result := True; - Exit; - end; - // Exit Src or Dest format is invalid - if (SrcInfo = nil) or (DstInfo = nil) then Exit; - // If dest format is just src with swapped channels we call - // SwapChannels instead - if (SrcInfo.RBSwapFormat = DestFormat) and - (DstInfo.RBSwapFormat = SrcInfo.Format) then - begin - Result := SwapChannels(Image, ChannelRed, ChannelBlue); - Image.Format := SrcInfo.RBSwapFormat; - Exit; - end; - - if (not SrcInfo.IsSpecial) and (not DstInfo.IsSpecial) then - begin - NumPixels := Width * Height; - NewSize := NumPixels * DstInfo.BytesPerPixel; - GetMem(NewData, NewSize); - FillChar(NewData^, NewSize, 0); - GetMem(NewPal, DstInfo.PaletteEntries * SizeOf(TColor32Rec)); - FillChar(NewPal^, DstInfo.PaletteEntries * SizeOf(TColor32Rec), 0); - - if SrcInfo.IsIndexed then - begin - // Source: indexed format - if DstInfo.IsIndexed then - IndexToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette, NewPal) - else if DstInfo.HasGrayChannel then - IndexToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette) - else if DstInfo.IsFloatingPoint then - IndexToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette) - else - IndexToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette); - end - else if SrcInfo.HasGrayChannel then - begin - // Source: grayscale format - if DstInfo.IsIndexed then - GrayToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal) - else if DstInfo.HasGrayChannel then - GrayToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo) - else if DstInfo.IsFloatingPoint then - GrayToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo) - else - GrayToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo); - end - else if SrcInfo.IsFloatingPoint then - begin - // Source: floating point format - if DstInfo.IsIndexed then - FloatToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal) - else if DstInfo.HasGrayChannel then - FloatToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo) - else if DstInfo.IsFloatingPoint then - FloatToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo) - else - FloatToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo); - end - else - begin - // Source: standard multi channel image - if DstInfo.IsIndexed then - ChannelToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal) - else if DstInfo.HasGrayChannel then - ChannelToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo) - else if DstInfo.IsFloatingPoint then - ChannelToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo) - else - ChannelToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo); - end; - - FreeMemNil(Bits); - FreeMemNil(Palette); - Format := DestFormat; - Bits := NewData; - Size := NewSize; - Palette := NewPal; - end - else - ConvertSpecial(Image, SrcInfo, DstInfo); - - Assert(SrcInfo.Format <> Image.Format); - - Result := True; - except - RaiseImaging(SErrorConvertImage, [GetFormatName(DestFormat), ImageToStr(Image)]); - end; -end; - -function FlipImage(var Image: TImageData): Boolean; -var - P1, P2, Buff: Pointer; - WidthBytes, I: LongInt; - OldFmt: TImageFormat; -begin - Result := False; - OldFmt := Image.Format; - if TestImage(Image) then - with Image do - try - if ImageFormatInfos[OldFmt].IsSpecial then - ConvertImage(Image, ifDefault); - - WidthBytes := Width * ImageFormatInfos[Format].BytesPerPixel; - GetMem(Buff, WidthBytes); - try - // Swap all scanlines of image - for I := 0 to Height div 2 - 1 do - begin - P1 := @PByteArray(Bits)[I * WidthBytes]; - P2 := @PByteArray(Bits)[(Height - I - 1) * WidthBytes]; - Move(P1^, Buff^, WidthBytes); - Move(P2^, P1^, WidthBytes); - Move(Buff^, P2^, WidthBytes); - end; - finally - FreeMemNil(Buff); - end; - - if OldFmt <> Format then - ConvertImage(Image, OldFmt); - - Result := True; - except - RaiseImaging(SErrorFlipImage, [ImageToStr(Image)]); - end; -end; - -function MirrorImage(var Image: TImageData): Boolean; -var - Scanline: PByte; - Buff: TColorFPRec; - Bpp, Y, X, WidthDiv2, WidthBytes, XLeft, XRight: LongInt; - OldFmt: TImageFormat; -begin - Result := False; - OldFmt := Image.Format; - if TestImage(Image) then - with Image do - try - if ImageFormatInfos[OldFmt].IsSpecial then - ConvertImage(Image, ifDefault); - - Bpp := ImageFormatInfos[Format].BytesPerPixel; - WidthDiv2 := Width div 2; - WidthBytes := Width * Bpp; - // Mirror all pixels on each scanline of image - for Y := 0 to Height - 1 do - begin - Scanline := @PByteArray(Bits)[Y * WidthBytes]; - XLeft := 0; - XRight := (Width - 1) * Bpp; - for X := 0 to WidthDiv2 - 1 do - begin - CopyPixel(@PByteArray(Scanline)[XLeft], @Buff, Bpp); - CopyPixel(@PByteArray(Scanline)[XRight], - @PByteArray(Scanline)[XLeft], Bpp); - CopyPixel(@Buff, @PByteArray(Scanline)[XRight], Bpp); - Inc(XLeft, Bpp); - Dec(XRight, Bpp); - end; - end; - - if OldFmt <> Format then - ConvertImage(Image, OldFmt); - - Result := True; - except - RaiseImaging(SErrorMirrorImage, [ImageToStr(Image)]); - end; -end; - -function ResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt; - Filter: TResizeFilter): Boolean; -var - WorkImage: TImageData; -begin - Assert((NewWidth > 0) and (NewHeight > 0)); - Result := False; - if TestImage(Image) and ((Image.Width <> NewWidth) or (Image.Height <> NewHeight)) then - try - InitImage(WorkImage); - // Create new image with desired dimensions - NewImage(NewWidth, NewHeight, Image.Format, WorkImage); - // Stretch pixels from old image to new one - StretchRect(Image, 0, 0, Image.Width, Image.Height, - WorkImage, 0, 0, WorkImage.Width, WorkImage.Height, Filter); - // Free old image and assign new image to it - FreeMemNil(Image.Bits); - if Image.Palette <> nil then - begin - FreeMem(WorkImage.Palette); - WorkImage.Palette := Image.Palette; - end; - Image := WorkImage; - Result := True; - except - RaiseImaging(SErrorResizeImage, [ImageToStr(Image)]); - end; -end; - -function SwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean; -var - I, NumPixels: LongInt; - Info: PImageFormatInfo; - Swap, Alpha: Word; - Data: PByte; - Pix64: TColor64Rec; - PixF: TColorFPRec; - SwapF: Single; -begin - Assert((SrcChannel in [0..3]) and (DstChannel in [0..3])); - Result := False; - if TestImage(Image) and (SrcChannel <> DstChannel) then - with Image do - try - NumPixels := Width * Height; - Info := ImageFormatInfos[Format]; - Data := Bits; - - if (Info.Format = ifR8G8B8) or ((Info.Format = ifA8R8G8B8) and - (SrcChannel <> ChannelAlpha) and (DstChannel <> ChannelAlpha)) then - begin - // Swap channels of most common formats R8G8B8 and A8R8G8B8 (no alpha) - for I := 0 to NumPixels - 1 do - with PColor24Rec(Data)^ do - begin - Swap := Channels[SrcChannel]; - Channels[SrcChannel] := Channels[DstChannel]; - Channels[DstChannel] := Swap; - Inc(Data, Info.BytesPerPixel); - end; - end - else if Info.IsIndexed then - begin - // Swap palette channels of indexed images - SwapChannelsOfPalette(Palette, Info.PaletteEntries, SrcChannel, DstChannel) - end - else if Info.IsFloatingPoint then - begin - // Swap channels of floating point images - for I := 0 to NumPixels - 1 do - begin - FloatGetSrcPixel(Data, Info, PixF); - with PixF do - begin - SwapF := Channels[SrcChannel]; - Channels[SrcChannel] := Channels[DstChannel]; - Channels[DstChannel] := SwapF; - end; - FloatSetDstPixel(Data, Info, PixF); - Inc(Data, Info.BytesPerPixel); - end; - end - else if Info.IsSpecial then - begin - // Swap channels of special format images - ConvertImage(Image, ifDefault); - SwapChannels(Image, SrcChannel, DstChannel); - ConvertImage(Image, Info.Format); - end - else if Info.HasGrayChannel and Info.HasAlphaChannel and - ((SrcChannel = ChannelAlpha) or (DstChannel = ChannelAlpha)) then - begin - for I := 0 to NumPixels - 1 do - begin - // If we have grayscale image with alpha and alpha is channel - // to be swapped, we swap it. No other alternative for gray images, - // just alpha and something - GrayGetSrcPixel(Data, Info, Pix64, Alpha); - Swap := Alpha; - Alpha := Pix64.A; - Pix64.A := Swap; - GraySetDstPixel(Data, Info, Pix64, Alpha); - Inc(Data, Info.BytesPerPixel); - end; - end - else - begin - // Then do general swap on other channel image formats - for I := 0 to NumPixels - 1 do - begin - ChannelGetSrcPixel(Data, Info, Pix64); - with Pix64 do - begin - Swap := Channels[SrcChannel]; - Channels[SrcChannel] := Channels[DstChannel]; - Channels[DstChannel] := Swap; - end; - ChannelSetDstPixel(Data, Info, Pix64); - Inc(Data, Info.BytesPerPixel); - end; - end; - - Result := True; - except - RaiseImaging(SErrorSwapImage, [ImageToStr(Image)]); - end; -end; - -function ReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; -var - TmpInfo: TImageFormatInfo; - Data, Index: PWord; - I, NumPixels: LongInt; - Pal: PPalette32; - Col:PColor32Rec; - OldFmt: TImageFormat; -begin - Result := False; - if TestImage(Image) then - with Image do - try - // First create temp image info and allocate output bits and palette - MaxColors := ClampInt(MaxColors, 2, High(Word)); - OldFmt := Format; - FillChar(TmpInfo, SizeOf(TmpInfo), 0); - TmpInfo.PaletteEntries := MaxColors; - TmpInfo.BytesPerPixel := 2; - NumPixels := Width * Height; - GetMem(Data, NumPixels * TmpInfo.BytesPerPixel); - GetMem(Pal, MaxColors * SizeOf(TColor32Rec)); - ConvertImage(Image, ifA8R8G8B8); - // We use median cut algorithm to create reduced palette and to - // fill Data with indices to this palette - ReduceColorsMedianCut(NumPixels, Bits, PByte(Data), - ImageFormatInfos[Format], @TmpInfo, MaxColors, ColorReductionMask, Pal); - Col := Bits; - Index := Data; - // Then we write reduced colors to the input image - for I := 0 to NumPixels - 1 do - begin - Col.Color := Pal[Index^].Color; - Inc(Col); - Inc(Index); - end; - FreeMemNil(Data); - FreeMemNil(Pal); - // And convert it to its original format - ConvertImage(Image, OldFmt); - Result := True; - except - RaiseImaging(SErrorReduceColors, [MaxColors, ImageToStr(Image)]); - end; -end; - -function GenerateMipMaps(const Image: TImageData; Levels: LongInt; - var MipMaps: TDynImageDataArray): Boolean; -var - Width, Height, I, Count: LongInt; - Info: TImageFormatInfo; - CompatibleCopy: TImageData; -begin - Result := False; - if TestImage(Image) then - try - Width := Image.Width; - Height := Image.Height; - // We compute number of possible mipmap levels and if - // the given levels are invalid or zero we use this value - Count := GetNumMipMapLevels(Width, Height); - if (Levels <= 0) or (Levels > Count) then - Levels := Count; - - // If we have special format image we create copy to allow pixel access. - // This is also done in FillMipMapLevel which is called for each level - // but then the main big image would be converted to compatible - // for every level. - GetImageFormatInfo(Image.Format, Info); - if Info.IsSpecial then - begin - InitImage(CompatibleCopy); - CloneImage(Image, CompatibleCopy); - ConvertImage(CompatibleCopy, ifDefault); - end - else - CompatibleCopy := Image; - - FreeImagesInArray(MipMaps); - SetLength(MipMaps, Levels); - CloneImage(Image, MipMaps[0]); - - for I := 1 to Levels - 1 do - begin - Width := Width shr 1; - Height := Height shr 1; - if Width < 1 then Width := 1; - if Height < 1 then Height := 1; - FillMipMapLevel(CompatibleCopy, Width, Height, MipMaps[I]); - end; - - if CompatibleCopy.Format <> MipMaps[0].Format then - begin - // Must convert smaller levels to proper format - for I := 1 to High(MipMaps) do - ConvertImage(MipMaps[I], MipMaps[0].Format); - FreeImage(CompatibleCopy); - end; - - Result := True; - except - RaiseImaging(SErrorGenerateMipMaps, [Levels, ImageToStr(Image)]); - end; -end; - -function MapImageToPalette(var Image: TImageData; Pal: PPalette32; - Entries: LongInt): Boolean; - - function FindNearestColor(Pal: PPalette32; Entries: LongInt; Col: TColor32Rec): LongInt; - var - I, MinDif, Dif: LongInt; - begin - Result := 0; - MinDif := 1020; - for I := 0 to Entries - 1 do - with Pal[I] do - begin - Dif := Abs(R - Col.R); - if Dif > MinDif then Continue; - Dif := Dif + Abs(G - Col.G); - if Dif > MinDif then Continue; - Dif := Dif + Abs(B - Col.B); - if Dif > MinDif then Continue; - Dif := Dif + Abs(A - Col.A); - if Dif < MinDif then - begin - MinDif := Dif; - Result := I; - end; - end; - end; - -var - I, MaxEntries: LongInt; - PIndex: PByte; - PColor: PColor32Rec; - CloneARGB: TImageData; - Info: PImageFormatInfo; -begin - Assert((Entries >= 2) and (Entries <= 256)); - Result := False; - - if TestImage(Image) then - try - // We create clone of source image in A8R8G8B8 and - // then recreate source image in ifIndex8 format - // with palette taken from Pal parameter - InitImage(CloneARGB); - CloneImage(Image, CloneARGB); - ConvertImage(CloneARGB, ifA8R8G8B8); - FreeImage(Image); - NewImage(CloneARGB.Width, CloneARGB.Height, ifIndex8, Image); - - Info := ImageFormatInfos[Image.Format]; - MaxEntries := Min(Info.PaletteEntries, Entries); - Move(Pal^, Image.Palette^, MaxEntries * SizeOf(TColor32Rec)); - PIndex := Image.Bits; - PColor := CloneARGB.Bits; - - // For every pixel of ARGB clone we find closest color in - // given palette and assign its index to resulting image's pixel - // procedure used here is very slow but simple and memory usage friendly - // (contrary to other methods) - for I := 0 to Image.Width * Image.Height - 1 do - begin - PIndex^ := Byte(FindNearestColor(Image.Palette, MaxEntries, PColor^)); - Inc(PIndex); - Inc(PColor); - end; - - FreeImage(CloneARGB); - Result := True; - except - RaiseImaging(SErrorMapImage, [ImageToStr(Image)]); - end; -end; - -function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray; - ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt; - PreserveSize: Boolean; Fill: Pointer): Boolean; -var - X, Y, XTrunc, YTrunc: LongInt; - NotOnEdge: Boolean; - Info: PImageFormatInfo; - OldFmt: TImageFormat; -begin - Assert((ChunkWidth > 0) and (ChunkHeight > 0)); - Result := False; - OldFmt := Image.Format; - FreeImagesInArray(Chunks); - - if TestImage(Image) then - try - Info := ImageFormatInfos[Image.Format]; - if Info.IsSpecial then - ConvertImage(Image, ifDefault); - - // We compute make sure that chunks are not larger than source image or negative - ChunkWidth := ClampInt(ChunkWidth, 0, Image.Width); - ChunkHeight := ClampInt(ChunkHeight, 0, Image.Height); - // Number of chunks along X and Y axes is computed - XChunks := Trunc(Ceil(Image.Width / ChunkWidth)); - YChunks := Trunc(Ceil(Image.Height / ChunkHeight)); - SetLength(Chunks, XChunks * YChunks); - - // For every chunk we create new image and copy a portion of - // the source image to it. If chunk is on the edge of the source image - // we fill enpty space with Fill pixel data if PreserveSize is set or - // make the chunk smaller if it is not set - for Y := 0 to YChunks - 1 do - for X := 0 to XChunks - 1 do - begin - // Determine if current chunk is on the edge of original image - NotOnEdge := ((X < XChunks - 1) and (Y < YChunks - 1)) or - ((Image.Width mod ChunkWidth = 0) and (Image.Height mod ChunkHeight = 0)); - - if PreserveSize or NotOnEdge then - begin - // We should preserve chunk sizes or we are somewhere inside original image - NewImage(ChunkWidth, ChunkHeight, Image.Format, Chunks[Y * XChunks + X]); - if (not NotOnEdge) and (Fill <> nil) then - FillRect(Chunks[Y * XChunks + X], 0, 0, ChunkWidth, ChunkHeight, Fill); - CopyRect(Image, X * ChunkWidth, Y * ChunkHeight, ChunkWidth, ChunkHeight, - Chunks[Y * XChunks + X], 0, 0); - end - else - begin - // Create smaller edge chunk - XTrunc := Image.Width - (Image.Width div ChunkWidth) * ChunkWidth; - YTrunc := Image.Height - (Image.Height div ChunkHeight) * ChunkHeight; - NewImage(XTrunc, YTrunc, Image.Format, Chunks[Y * XChunks + X]); - CopyRect(Image, X * ChunkWidth, Y * ChunkHeight, XTrunc, YTrunc, - Chunks[Y * XChunks + X], 0, 0); - end; - - // If source image is in indexed format we copy its palette to chunk - if Info.IsIndexed then - begin - Move(Image.Palette^, Chunks[Y * XChunks + X].Palette^, - Info.PaletteEntries * SizeOf(TColor32Rec)); - end; - end; - - if OldFmt <> Image.Format then - begin - ConvertImage(Image, OldFmt); - for X := 0 to Length(Chunks) - 1 do - ConvertImage(Chunks[X], OldFmt); - end; - - Result := True; - except - RaiseImaging(SErrorSplitImage, [ImageToStr(Image), ChunkWidth, ChunkHeight]); - end; -end; - -function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32; - MaxColors: LongInt; ConvertImages: Boolean): Boolean; -var - I: Integer; - SrcInfo, DstInfo: PImageFormatInfo; - Target, TempImage: TImageData; - DstFormat: TImageFormat; -begin - Assert((Pal <> nil) and (MaxColors > 0)); - Result := False; - InitImage(TempImage); - - if TestImagesInArray(Images) then - try - // Null the color histogram - ReduceColorsMedianCut(0, nil, nil, nil, nil, 0, 0, nil, [raCreateHistogram]); - for I := 0 to Length(Images) - 1 do - begin - SrcInfo := ImageFormatInfos[Images[I].Format]; - if SrcInfo.IsIndexed or SrcInfo.IsSpecial then - begin - // create temp image in supported format for updating histogram - CloneImage(Images[I], TempImage); - ConvertImage(TempImage, ifA8R8G8B8); - SrcInfo := ImageFormatInfos[TempImage.Format]; - end - else - TempImage := Images[I]; - - // Update histogram with colors of each input image - ReduceColorsMedianCut(TempImage.Width * TempImage.Height, TempImage.Bits, - nil, SrcInfo, nil, MaxColors, ColorReductionMask, nil, [raUpdateHistogram]); - - if Images[I].Bits <> TempImage.Bits then - FreeImage(TempImage); - end; - // Construct reduced color map from the histogram - ReduceColorsMedianCut(0, nil, nil, nil, nil, MaxColors, ColorReductionMask, - Pal, [raMakeColorMap]); - - if ConvertImages then - begin - DstFormat := ifIndex8; - DstInfo := ImageFormatInfos[DstFormat]; - MaxColors := Min(DstInfo.PaletteEntries, MaxColors); - - for I := 0 to Length(Images) - 1 do - begin - SrcInfo := ImageFormatInfos[Images[I].Format]; - if SrcInfo.IsIndexed or SrcInfo.IsSpecial then - begin - // If source image is in format not supported by ReduceColorsMedianCut - // we convert it - ConvertImage(Images[I], ifA8R8G8B8); - SrcInfo := ImageFormatInfos[Images[I].Format]; - end; - - InitImage(Target); - NewImage(Images[I].Width, Images[I].Height, DstFormat, Target); - // We map each input image to reduced palette and replace - // image in array with mapped image - ReduceColorsMedianCut(Images[I].Width * Images[I].Height, Images[I].Bits, - Target.Bits, SrcInfo, DstInfo, MaxColors, 0, nil, [raMapImage]); - Move(Pal^, Target.Palette^, MaxColors * SizeOf(TColor32Rec)); - - FreeImage(Images[I]); - Images[I] := Target; - end; - end; - Result := True; - except - RaiseImaging(SErrorMakePaletteForImages, [MaxColors, Length(Images)]); - end; -end; - -function RotateImage(var Image: TImageData; Angle: Single): Boolean; -var - OldFmt: TImageFormat; - - procedure XShear(var Src, Dst: TImageData; Row, Offset, Weight, Bpp: Integer); +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit is heart of Imaging library. It contains basic functions for + manipulating image data as well as various image file format support.} +unit Imaging; + +{$I ImagingOptions.inc} + +interface + +uses + SysUtils, Classes, Types, ImagingTypes; + +type + { Default Imaging exception class } + EImagingError = class(Exception); + { Raised when function receives bad image (not passed TestImage).} + EImagingBadImage = class(Exception) + public + constructor Create; + end; + + { Dynamic array of TImageData records } + TDynImageDataArray = array of TImageData; + + +{ ------------------------------------------------------------------------ + Low Level Interface Functions + ------------------------------------------------------------------------} + +{ General Functions } + +{ Initializes image (all is set to zeroes). Call this for each image + before using it (before calling every other function) to be sure there + are no random-filled bytes (which would cause errors later).} +procedure InitImage(out Image: TImageData); +{ Creates empty image of given dimensions and format. Image is filled with + transparent black color (A=0, R=0, G=0, B=0).} +function NewImage(Width, Height: LongInt; Format: TImageFormat; + var Image: TImageData): Boolean; +{ Returns True if given TImageData record is valid.} +function TestImage(const Image: TImageData): Boolean; +{ Frees given image data. After this call image is in the same state + as after calling InitImage. If image is not valid (dost not pass TestImage + test) it is only zeroed by calling InitImage.} +procedure FreeImage(var Image: TImageData); +{ Call FreeImage() on all images in given dynamic array and sets its + length to zero.} +procedure FreeImagesInArray(var Images: TDynImageDataArray); +{ Returns True if all TImageData records in given array are valid. Returns False + if at least one is invalid or if array is empty.} +function TestImagesInArray(const Images: TDynImageDataArray): Boolean; +{ Checks given file for every supported image file format and if + the file is in one of them returns its string identifier + (which can be used in LoadFromStream/LoadFromMem type functions). + If file is not in any of the supported formats empty string is returned.} +function DetermineFileFormat(const FileName: string): string; +{ Checks given stream for every supported image file format and if + the stream is in one of them returns its string identifier + (which can be used in LoadFromStream/LoadFromMem type functions). + If stream is not in any of the supported formats empty string is returned.} +function DetermineStreamFormat(Stream: TStream): string; +{ Checks given memory for every supported image file format and if + the memory is in one of them returns its string identifier + (which can be used in LoadFromStream/LoadFromMem type functions). + If memory is not in any of the supported formats empty string is returned.} +function DetermineMemoryFormat(Data: Pointer; Size: LongInt): string; +{ Checks that an appropriate file format is supported purely from inspecting + the given file name's extension (not contents of the file itself). + The file need not exist.} +function IsFileFormatSupported(const FileName: string): Boolean; +{ Enumerates all registered image file formats. Descriptive name, + default extension, masks (like '*.jpg,*.jfif') and some capabilities + of each format are returned. To enumerate all formats start with Index at 0 and + call EnumFileFormats with given Index in loop until it returns False (Index is + automatically increased by 1 in function's body on successful call).} +function EnumFileFormats(var Index: LongInt; var Name, DefaultExt, Masks: string; + var CanSaveImages, IsMultiImageFormat: Boolean): Boolean; + +{ Loading Functions } + +{ Loads single image from given file.} +function LoadImageFromFile(const FileName: string; var Image: TImageData): Boolean; +{ Loads single image from given stream. If function fails stream position + is not changed.} +function LoadImageFromStream(Stream: TStream; var Image: TImageData): Boolean; +{ Loads single image from given memory location.} +function LoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; +{ Loads multiple images from given file.} +function LoadMultiImageFromFile(const FileName: string; + var Images: TDynImageDataArray): Boolean; +{ Loads multiple images from given stream. If function fails stream position + is not changed.} +function LoadMultiImageFromStream(Stream: TStream; + var Images: TDynImageDataArray): Boolean; +{ Loads multiple images from given memory location.} +function LoadMultiImageFromMemory(Data: Pointer; Size: LongInt; + var Images: TDynImageDataArray): Boolean; + +{ Saving Functions } + +{ Saves single image to given file.} +function SaveImageToFile(const FileName: string; const Image: TImageData): Boolean; +{ Saves single image to given stream. If function fails stream position + is not changed. Ext identifies desired image file format (jpg, png, dds, ...).} +function SaveImageToStream(const Ext: string; Stream: TStream; + const Image: TImageData): Boolean; +{ Saves single image to given memory location. Memory must be allocated and its + size is passed in Size parameter in which number of written bytes is returned. + Ext identifies desired image file format (jpg, png, dds, ...).} +function SaveImageToMemory(const Ext: string; Data: Pointer; var Size: LongInt; + const Image: TImageData): Boolean; +{ Saves multiple images to given file. If format supports + only single level images and there are multiple images to be saved, + they are saved as sequence of files img000.jpg, img001.jpg ....).} +function SaveMultiImageToFile(const FileName: string; + const Images: TDynImageDataArray): Boolean; +{ Saves multiple images to given stream. If format supports + only single level images and there are multiple images to be saved, + they are saved one after another to the stream. If function fails stream + position is not changed. Ext identifies desired image file format (jpg, png, dds, ...).} +function SaveMultiImageToStream(const Ext: string; Stream: TStream; + const Images: TDynImageDataArray): Boolean; +{ Saves multiple images to given memory location. If format supports + only single level images and there are multiple images to be saved, + they are saved one after another to the memory. Memory must be allocated and + its size is passed in Size parameter in which number of written bytes is returned. + Ext identifies desired image file format (jpg, png, dds, ...).} +function SaveMultiImageToMemory(const Ext: string; Data: Pointer; + var Size: LongInt; const Images: TDynImageDataArray): Boolean; + +{ Manipulation Functions } + +{ Creates identical copy of image data. Clone should be initialized + by InitImage or it should be valid image which will be freed by CloneImage.} +function CloneImage(const Image: TImageData; var Clone: TImageData): Boolean; +{ Converts image to the given format.} +function ConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; +{ Flips given image. Reverses the image along its horizontal axis - the top + becomes the bottom and vice versa.} +function FlipImage(var Image: TImageData): Boolean; +{ Mirrors given image. Reverses the image along its vertical axis � the left + side becomes the right and vice versa.} +function MirrorImage(var Image: TImageData): Boolean; +{ Resizes given image to new dimensions. Nearest, bilinear, or bicubic filtering + can be used. Input Image must already be created - use NewImage to create new images.} +function ResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt; + Filter: TResizeFilter): Boolean; +{ Swaps SrcChannel and DstChannel color or alpha channels of image. + Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to + identify channels.} +function SwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean; +{ Reduces the number of colors of the Image. Currently MaxColors must be in + range <2, 4096>. Color reduction works also for alpha channel. Note that for + large images and big number of colors it can be very slow. + Output format of the image is the same as input format.} +function ReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; +{ Generates mipmaps for image. Levels is the number of desired mipmaps levels + with zero (or some invalid number) meaning all possible levels.} +function GenerateMipMaps(const Image: TImageData; Levels: LongInt; + var MipMaps: TDynImageDataArray): Boolean; +{ Maps image to existing palette producing image in ifIndex8 format. + Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes. + As resulting image is in 8bit indexed format Entries must be lower or + equal to 256.} +function MapImageToPalette(var Image: TImageData; Pal: PPalette32; + Entries: LongInt): Boolean; +{ Splits image into XChunks x YChunks subimages. Default size of each chunk is + ChunkWidth x ChunkHeight. If PreserveSize si True chunks at the edges of + the image are also ChunkWidth x ChunkHeight sized and empty space is filled + with optional Fill pixels. After calling this function XChunks contains number of + chunks along x axis and YChunks along y axis. To access chunk [X, Y] use this + index: Chunks[Y * XChunks + X].} +function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray; + ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt; + PreserveSize: Boolean; Fill: Pointer = nil): Boolean; +{ Creates palette with MaxColors based on the colors of images in Images array. + Use it when you want to convert several images to indexed format using + single palette for all of them. If ConvertImages is True images in array + are converted to indexed format using resulting palette. if it is False + images are left intact and only resulting palette is returned in Pal. + Pal must be allocated to have at least MaxColors entries.} +function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32; + MaxColors: LongInt; ConvertImages: Boolean): Boolean; +{ Rotates image by Angle degrees counterclockwise. All angles are allowed. } +procedure RotateImage(var Image: TImageData; Angle: Single); +{ Rotates image by Angle that is multiple of 90 degrees counterclockwise. } +procedure RotateImageMul90(var Image: TImageData; AngleDeg: Integer); + +{ Drawing/Pixel functions } + +{ Copies rectangular part of SrcImage to DstImage. No blending is performed - + alpha is simply copied to destination image. Operates also with + negative X and Y coordinates. + Note that copying is fastest for images in the same data format + (and slowest for images in special formats).} +function CopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt; + var DstImage: TImageData; DstX, DstY: LongInt): Boolean; +{ Fills given rectangle of image with given pixel fill data. Fill should point + to the pixel in the same format as the given image is in.} +function FillRect(var Image: TImageData; X, Y, Width, Height: LongInt; FillColor: Pointer): Boolean; +{ Replaces pixels with OldPixel in the given rectangle by NewPixel. + OldPixel and NewPixel should point to the pixels in the same format + as the given image is in.} +function ReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt; + OldColor, NewColor: Pointer): Boolean; +{ Stretches the contents of the source rectangle to the destination rectangle + with optional resampling. No blending is performed - alpha is + simply copied/resampled to destination image. Note that stretching is + fastest for images in the same data format (and slowest for + images in special formats).} +function StretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, + SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, + DstHeight: LongInt; Filter: TResizeFilter): Boolean; +{ Copies pixel of Image at [X, Y] to memory pointed at by Pixel. Doesn't + work with special formats.} +procedure GetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); +{ Copies pixel from memory pointed at by Pixel to Image at position [X, Y]. + Doesn't work with special formats.} +procedure SetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); +{ Function for getting pixel colors. Native pixel is read from Image and + then translated to 32 bit ARGB. Works for all image formats (except special) + so it is not very fast.} +function GetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; +{ Procedure for setting pixel colors. Input 32 bit ARGB color is translated to + native format and then written to Image. Works for all image formats (except special) + so it is not very fast.} +procedure SetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); +{ Function for getting pixel colors. Native pixel is read from Image and + then translated to FP ARGB. Works for all image formats (except special) + so it is not very fast.} +function GetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; +{ Procedure for setting pixel colors. Input FP ARGB color is translated to + native format and then written to Image. Works for all image formats (except special) + so it is not very fast.} +procedure SetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); + +{ Palette Functions } + +{ Allocates new palette with Entries ARGB color entries.} +procedure NewPalette(Entries: LongInt; var Pal: PPalette32); +{ Frees given palette.} +procedure FreePalette(var Pal: PPalette32); +{ Copies Count palette entries from SrcPal starting at index SrcIdx to + DstPal at index DstPal.} +procedure CopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt); +{ Returns index of color in palette or index of nearest color if exact match + is not found. Pal must have at least Entries color entries.} +function FindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt; +{ Creates grayscale palette where each color channel has the same value. + Pal must have at least Entries color entries.} +procedure FillGrayscalePalette(Pal: PPalette32; Entries: LongInt); +{ Creates palette with given bitcount for each channel. + 2^(RBits + GBits + BBits) should be equal to Entries. Examples: + (3, 3, 2) will create palette with all possible colors of R3G3B2 format + and (8, 0, 0) will create palette with 256 shades of red. + Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes.} +procedure FillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits, + BBits: Byte; Alpha: Byte = $FF); +{ Swaps SrcChannel and DstChannel color or alpha channels of palette. + Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to + identify channels. Pal must be allocated to at least + Entries * SizeOf(TColor32Rec) bytes.} +procedure SwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel, + DstChannel: LongInt); + +{ Options Functions } + +{ Sets value of integer option specified by OptionId parameter. + Option Ids are constants starting ImagingXXX.} +function SetOption(OptionId, Value: LongInt): Boolean; +{ Returns value of integer option specified by OptionId parameter. If OptionId is + invalid, InvalidOption is returned. Option Ids are constants + starting ImagingXXX.} +function GetOption(OptionId: LongInt): LongInt; +{ Pushes current values of all options on the stack. Returns True + if successful (max stack depth is 8 now). } +function PushOptions: Boolean; +{ Pops back values of all options from the top of the stack. Returns True + if successful (max stack depth is 8 now). } +function PopOptions: Boolean; + +{ Image Data Format Functions } + +{ Returns short information about given image format.} +function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean; +{ Returns size in bytes of Width x Height area of pixels. Works for all formats.} +function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; + +{ IO Functions } + +{ User can set his own file IO functions used when loading from/saving to + files by this function.} +procedure SetUserFileIO(OpenProc: TOpenProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: + TSeekProc; TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); +{ Sets file IO functions to Imaging default.} +procedure ResetFileIO; + +{ Raw Image IO Functions } + +procedure ReadRawImageFromFile(const FileName: string; Width, Height: Integer; + Format: TImageFormat; var Image: TImageData; Offset: Integer = 0; RowLength: Integer = 0); +procedure ReadRawImageFromStream(Stream: TStream; Width, Height: Integer; + Format: TImageFormat; var Image: TImageData; Offset: Integer = 0; RowLength: Integer = 0); +procedure ReadRawImageFromMemory(Data: Pointer; DataSize: Integer; Width, Height: Integer; + Format: TImageFormat; var Image: TImageData; Offset: Integer = 0; RowLength: Integer = 0); +procedure ReadRawImageRect(Data: Pointer; Left, Top, Width, Height: Integer; + var Image: TImageData; Offset: Integer = 0; RowLength: Integer = 0); + +procedure WriteRawImageToFile(const FileName: string; const Image: TImageData; + Offset: Integer = 0; RowLength: Integer = 0); +procedure WriteRawImageToStream(Stream: TStream; const Image: TImageData; + Offset: Integer = 0; RowLength: Integer = 0); +procedure WriteRawImageToMemory(Data: Pointer; DataSize: Integer; const Image: TImageData; + Offset: Integer = 0; RowLength: Integer = 0); +procedure WriteRawImageRect(Data: Pointer; Left, Top, Width, Height: Integer; + const Image: TImageData; Offset: Integer = 0; RowLength: Integer = 0); + +{ Convenience/helper Functions } + +{ Resizes image proportionally to fit the given width and height. } +procedure ResizeImageToFit(const SrcImage: TImageData; FitWidth, FitHeight: Integer; + Filter: TResizeFilter; var DestImage: TImageData); + +{ Color functions } + +{ Constructs TColor24Rec color.} +function Color24(R, G, B: Byte): TColor24Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Constructs TColor32Rec color.} +function Color32(A, R, G, B: Byte): TColor32Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Constructs TColor48Rec color.} +function Color48(R, G, B: Word): TColor48Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Constructs TColor64Rec color.} +function Color64(A, R, G, B: Word): TColor64Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Constructs TColorFPRec color.} +function ColorFP(A, R, G, B: Single): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Constructs TColorHFRec color.} +function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF} + +{ Convenience function for getting alpha component of TColor32.} +function GetAlphaValue(Color32: TColor32): Byte; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Convenience function for getting red component of TColor32.} +function GetRedValue(Color32: TColor32): Byte; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Convenience function for getting green component of TColor32.} +function GetGreenValue(Color32: TColor32): Byte; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Convenience function for getting blue component of TColor32.} +function GetBlueValue(Color32: TColor32): Byte; {$IFDEF USE_INLINE}inline;{$ENDIF} + + +{ ------------------------------------------------------------------------ + Other Imaging Stuff + ------------------------------------------------------------------------} + +type + { Set of TImageFormat enum.} + TImageFormats = set of TImageFormat; + + { Record containing set of IO functions internally used by image loaders/savers.} + TIOFunctions = record + Open: TOpenProc; + Close: TCloseProc; + Eof: TEofProc; + Seek: TSeekProc; + Tell: TTellProc; + Read: TReadProc; + Write: TWriteProc; + end; + PIOFunctions = ^TIOFunctions; + +type + TFileFormatFeature = ( + ffLoad, + ffSave, + ffMultiImage, + ffReadOnSave, + ffProgress, + ffReadScanlines); + + TFileFormatFeatures = set of TFileFormatFeature; + + TMetadata = class; + + { Base class for various image file format loaders/savers which + descend from this class. If you want to add support for new image file + format the best way is probably to look at TImageFileFormat descendants' + implementations that are already part of Imaging.} +{$TYPEINFO ON} + TImageFileFormat = class + private + FExtensions: TStringList; + FMasks: TStringList; + function GetCanLoad: Boolean; + function GetCanSave: Boolean; + function GetIsMultiImageFormat: Boolean; + { Does various checks and actions before LoadData method is called.} + function PrepareLoad(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstFrame: Boolean): Boolean; + { Processes some actions according to result of LoadData.} + function PostLoadCheck(var Images: TDynImageDataArray; LoadResult: Boolean): Boolean; + { Helper function to be called in SaveData methods of descendants (ensures proper + index and sets FFirstIdx and FLastIdx for multi-images).} + function PrepareSave(Handle: TImagingHandle; const Images: TDynImageDataArray; + var Index: LongInt): Boolean; + { Returns file open mode used for saving images. Depends on defined Features.} + function GetSaveOpenMode: TOpenMode; + protected + FName: string; + FFeatures: TFileFormatFeatures; + FSupportedFormats: TImageFormats; + FFirstIdx, FLastIdx: LongInt; + FMetadata: TMetadata; + { Descendants must override this method and define file format name and + capabilities.} + procedure Define; virtual; + { Defines filename masks for this image file format. AMasks should be + in format '*.ext1,*.ext2,umajo.*'.} + procedure AddMasks(const AMasks: string); + function GetFormatInfo(Format: TImageFormat): TImageFormatInfo; + { Returns set of TImageData formats that can be saved in this file format + without need for conversion.} + function GetSupportedFormats: TImageFormats; virtual; + { Method which must be overridden in descendants if they' are be capable + of loading images. Images are already freed and length is set to zero + whenever this method gets called. Also Handle is assured to be valid + and contains data that passed TestFormat method's check.} + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstFrame: Boolean): Boolean; virtual; + { Method which must be overridden in descendants if they are be capable + of saving images. Images are checked to have length >0 and + that they contain valid images. For single-image file formats + Index contain valid index to Images array (to image which should be saved). + Multi-image formats should use FFirstIdx and FLastIdx fields to + to get all images that are to be saved.} + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; virtual; + { This method is called internally by MakeCompatible when input image + is in format not supported by this file format. Image is clone of + MakeCompatible's input and Info is its extended format info.} + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); virtual; + { Returns True if given image is supported for saving by this file format. + Most file formats don't need to override this method. It checks + (in this base class) if Image's format is in SupportedFormats set. + But you may override it if you want further checks + (proper width and height for example).} + function IsSupported(const Image: TImageData): Boolean; virtual; + public + constructor Create(AMetadata: TMetadata = nil); virtual; + destructor Destroy; override; + + { Loads images from file source.} + function LoadFromFile(const FileName: string; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean = False): Boolean; + { Loads images from stream source.} + function LoadFromStream(Stream: TStream; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean = False): Boolean; + { Loads images from memory source.} + function LoadFromMemory(Data: Pointer; Size: LongInt; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean = False): Boolean; + + { Saves images to file. If format supports only single level images and + there are multiple images to be saved, they are saved as sequence of + independent images (for example SaveToFile saves sequence of + files img000.jpg, img001.jpg ....).} + function SaveToFile(const FileName: string; const Images: TDynImageDataArray; + OnlyFirstLevel: Boolean = False): Boolean; + { Saves images to stream. If format supports only single level images and + there are multiple images to be saved, they are saved as sequence of + independent images.} + function SaveToStream(Stream: TStream; const Images: TDynImageDataArray; + OnlyFirstLevel: Boolean = False): Boolean; + { Saves images to memory. If format supports only single level images and + there are multiple images to be saved, they are saved as sequence of + independent images. Data must be already allocated and their size passed + as Size parameter, number of written bytes is then returned in the same + parameter.} + function SaveToMemory(Data: Pointer; var Size: LongInt; + const Images: TDynImageDataArray; OnlyFirstLevel: Boolean = False): Boolean; + + { Makes Image compatible with this file format (that means it is in one + of data formats in Supported formats set). If input is already + in supported format then Compatible just use value from input + (Compatible := Image) so must not free it after you are done with it + (image bits pointer points to input image's bits). + If input is not in supported format then it is cloned to Compatible + and converted to one of supported formats (what exact format depends on + this file format). If image is cloned MustBeFreed is set to True + to indicated that you must free Compatible after you are done with it.} + function MakeCompatible(const Image: TImageData; var Compatible: TImageData; + out MustBeFreed: Boolean): Boolean; + { Returns True if data located in source identified by Handle + represent valid image in current format.} + function TestFormat(Handle: TImagingHandle): Boolean; virtual; + { Returns True if the given FileName matches filter for this file format. + For most formats it just checks filename extensions. + It uses filename masks in from Masks property so it can recognize + filenames like this 'umajoXXXumajo.j0j' if one of the masks is + 'umajo*umajo.j?j'.} + function TestFileName(const FileName: string): Boolean; + { Descendants use this method to check if their options (registered with + constant Ids for SetOption/GetOption interface or accessible as properties + of descendants) have valid values and make necessary changes.} + procedure CheckOptionsValidity; virtual; + + { Description of this format.} + property Name: string read FName; + { Indicates whether images in this format can be loaded.} + property CanLoad: Boolean read GetCanLoad; + { Indicates whether images in this format can be saved.} + property CanSave: Boolean read GetCanSave; + { Indicates whether images in this format can contain multiple image levels.} + property IsMultiImageFormat: Boolean read GetIsMultiImageFormat; + { List of filename extensions for this format.} + property Extensions: TStringList read FExtensions; + { List of filename masks that are used to associate filenames + with TImageFileFormat descendants. Typical mask looks like + '*.bmp' or 'texture.*' (supports file formats which use filename instead + of extension to identify image files).} + property Masks: TStringList read FMasks; + { Set of TImageFormats supported by saving functions of this format. Images + can be saved only in one those formats.} + property SupportedFormats: TImageFormats read GetSupportedFormats; + end; +{$TYPEINFO OFF} + + { Class reference for TImageFileFormat class} + TImageFileFormatClass = class of TImageFileFormat; + + { Physical resolution unit.} + TResolutionUnit = ( + ruSizeInMicroMeters, // value is pixel size in micrometers + ruDpi, // value is pixels/dots per inch + ruDpm, // value is pixels/dots per meter + ruDpcm // value is pixels/dots per centimeter + ); + + { Class for storage of single metadata item.} + TMetadataItem = class + public + Id: string; + ImageIndex: Integer; + Value: Variant; + end; + + { Metadata manager class.} + TMetadata = class + private + FLoadMetaItems: TStringList; + FSaveMetaItems: TStringList; + procedure AddMetaToList(List: TStringList; const Id: string; const Value: Variant; ImageIndex: Integer); + procedure ClearMetaList(List: TStringList); + function GetMetaById(const Id: string): Variant; + function GetMetaByIdMulti(const Id: string; ImageIndex: Integer): Variant; + function GetMetaCount: Integer; + function GetMetaByIdx(Index: Integer): TMetadataItem; + function GetSaveMetaById(const Id: string): Variant; + function GetSaveMetaByIdMulti(const Id: string; ImageIndex: Integer): Variant; + procedure TranslateUnits(ResolutionUnit: TResolutionUnit; var XRes, YRes: Double); + public + constructor Create; + destructor Destroy; override; + + procedure SetMetaItem(const Id: string; const Value: Variant; ImageIndex: Integer = 0); + procedure SetMetaItemForSaving(const Id: string; const Value: Variant; ImageIndex: Integer = 0); + function HasMetaItem(const Id: string; ImageIndex: Integer = 0): Boolean; + function HasMetaItemForSaving(const Id: string; ImageIndex: Integer = 0): Boolean; + + procedure ClearMetaItems; + procedure ClearMetaItemsForSaving; + function GetMetaItemName(const Id: string; ImageIndex: Integer): string; + { Copies loaded meta items to items-for-save stack. Use this when you want to + save metadata that have been just loaded (e.g. resaving image in + different file format but keeping the metadata).} + procedure CopyLoadedMetaItemsForSaving; + + function GetPhysicalPixelSize(ResUnit: TResolutionUnit; out XSize, + YSize: Double; MetaForSave: Boolean = False; ImageIndex: Integer = 0): Boolean; + procedure SetPhysicalPixelSize(ResUnit: TResolutionUnit; XSize, YSize: Double; + MetaForSave: Boolean = False; ImageIndex: Integer = 0); + + property MetaItems[const Id: string]: Variant read GetMetaById; + property MetaItemsMulti[const Id: string; ImageIndex: Integer]: Variant read GetMetaByIdMulti; + { Number of loaded metadata items.} + property MetaItemCount: Integer read GetMetaCount; + property MetaItemsByIdx[Index: Integer]: TMetadataItem read GetMetaByIdx; + property MetaItemsForSaving[const Id: string]: Variant read GetSaveMetaById; + property MetaItemsForSavingMulti[const Id: string; ImageIndex: Integer]: Variant read GetSaveMetaByIdMulti; + end; + +const + { Metadata item id constants } + + { Physical size of one pixel in micrometers. Type of value is Double.} + SMetaPhysicalPixelSizeX = 'PhysicalPixelSizeX'; + SMetaPhysicalPixelSizeY = 'PhysicalPixelSizeY'; + { Delay for frame of animation (how long it should stay visible) in milliseconds. + Type of value is Integer.} + SMetaFrameDelay = 'FrameDelay'; + { Number of times animation should be looped (0 = infinite looping). Type is Int. } + SMetaAnimationLoops = 'AnimationLoops'; + { Gamma correction value. Type is Float.} + SMetaGamma = 'Gamma'; + { Exposure value for HDR etc. Type is Float.} + SMetaExposure = 'Exposure'; + { EXIF image metadata raw blob.} + SMetaExifBlob = 'ExifBlob'; + { XMP image metadata raw blob.} + SMetaXmpBlob = 'XmpBlob'; + { IPTC image metadata raw blob.} + SMetaIptcBlob = 'IptcBlob'; + +var + GlobalMetadata: TMetadata; + +{ Returns symbolic name of given format.} +function GetFormatName(Format: TImageFormat): string; +{ Returns string with information about given Image.} +function ImageToStr(const Image: TImageData): string; +{ Returns Imaging version string in format 'Major.Minor'.} +function GetVersionStr: string; +{ If Condition is True then TruePart is returned, otherwise FalsePart is returned.} +function IffFormat(Condition: Boolean; const TruePart, FalsePart: TImageFormat): TImageFormat; + +{ Registers new option so it can be used by SetOption and GetOption functions. + Returns True if registration was successful - that is Id is valid and is + not already taken by another option.} +function RegisterOption(OptionId: LongInt; Variable: PLongInt): Boolean; + +{ Registers new image loader/saver so it can be used by LoadFrom/SaveTo + functions.} +procedure RegisterImageFileFormat(AClass: TImageFileFormatClass); +{ Returns image format loader/saver according to a given extension + (case insensitive) or nil if not found. Extension may or may not + contain the initial dot.} +function FindImageFileFormatByExt(const Ext: string): TImageFileFormat; +{ Returns image format loader/saver according to a given filename + (case insensitive) or nil if not found. } +function FindImageFileFormatByName(const FileName: string): TImageFileFormat; +{ Returns image format loader/saver based on its class + or nil if not found or not registered.} +function FindImageFileFormatByClass(AClass: TImageFileFormatClass): TImageFileFormat; +{ Returns number of registered image file format loaders/saver.} +function GetFileFormatCount: LongInt; +{ Returns image file format loader/saver at given index. Index must be + in range [0..GetFileFormatCount - 1] otherwise nil is returned.} +function GetFileFormatAtIndex(Index: LongInt): TImageFileFormat; +{ Returns filter string for usage with open and save picture dialogs + which contains all registered image file formats. + Set OpenFileFilter to True if you want filter for open dialog + and to False if you want save dialog filter (formats that cannot save to files + are not added then). + For open dialog filter for all known graphic files + (like All(*.jpg;*.png;....) is added too at the first index.} +function GetImageFileFormatsFilter(OpenFileFilter: Boolean): string; +{ Returns file extension (without dot) of image format selected + by given filter index. Used filter string is defined by GetImageFileFormatsFilter + function. This function can be used with save dialogs (with filters created + by GetImageFileFormatsFilter) to get the extension of file format selected + in dialog quickly. Index is in range 1..N (as FilterIndex property + of TOpenDialog/TSaveDialog)} +function GetFilterIndexExtension(Index: LongInt; OpenFileFilter: Boolean): string; +{ Returns filter index of image file format of file specified by FileName. Used filter + string is defined by GetImageFileFormatsFilter function. + Returned index is in range 1..N (as FilterIndex property of TOpenDialog/TSaveDialog)} +function GetFileNameFilterIndex(const FileName: string; OpenFileFilter: Boolean): LongInt; + +{ Returns current IO functions.} +function GetIO: TIOFunctions; +{ Raises EImagingError with given message.} +procedure RaiseImaging(const Msg: string; const Args: array of const); overload; +procedure RaiseImaging(const Msg: string); overload; {$IFDEF USE_INLINE}inline;{$ENDIF} + +const + SImagingLibTitle = 'Vampyre Imaging Library'; + +implementation + +uses +{$IFNDEF DONT_LINK_FILE_FORMATS} +{$IFNDEF DONT_LINK_BITMAP} + ImagingBitmap, +{$ENDIF} +{$IFNDEF DONT_LINK_JPEG} + ImagingJpeg, +{$ENDIF} +{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)} + ImagingNetworkGraphics, +{$IFEND} +{$IFNDEF DONT_LINK_GIF} + ImagingGif, +{$ENDIF} +{$IFNDEF DONT_LINK_DDS} + ImagingDds, +{$ENDIF} +{$IFNDEF DONT_LINK_TARGA} + ImagingTarga, +{$ENDIF} +{$IFNDEF DONT_LINK_PNM} + ImagingPortableMaps, +{$ENDIF} +{$IFNDEF DONT_LINK_RADHDR} + ImagingRadiance, +{$ENDIF} +{$IFNDEF DONT_LINK_EXTRAS} + ImagingExtFileFormats, +{$ENDIF} +{$ENDIF} + //ImagingDebug, + ImagingFormats, ImagingUtility, ImagingIO, Variants; + +resourcestring + SExceptMsg = 'Exception Message'; + SAllFilter = 'All Images'; + SUnknownFormat = 'Unknown and unsupported format'; + + SErrorFreeImage = 'Error while freeing image. %s'; + SErrorCloneImage = 'Error while cloning image. %s'; + SErrorFlipImage = 'Error while flipping image. %s'; + SErrorMirrorImage = 'Error while mirroring image. %s'; + SErrorResizeImage = 'Error while resizing image. %s'; + SErrorSwapImage = 'Error while swapping channels of image. %s'; + SFileFormatCanNotLoad = 'Image Format "%s" does not support loading images.'; + SFileFormatCanNotSave = 'Image Format "%s" does not support saving images.'; + SErrorNewImage = 'Error while creating image data with params: Width=%d ' + + 'Height=%d Format=%s.'; + SErrorConvertImage = 'Error while converting image to format "%s". %s'; + SImageInfo = 'Image @%p info: Width = %dpx, Height = %dpx, ' + + 'Format = %s, Size = %.0n %s, Bits @%p, Palette @%p.'; + SImageInfoInvalid = 'Access violation encountered when getting info on ' + + 'image at address %p.'; + SFileNotValid = 'File "%s" is not valid image in "%s" format.'; + SStreamNotValid = 'Stream %p does not contain valid image in "%s" format.'; + SMemoryNotValid = 'Memory %p (%d Bytes) does not contain valid image ' + + 'in "%s" format.'; + SErrorLoadingFile = 'Error while loading images from file "%s" (file format: %s).'; + SErrorLoadingStream = 'Error while loading images from stream %p (file format: %s).'; + SErrorLoadingMemory = 'Error while loading images from memory %p (%d Bytes) (file format: %s).'; + SErrorSavingFile = 'Error while saving images to file "%s" (file format: %s).'; + SErrorSavingStream = 'Error while saving images to stream %p (file format: %s).'; + SErrorSavingMemory = 'Error while saving images to memory %p (%d Bytes) (file format: %s).'; + SErrorFindColor = 'Error while finding color in palette @%p with %d entries.'; + SErrorGrayscalePalette = 'Error while filling grayscale palette @%p with %d entries.'; + SErrorCustomPalette = 'Error while filling custom palette @%p with %d entries.'; + SErrorSwapPalette = 'Error while swapping channels of palette @%p with %d entries.'; + SErrorReduceColors = 'Error while reducing number of colors of image to %d. %s'; + SErrorGenerateMipMaps = 'Error while generating %d mipmap levels for image %s'; + SImagesNotValid = 'One or more images are not valid.'; + SErrorCopyRect = 'Error while copying rect from image %s to image %s.'; + SErrorMapImage = 'Error while mapping image %s to palette.'; + SErrorFillRect = 'Error while filling rectangle X:%d Y:%d W:%d H:%d in image %s'; + SErrorSplitImage = 'Error while splitting image %s to %dx%d sized chunks.'; + SErrorMakePaletteForImages = 'Error while making %d color palette for %d images.'; + SErrorNewPalette = 'Error while creating new palette with %d entries'; + SErrorFreePalette = 'Error while freeing palette @%p'; + SErrorCopyPalette = 'Error while copying %d entries from palette @%p to @%p'; + SErrorReplaceColor = 'Error while replacing colors in rectangle X:%d Y:%d W:%d H:%d of image %s'; + SErrorRotateImage = 'Error while rotating image %s by %.2n degrees'; + SErrorStretchRect = 'Error while stretching rect from image %s to image %s.'; + SErrorEmptyStream = 'Input stream has no data. Check Position property.'; + SErrorInvalidInputImage = 'Invalid input image.'; + + SErrorBadImage = 'Bad image detected.'; + +const + // Initial size of array with options information + InitialOptions = 256; + // Max depth of the option stack + OptionStackDepth = 8; + // Do not change the default format now, its too late + DefaultImageFormat: TImageFormat = ifA8R8G8B8; + // Format used to create metadata IDs for frames loaded from multi-images. + SMetaIdForSubImage = '%s/%d'; + +type + TOptionArray = array of PLongInt; + TOptionValueArray = array of LongInt; + + TOptionStack = class(TObject) + private + FStack: array[0..OptionStackDepth - 1] of TOptionValueArray; + FPosition: LongInt; + public + constructor Create; + destructor Destroy; override; + function Push: Boolean; + function Pop: Boolean; + end; + +var + // Currently set IO functions + IO: TIOFunctions; + // List with all registered TImageFileFormat classes + ImageFileFormats: TList = nil; + // Array with registered options (pointers to their values) + Options: TOptionArray = nil; + // Array containing additional information about every image format + ImageFormatInfos: TImageFormatInfoArray; + // Stack used by PushOptions/PopOptions functions + OptionStack: TOptionStack = nil; +var + // Variable for ImagingColorReduction option + ColorReductionMask: LongInt = $FF; + // Variable for ImagingLoadOverrideFormat option + LoadOverrideFormat: TImageFormat = ifUnknown; + // Variable for ImagingSaveOverrideFormat option + SaveOverrideFormat: TImageFormat = ifUnknown; + // Variable for ImagingSaveOverrideFormat option + MipMapFilter: TSamplingFilter = sfLinear; + // Variable for ImagingBinaryThreshold option + BinaryThreshold: Integer = 128; + +{ Exceptions } + +constructor EImagingBadImage.Create; +begin + inherited Create(SErrorBadImage); +end; + +{ Internal unit functions } + +{ Modifies option value to be in the allowed range. Works only + for options registered in this unit.} +function CheckOptionValue(OptionId, Value: LongInt): LongInt; forward; +{ Sets IO functions to file IO.} +procedure SetFileIO; forward; +{ Sets IO functions to stream IO.} +procedure SetStreamIO; forward; +{ Sets IO functions to memory IO.} +procedure SetMemoryIO; forward; +{ Inits image format infos array.} +procedure InitImageFormats; forward; +{ Free image format infos array.} +procedure FreeImageFileFormats; forward; +{ Creates options array and stack.} +procedure InitOptions; forward; +{ Frees options array and stack.} +procedure FreeOptions; forward; + +function UpdateExceptMessage(E: Exception; const MsgToPrepend: string; const Args: array of const): Exception; +begin + Result := E; + E.Message := Format(MsgToPrepend, Args) + ' ' + SExceptMsg + ': ' + E.Message +end; + +{ ------------------------------------------------------------------------ + Low Level Interface Functions + ------------------------------------------------------------------------} + +{ General Functions } + +procedure InitImage(out Image: TImageData); +begin + FillChar(Image, SizeOf(Image), 0); +end; + +function NewImage(Width, Height: LongInt; Format: TImageFormat; var Image: + TImageData): Boolean; +var + FInfo: PImageFormatInfo; +begin + Assert((Width > 0) and (Height >0)); + Assert(IsImageFormatValid(Format)); + Result := False; + FreeImage(Image); + try + Image.Width := Width; + Image.Height := Height; + // Select default data format if selected + if (Format = ifDefault) then + Image.Format := DefaultImageFormat + else + Image.Format := Format; + // Get extended format info + FInfo := ImageFormatInfos[Image.Format]; + if FInfo = nil then + begin + InitImage(Image); + Exit; + end; + // Check image dimensions and calculate its size in bytes + FInfo.CheckDimensions(FInfo.Format, Image.Width, Image.Height); + Image.Size := FInfo.GetPixelsSize(FInfo.Format, Image.Width, Image.Height); + if Image.Size = 0 then + begin + InitImage(Image); + Exit; + end; + // Image bits are allocated and set to zeroes + GetMem(Image.Bits, Image.Size); + FillChar(Image.Bits^, Image.Size, 0); + // Palette is allocated and set to zeroes + if FInfo.PaletteEntries > 0 then + begin + GetMem(Image.Palette, FInfo.PaletteEntries * SizeOf(TColor32Rec)); + FillChar(Image.Palette^, FInfo.PaletteEntries * SizeOf(TColor32Rec), 0); + end; + Result := TestImage(Image); + except + on E: Exception do + begin + FreeMem(Image.Bits); + FreeMem(Image.Palette); + InitImage(Image); + raise UpdateExceptMessage(E, SErrorNewImage, [Width, Height, GetFormatName(Format)]); + end; + end; +end; + +function TestImage(const Image: TImageData): Boolean; +begin + try + Result := (LongInt(Image.Format) >= LongInt(Low(TImageFormat))) and + (LongInt(Image.Format) <= LongInt(High(TImageFormat))) and + (ImageFormatInfos[Image.Format] <> nil) and + (Assigned(ImageFormatInfos[Image.Format].GetPixelsSize) and + (ImageFormatInfos[Image.Format].GetPixelsSize(Image.Format, + Image.Width, Image.Height) = Image.Size)); + except + // Possible int overflows or other errors + Result := False; + end; +end; + +procedure FreeImage(var Image: TImageData); +begin + try + if TestImage(Image) then + begin + FreeMemNil(Image.Bits); + FreeMemNil(Image.Palette); + end; + InitImage(Image); + except + raise UpdateExceptMessage(GetExceptObject, SErrorFreeImage, [ImageToStr(Image)]); + end; +end; + +procedure FreeImagesInArray(var Images: TDynImageDataArray); +var + I: LongInt; +begin + if Length(Images) > 0 then + begin + for I := 0 to Length(Images) - 1 do + FreeImage(Images[I]); + SetLength(Images, 0); + end; +end; + +function TestImagesInArray(const Images: TDynImageDataArray): Boolean; +var + I: LongInt; +begin + if Length(Images) > 0 then + begin + Result := True; + for I := 0 to Length(Images) - 1 do + begin + Result := Result and TestImage(Images[I]); + if not Result then + Break; + end; + end + else + Result := False; +end; + +function DetermineFileFormat(const FileName: string): string; +var + I: LongInt; + Fmt: TImageFileFormat; + Handle: TImagingHandle; +begin + Assert(FileName <> ''); + Result := ''; + SetFileIO; + Handle := IO.Open(PChar(FileName), omReadOnly); + try + // First file format according to FileName and test if the data in + // file is really in that format + for I := 0 to ImageFileFormats.Count - 1 do + begin + Fmt := TImageFileFormat(ImageFileFormats[I]); + if Fmt.TestFileName(FileName) and Fmt.TestFormat(Handle) then + begin + Result := Fmt.Extensions[0]; + Exit; + end; + end; + // No file format was found with filename search so try data-based search + for I := 0 to ImageFileFormats.Count - 1 do + begin + Fmt := TImageFileFormat(ImageFileFormats[I]); + if Fmt.TestFormat(Handle) then + begin + Result := Fmt.Extensions[0]; + Exit; + end; + end; + finally + IO.Close(Handle); + end; +end; + +function DetermineStreamFormat(Stream: TStream): string; +var + I: LongInt; + Fmt: TImageFileFormat; + Handle: TImagingHandle; +begin + Assert(Stream <> nil); + Result := ''; + SetStreamIO; + Handle := IO.Open(Pointer(Stream), omReadOnly); + try + for I := 0 to ImageFileFormats.Count - 1 do + begin + Fmt := TImageFileFormat(ImageFileFormats[I]); + if Fmt.TestFormat(Handle) then + begin + Result := Fmt.Extensions[0]; + Exit; + end; + end; + finally + IO.Close(Handle); + end; +end; + +function DetermineMemoryFormat(Data: Pointer; Size: LongInt): string; +var + I: LongInt; + Fmt: TImageFileFormat; + Handle: TImagingHandle; + IORec: TMemoryIORec; +begin + Assert((Data <> nil) and (Size > 0)); + Result := ''; + SetMemoryIO; + IORec.Data := Data; + IORec.Position := 0; + IORec.Size := Size; + Handle := IO.Open(@IORec, omReadOnly); + try + for I := 0 to ImageFileFormats.Count - 1 do + begin + Fmt := TImageFileFormat(ImageFileFormats[I]); + if Fmt.TestFormat(Handle) then + begin + Result := Fmt.Extensions[0]; + Exit; + end; + end; + finally + IO.Close(Handle); + end; +end; + +function IsFileFormatSupported(const FileName: string): Boolean; +begin + Result := FindImageFileFormatByName(FileName) <> nil; +end; + +function EnumFileFormats(var Index: LongInt; var Name, DefaultExt, Masks: string; + var CanSaveImages, IsMultiImageFormat: Boolean): Boolean; +var + FileFmt: TImageFileFormat; +begin + FileFmt := GetFileFormatAtIndex(Index); + Result := FileFmt <> nil; + if Result then + begin + Name := FileFmt.Name; + DefaultExt := FileFmt.Extensions[0]; + Masks := FileFmt.Masks.DelimitedText; + CanSaveImages := FileFmt.CanSave; + IsMultiImageFormat := FileFmt.IsMultiImageFormat; + Inc(Index); + end + else + begin + Name := ''; + DefaultExt := ''; + Masks := ''; + CanSaveImages := False; + IsMultiImageFormat := False; + end; +end; + +{ Loading Functions } + +function LoadImageFromFile(const FileName: string; var Image: TImageData): + Boolean; +var + Format: TImageFileFormat; + IArray: TDynImageDataArray; + I: LongInt; +begin + Assert(FileName <> ''); + Result := False; + Format := FindImageFileFormatByExt(DetermineFileFormat(FileName)); + if Format <> nil then + begin + FreeImage(Image); + Result := Format.LoadFromFile(FileName, IArray, True); + if Result and (Length(IArray) > 0) then + begin + Image := IArray[0]; + for I := 1 to Length(IArray) - 1 do + FreeImage(IArray[I]); + end + else + Result := False; + end; +end; + +function LoadImageFromStream(Stream: TStream; var Image: TImageData): Boolean; +var + Format: TImageFileFormat; + IArray: TDynImageDataArray; + I: LongInt; +begin + Assert(Stream <> nil); + if Stream.Size - Stream.Position = 0 then + RaiseImaging(SErrorEmptyStream, []); + Result := False; + Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream)); + if Format <> nil then + begin + FreeImage(Image); + Result := Format.LoadFromStream(Stream, IArray, True); + if Result and (Length(IArray) > 0) then + begin + Image := IArray[0]; + for I := 1 to Length(IArray) - 1 do + FreeImage(IArray[I]); + end + else + Result := False; + end; +end; + +function LoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; +var + Format: TImageFileFormat; + IArray: TDynImageDataArray; + I: LongInt; +begin + Assert((Data <> nil) and (Size > 0)); + Result := False; + Format := FindImageFileFormatByExt(DetermineMemoryFormat(Data, Size)); + if Format <> nil then + begin + FreeImage(Image); + Result := Format.LoadFromMemory(Data, Size, IArray, True); + if Result and (Length(IArray) > 0) then + begin + Image := IArray[0]; + for I := 1 to Length(IArray) - 1 do + FreeImage(IArray[I]); + end + else + Result := False; + end; +end; + +function LoadMultiImageFromFile(const FileName: string; var Images: + TDynImageDataArray): Boolean; +var + Format: TImageFileFormat; +begin + Assert(FileName <> ''); + Result := False; + Format := FindImageFileFormatByExt(DetermineFileFormat(FileName)); + if Format <> nil then + begin + FreeImagesInArray(Images); + Result := Format.LoadFromFile(FileName, Images); + end; +end; + +function LoadMultiImageFromStream(Stream: TStream; var Images: TDynImageDataArray): Boolean; +var + Format: TImageFileFormat; +begin + Assert(Stream <> nil); + if Stream.Size - Stream.Position = 0 then + RaiseImaging(SErrorEmptyStream, []); + Result := False; + Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream)); + if Format <> nil then + begin + FreeImagesInArray(Images); + Result := Format.LoadFromStream(Stream, Images); + end; +end; + +function LoadMultiImageFromMemory(Data: Pointer; Size: LongInt; + var Images: TDynImageDataArray): Boolean; +var + Format: TImageFileFormat; +begin + Assert((Data <> nil) and (Size > 0)); + Result := False; + Format := FindImageFileFormatByExt(DetermineMemoryFormat(Data, Size)); + if Format <> nil then + begin + FreeImagesInArray(Images); + Result := Format.LoadFromMemory(Data, Size, Images); + end; +end; + +{ Saving Functions } + +function SaveImageToFile(const FileName: string; const Image: TImageData): Boolean; +var + Format: TImageFileFormat; + IArray: TDynImageDataArray; +begin + Assert(FileName <> ''); + Result := False; + Format := FindImageFileFormatByName(FileName); + if Format <> nil then + begin + SetLength(IArray, 1); + IArray[0] := Image; + Result := Format.SaveToFile(FileName, IArray, True); + end; +end; + +function SaveImageToStream(const Ext: string; Stream: TStream; + const Image: TImageData): Boolean; +var + Format: TImageFileFormat; + IArray: TDynImageDataArray; +begin + Assert((Ext <> '') and (Stream <> nil)); + Result := False; + Format := FindImageFileFormatByExt(Ext); + if Format <> nil then + begin + SetLength(IArray, 1); + IArray[0] := Image; + Result := Format.SaveToStream(Stream, IArray, True); + end; +end; + +function SaveImageToMemory(const Ext: string; Data: Pointer; var Size: LongInt; + const Image: TImageData): Boolean; +var + Format: TImageFileFormat; + IArray: TDynImageDataArray; +begin + Assert((Ext <> '') and (Data <> nil) and (Size > 0)); + Result := False; + Format := FindImageFileFormatByExt(Ext); + if Format <> nil then + begin + SetLength(IArray, 1); + IArray[0] := Image; + Result := Format.SaveToMemory(Data, Size, IArray, True); + end; +end; + +function SaveMultiImageToFile(const FileName: string; + const Images: TDynImageDataArray): Boolean; +var + Format: TImageFileFormat; +begin + Assert(FileName <> ''); + Result := False; + Format := FindImageFileFormatByName(FileName); + if Format <> nil then + Result := Format.SaveToFile(FileName, Images); +end; + +function SaveMultiImageToStream(const Ext: string; Stream: TStream; + const Images: TDynImageDataArray): Boolean; +var + Format: TImageFileFormat; +begin + Assert((Ext <> '') and (Stream <> nil)); + Result := False; + Format := FindImageFileFormatByExt(Ext); + if Format <> nil then + Result := Format.SaveToStream(Stream, Images); +end; + +function SaveMultiImageToMemory(const Ext: string; Data: Pointer; + var Size: LongInt; const Images: TDynImageDataArray): Boolean; +var + Format: TImageFileFormat; +begin + Assert((Ext <> '') and (Data <> nil) and (Size > 0)); + Result := False; + Format := FindImageFileFormatByExt(Ext); + if Format <> nil then + Result := Format.SaveToMemory(Data, Size, Images); +end; + +{ Manipulation Functions } + +function CloneImage(const Image: TImageData; var Clone: TImageData): Boolean; +var + Info: PImageFormatInfo; +begin + Result := False; + if TestImage(Image) then + try + if TestImage(Clone) and (Image.Bits <> Clone.Bits) then + FreeImage(Clone) + else + InitImage(Clone); + + Info := ImageFormatInfos[Image.Format]; + Clone.Width := Image.Width; + Clone.Height := Image.Height; + Clone.Format := Image.Format; + Clone.Size := Image.Size; + + if Info.PaletteEntries > 0 then + begin + GetMem(Clone.Palette, Info.PaletteEntries * SizeOf(TColor32Rec)); + Move(Image.Palette^, Clone.Palette^, Info.PaletteEntries * + SizeOf(TColor32Rec)); + end; + + GetMem(Clone.Bits, Clone.Size); + Move(Image.Bits^, Clone.Bits^, Clone.Size); + Result := True; + except + raise UpdateExceptMessage(GetExceptObject, SErrorCloneImage, [ImageToStr(Image)]); + end; +end; + +function ConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; +var + NewData: Pointer; + NewPal: PPalette32; + NewSize, NumPixels: LongInt; + SrcInfo, DstInfo: PImageFormatInfo; +begin + Assert(IsImageFormatValid(DestFormat)); + Result := False; + if TestImage(Image) then + with Image do + try + // If default format is set we use DefaultImageFormat + if DestFormat = ifDefault then + DestFormat := DefaultImageFormat; + SrcInfo := ImageFormatInfos[Format]; + DstInfo := ImageFormatInfos[DestFormat]; + if SrcInfo = DstInfo then + begin + // There is nothing to convert - src is already in dest format + Result := True; + Exit; + end; + // Exit Src or Dest format is invalid + if (SrcInfo = nil) or (DstInfo = nil) then Exit; + // If dest format is just src with swapped channels we call + // SwapChannels instead + if (SrcInfo.RBSwapFormat = DestFormat) and + (DstInfo.RBSwapFormat = SrcInfo.Format) then + begin + Result := SwapChannels(Image, ChannelRed, ChannelBlue); + Image.Format := SrcInfo.RBSwapFormat; + Exit; + end; + + if (not SrcInfo.IsSpecial) and (not DstInfo.IsSpecial) then + begin + NumPixels := Width * Height; + NewSize := NumPixels * DstInfo.BytesPerPixel; + GetMem(NewData, NewSize); + FillChar(NewData^, NewSize, 0); + GetMem(NewPal, DstInfo.PaletteEntries * SizeOf(TColor32Rec)); + FillChar(NewPal^, DstInfo.PaletteEntries * SizeOf(TColor32Rec), 0); + + if SrcInfo.IsIndexed then + begin + // Source: indexed format + if DstInfo.IsIndexed then + IndexToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette, NewPal) + else if DstInfo.HasGrayChannel then + IndexToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette) + else if DstInfo.IsFloatingPoint then + IndexToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette) + else + IndexToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette); + end + else if SrcInfo.HasGrayChannel then + begin + // Source: grayscale format + if DstInfo.IsIndexed then + GrayToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal) + else if DstInfo.HasGrayChannel then + GrayToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo) + else if DstInfo.IsFloatingPoint then + GrayToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo) + else + GrayToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo); + end + else if SrcInfo.IsFloatingPoint then + begin + // Source: floating point format + if DstInfo.IsIndexed then + FloatToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal) + else if DstInfo.HasGrayChannel then + FloatToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo) + else if DstInfo.IsFloatingPoint then + FloatToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo) + else + FloatToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo); + end + else + begin + // Source: standard multi channel image + if DstInfo.IsIndexed then + ChannelToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal) + else if DstInfo.HasGrayChannel then + ChannelToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo) + else if DstInfo.IsFloatingPoint then + ChannelToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo) + else + ChannelToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo); + end; + + FreeMemNil(Bits); + FreeMemNil(Palette); + Format := DestFormat; + Bits := NewData; + Size := NewSize; + Palette := NewPal; + end + else + ConvertSpecial(Image, SrcInfo, DstInfo); + + Assert(SrcInfo.Format <> Image.Format); + + Result := True; + except + raise UpdateExceptMessage(GetExceptObject, SErrorConvertImage, [GetFormatName(DestFormat), ImageToStr(Image)]); + end; +end; + +function FlipImage(var Image: TImageData): Boolean; +var + P1, P2, Buff: Pointer; + WidthBytes, I: LongInt; + OldFmt: TImageFormat; +begin + Result := False; + OldFmt := Image.Format; + if TestImage(Image) then + with Image do + try + if ImageFormatInfos[OldFmt].IsSpecial then + ConvertImage(Image, ifDefault); + + WidthBytes := Width * ImageFormatInfos[Format].BytesPerPixel; + GetMem(Buff, WidthBytes); + try + // Swap all scanlines of image + for I := 0 to Height div 2 - 1 do + begin + P1 := @PByteArray(Bits)[I * WidthBytes]; + P2 := @PByteArray(Bits)[(Height - I - 1) * WidthBytes]; + Move(P1^, Buff^, WidthBytes); + Move(P2^, P1^, WidthBytes); + Move(Buff^, P2^, WidthBytes); + end; + finally + FreeMemNil(Buff); + end; + + if OldFmt <> Format then + ConvertImage(Image, OldFmt); + + Result := True; + except + RaiseImaging(SErrorFlipImage, [ImageToStr(Image)]); + end; +end; + +function MirrorImage(var Image: TImageData): Boolean; +var + Scanline: PByte; + Buff: TColorFPRec; + Bpp, Y, X, WidthDiv2, WidthBytes, XLeft, XRight: LongInt; + OldFmt: TImageFormat; +begin + Result := False; + OldFmt := Image.Format; + if TestImage(Image) then + with Image do + try + if ImageFormatInfos[OldFmt].IsSpecial then + ConvertImage(Image, ifDefault); + + Bpp := ImageFormatInfos[Format].BytesPerPixel; + WidthDiv2 := Width div 2; + WidthBytes := Width * Bpp; + // Mirror all pixels on each scanline of image + for Y := 0 to Height - 1 do + begin + Scanline := @PByteArray(Bits)[Y * WidthBytes]; + XLeft := 0; + XRight := (Width - 1) * Bpp; + for X := 0 to WidthDiv2 - 1 do + begin + CopyPixel(@PByteArray(Scanline)[XLeft], @Buff, Bpp); + CopyPixel(@PByteArray(Scanline)[XRight], + @PByteArray(Scanline)[XLeft], Bpp); + CopyPixel(@Buff, @PByteArray(Scanline)[XRight], Bpp); + Inc(XLeft, Bpp); + Dec(XRight, Bpp); + end; + end; + + if OldFmt <> Format then + ConvertImage(Image, OldFmt); + + Result := True; + except + RaiseImaging(SErrorMirrorImage, [ImageToStr(Image)]); + end; +end; + +function ResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt; + Filter: TResizeFilter): Boolean; +var + WorkImage: TImageData; +begin + Assert((NewWidth > 0) and (NewHeight > 0), 'New width or height is zero.'); + Result := False; + if TestImage(Image) and ((Image.Width <> NewWidth) or (Image.Height <> NewHeight)) then + try + InitImage(WorkImage); + // Create new image with desired dimensions + NewImage(NewWidth, NewHeight, Image.Format, WorkImage); + // Stretch pixels from old image to new one + StretchRect(Image, 0, 0, Image.Width, Image.Height, + WorkImage, 0, 0, WorkImage.Width, WorkImage.Height, Filter); + // Free old image and assign new image to it + FreeMemNil(Image.Bits); + if Image.Palette <> nil then + begin + FreeMem(WorkImage.Palette); + WorkImage.Palette := Image.Palette; + end; + Image := WorkImage; + Result := True; + except + raise UpdateExceptMessage(GetExceptObject, SErrorResizeImage, [ImageToStr(Image)]); + end; +end; + +function SwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean; +var + I, NumPixels: LongInt; + Info: PImageFormatInfo; + Swap, Alpha: Word; + Data: PByte; + Pix64: TColor64Rec; + PixF: TColorFPRec; + SwapF: Single; +begin + Assert((SrcChannel in [0..3]) and (DstChannel in [0..3])); + Result := False; + if TestImage(Image) and (SrcChannel <> DstChannel) then + with Image do + try + NumPixels := Width * Height; + Info := ImageFormatInfos[Format]; + Data := Bits; + + if (Info.Format = ifR8G8B8) or ((Info.Format = ifA8R8G8B8) and + (SrcChannel <> ChannelAlpha) and (DstChannel <> ChannelAlpha)) then + begin + // Swap channels of most common formats R8G8B8 and A8R8G8B8 (no alpha) + for I := 0 to NumPixels - 1 do + with PColor24Rec(Data)^ do + begin + Swap := Channels[SrcChannel]; + Channels[SrcChannel] := Channels[DstChannel]; + Channels[DstChannel] := Swap; + Inc(Data, Info.BytesPerPixel); + end; + end + else if Info.IsIndexed then + begin + // Swap palette channels of indexed images + SwapChannelsOfPalette(Palette, Info.PaletteEntries, SrcChannel, DstChannel) + end + else if Info.IsFloatingPoint then + begin + // Swap channels of floating point images + for I := 0 to NumPixels - 1 do + begin + FloatGetSrcPixel(Data, Info, PixF); + with PixF do + begin + SwapF := Channels[SrcChannel]; + Channels[SrcChannel] := Channels[DstChannel]; + Channels[DstChannel] := SwapF; + end; + FloatSetDstPixel(Data, Info, PixF); + Inc(Data, Info.BytesPerPixel); + end; + end + else if Info.IsSpecial then + begin + // Swap channels of special format images + ConvertImage(Image, ifDefault); + SwapChannels(Image, SrcChannel, DstChannel); + ConvertImage(Image, Info.Format); + end + else if Info.HasGrayChannel and Info.HasAlphaChannel and + ((SrcChannel = ChannelAlpha) or (DstChannel = ChannelAlpha)) then + begin + for I := 0 to NumPixels - 1 do + begin + // If we have grayscale image with alpha and alpha is channel + // to be swapped, we swap it. No other alternative for gray images, + // just alpha and something + GrayGetSrcPixel(Data, Info, Pix64, Alpha); + Swap := Alpha; + Alpha := Pix64.A; + Pix64.A := Swap; + GraySetDstPixel(Data, Info, Pix64, Alpha); + Inc(Data, Info.BytesPerPixel); + end; + end + else + begin + // Then do general swap on other channel image formats + for I := 0 to NumPixels - 1 do + begin + ChannelGetSrcPixel(Data, Info, Pix64); + with Pix64 do + begin + Swap := Channels[SrcChannel]; + Channels[SrcChannel] := Channels[DstChannel]; + Channels[DstChannel] := Swap; + end; + ChannelSetDstPixel(Data, Info, Pix64); + Inc(Data, Info.BytesPerPixel); + end; + end; + + Result := True; + except + RaiseImaging(SErrorSwapImage, [ImageToStr(Image)]); + end; +end; + +function ReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; +var + TmpInfo: TImageFormatInfo; + Data, Index: PWord; + I, NumPixels: LongInt; + Pal: PPalette32; + Col:PColor32Rec; + OldFmt: TImageFormat; +begin + Result := False; + if TestImage(Image) then + with Image do + try + // First create temp image info and allocate output bits and palette + MaxColors := ClampInt(MaxColors, 2, High(Word)); + OldFmt := Format; + FillChar(TmpInfo, SizeOf(TmpInfo), 0); + TmpInfo.PaletteEntries := MaxColors; + TmpInfo.BytesPerPixel := 2; + NumPixels := Width * Height; + GetMem(Data, NumPixels * TmpInfo.BytesPerPixel); + GetMem(Pal, MaxColors * SizeOf(TColor32Rec)); + ConvertImage(Image, ifA8R8G8B8); + // We use median cut algorithm to create reduced palette and to + // fill Data with indices to this palette + ReduceColorsMedianCut(NumPixels, Bits, PByte(Data), + ImageFormatInfos[Format], @TmpInfo, MaxColors, ColorReductionMask, Pal); + Col := Bits; + Index := Data; + // Then we write reduced colors to the input image + for I := 0 to NumPixels - 1 do + begin + Col.Color := Pal[Index^].Color; + Inc(Col); + Inc(Index); + end; + FreeMemNil(Data); + FreeMemNil(Pal); + // And convert it to its original format + ConvertImage(Image, OldFmt); + Result := True; + except + RaiseImaging(SErrorReduceColors, [MaxColors, ImageToStr(Image)]); + end; +end; + +function GenerateMipMaps(const Image: TImageData; Levels: LongInt; + var MipMaps: TDynImageDataArray): Boolean; +var + Width, Height, I, Count: LongInt; + Info: TImageFormatInfo; + CompatibleCopy: TImageData; +begin + Result := False; + if TestImage(Image) then + try + Width := Image.Width; + Height := Image.Height; + // We compute number of possible mipmap levels and if + // the given levels are invalid or zero we use this value + Count := GetNumMipMapLevels(Width, Height); + if (Levels <= 0) or (Levels > Count) then + Levels := Count; + + // If we have special format image we create copy to allow pixel access. + // This is also done in FillMipMapLevel which is called for each level + // but then the main big image would be converted to compatible + // for every level. + GetImageFormatInfo(Image.Format, Info); + if Info.IsSpecial then + begin + InitImage(CompatibleCopy); + CloneImage(Image, CompatibleCopy); + ConvertImage(CompatibleCopy, ifDefault); + end + else + CompatibleCopy := Image; + + FreeImagesInArray(MipMaps); + SetLength(MipMaps, Levels); + CloneImage(Image, MipMaps[0]); + + for I := 1 to Levels - 1 do + begin + Width := Width shr 1; + Height := Height shr 1; + if Width < 1 then Width := 1; + if Height < 1 then Height := 1; + FillMipMapLevel(CompatibleCopy, Width, Height, MipMaps[I]); + end; + + if CompatibleCopy.Format <> MipMaps[0].Format then + begin + // Must convert smaller levels to proper format + for I := 1 to High(MipMaps) do + ConvertImage(MipMaps[I], MipMaps[0].Format); + FreeImage(CompatibleCopy); + end; + + Result := True; + except + RaiseImaging(SErrorGenerateMipMaps, [Levels, ImageToStr(Image)]); + end; +end; + +function MapImageToPalette(var Image: TImageData; Pal: PPalette32; + Entries: LongInt): Boolean; + + function FindNearestColor(Pal: PPalette32; Entries: LongInt; Col: TColor32Rec): LongInt; + var + I, MinDif, Dif: LongInt; + begin + Result := 0; + MinDif := 1020; + for I := 0 to Entries - 1 do + with Pal[I] do + begin + Dif := Abs(R - Col.R); + if Dif > MinDif then Continue; + Dif := Dif + Abs(G - Col.G); + if Dif > MinDif then Continue; + Dif := Dif + Abs(B - Col.B); + if Dif > MinDif then Continue; + Dif := Dif + Abs(A - Col.A); + if Dif < MinDif then + begin + MinDif := Dif; + Result := I; + end; + end; + end; + +var + I, MaxEntries: LongInt; + PIndex: PByte; + PColor: PColor32Rec; + CloneARGB: TImageData; + Info: PImageFormatInfo; +begin + Assert((Entries >= 2) and (Entries <= 256)); + Result := False; + + if TestImage(Image) then + try + // We create clone of source image in A8R8G8B8 and + // then recreate source image in ifIndex8 format + // with palette taken from Pal parameter + InitImage(CloneARGB); + CloneImage(Image, CloneARGB); + ConvertImage(CloneARGB, ifA8R8G8B8); + FreeImage(Image); + NewImage(CloneARGB.Width, CloneARGB.Height, ifIndex8, Image); + + Info := ImageFormatInfos[Image.Format]; + MaxEntries := Min(Info.PaletteEntries, Entries); + Move(Pal^, Image.Palette^, MaxEntries * SizeOf(TColor32Rec)); + PIndex := Image.Bits; + PColor := CloneARGB.Bits; + + // For every pixel of ARGB clone we find closest color in + // given palette and assign its index to resulting image's pixel + // procedure used here is very slow but simple and memory usage friendly + // (contrary to other methods) + for I := 0 to Image.Width * Image.Height - 1 do + begin + PIndex^ := Byte(FindNearestColor(Image.Palette, MaxEntries, PColor^)); + Inc(PIndex); + Inc(PColor); + end; + + FreeImage(CloneARGB); + Result := True; + except + raise UpdateExceptMessage(GetExceptObject, SErrorMapImage, [ImageToStr(Image)]); + end; +end; + +function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray; + ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt; + PreserveSize: Boolean; Fill: Pointer): Boolean; +var + X, Y, XTrunc, YTrunc: LongInt; + NotOnEdge: Boolean; + Info: PImageFormatInfo; + OldFmt: TImageFormat; + +begin + Assert((ChunkWidth > 0) and (ChunkHeight > 0)); + Result := False; + OldFmt := Image.Format; + FreeImagesInArray(Chunks); + + if TestImage(Image) then + try + Info := ImageFormatInfos[Image.Format]; + if Info.IsSpecial then + ConvertImage(Image, ifDefault); + + // We compute make sure that chunks are not larger than source image or negative + ChunkWidth := ClampInt(ChunkWidth, 0, Image.Width); + ChunkHeight := ClampInt(ChunkHeight, 0, Image.Height); + // Number of chunks along X and Y axes is computed + XChunks := Ceil(Image.Width / ChunkWidth); + YChunks := Ceil(Image.Height / ChunkHeight); + SetLength(Chunks, XChunks * YChunks); + + // For every chunk we create new image and copy a portion of + // the source image to it. If chunk is on the edge of the source image + // we fill empty space with Fill pixel data if PreserveSize is set or + // make the chunk smaller if it is not set + for Y := 0 to YChunks - 1 do + for X := 0 to XChunks - 1 do + begin + // Determine if current chunk is on the edge of original image + NotOnEdge := ((X < XChunks - 1) and (Y < YChunks - 1)) or + ((Image.Width mod ChunkWidth = 0) and (Image.Height mod ChunkHeight = 0)); + + if PreserveSize or NotOnEdge then + begin + // We should preserve chunk sizes or we are somewhere inside original image + NewImage(ChunkWidth, ChunkHeight, Image.Format, Chunks[Y * XChunks + X]); + if (not NotOnEdge) and (Fill <> nil) then + FillRect(Chunks[Y * XChunks + X], 0, 0, ChunkWidth, ChunkHeight, Fill); + CopyRect(Image, X * ChunkWidth, Y * ChunkHeight, ChunkWidth, ChunkHeight, + Chunks[Y * XChunks + X], 0, 0); + end + else + begin + // Create smaller edge chunk + XTrunc := Image.Width - X * ChunkWidth; + YTrunc := Image.Height - Y * ChunkHeight; + NewImage(XTrunc, YTrunc, Image.Format, Chunks[Y * XChunks + X]); + CopyRect(Image, X * ChunkWidth, Y * ChunkHeight, XTrunc, YTrunc, + Chunks[Y * XChunks + X], 0, 0); + end; + + // If source image is in indexed format we copy its palette to chunk + if Info.IsIndexed then + begin + Move(Image.Palette^, Chunks[Y * XChunks + X].Palette^, + Info.PaletteEntries * SizeOf(TColor32Rec)); + end; + end; + + if OldFmt <> Image.Format then + begin + ConvertImage(Image, OldFmt); + for X := 0 to Length(Chunks) - 1 do + ConvertImage(Chunks[X], OldFmt); + end; + + Result := True; + except + raise UpdateExceptMessage(GetExceptObject, SErrorSplitImage, + [ImageToStr(Image), ChunkWidth, ChunkHeight]); + end; +end; + +function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32; + MaxColors: LongInt; ConvertImages: Boolean): Boolean; +var + I: Integer; + SrcInfo, DstInfo: PImageFormatInfo; + Target, TempImage: TImageData; + DstFormat: TImageFormat; +begin + Assert((Pal <> nil) and (MaxColors > 0)); + Result := False; + InitImage(TempImage); + + if TestImagesInArray(Images) then + try + // Null the color histogram + ReduceColorsMedianCut(0, nil, nil, nil, nil, 0, 0, nil, [raCreateHistogram]); + for I := 0 to Length(Images) - 1 do + begin + SrcInfo := ImageFormatInfos[Images[I].Format]; + if SrcInfo.IsIndexed or SrcInfo.IsSpecial then + begin + // create temp image in supported format for updating histogram + CloneImage(Images[I], TempImage); + ConvertImage(TempImage, ifA8R8G8B8); + SrcInfo := ImageFormatInfos[TempImage.Format]; + end + else + TempImage := Images[I]; + + // Update histogram with colors of each input image + ReduceColorsMedianCut(TempImage.Width * TempImage.Height, TempImage.Bits, + nil, SrcInfo, nil, MaxColors, ColorReductionMask, nil, [raUpdateHistogram]); + + if Images[I].Bits <> TempImage.Bits then + FreeImage(TempImage); + end; + // Construct reduced color map from the histogram + ReduceColorsMedianCut(0, nil, nil, nil, nil, MaxColors, ColorReductionMask, + Pal, [raMakeColorMap]); + + if ConvertImages then + begin + DstFormat := ifIndex8; + DstInfo := ImageFormatInfos[DstFormat]; + MaxColors := Min(DstInfo.PaletteEntries, MaxColors); + + for I := 0 to Length(Images) - 1 do + begin + SrcInfo := ImageFormatInfos[Images[I].Format]; + if SrcInfo.IsIndexed or SrcInfo.IsSpecial then + begin + // If source image is in format not supported by ReduceColorsMedianCut + // we convert it + ConvertImage(Images[I], ifA8R8G8B8); + SrcInfo := ImageFormatInfos[Images[I].Format]; + end; + + InitImage(Target); + NewImage(Images[I].Width, Images[I].Height, DstFormat, Target); + // We map each input image to reduced palette and replace + // image in array with mapped image + ReduceColorsMedianCut(Images[I].Width * Images[I].Height, Images[I].Bits, + Target.Bits, SrcInfo, DstInfo, MaxColors, 0, nil, [raMapImage]); + Move(Pal^, Target.Palette^, MaxColors * SizeOf(TColor32Rec)); + + FreeImage(Images[I]); + Images[I] := Target; + end; + end; + Result := True; + except + RaiseImaging(SErrorMakePaletteForImages, [MaxColors, Length(Images)]); + end; +end; + +procedure RotateImage(var Image: TImageData; Angle: Single); +var + OldFmt: TImageFormat; + + procedure XShear(var Src, Dst: TImageData; Row, Offset, Weight, Bpp: Integer); var I, J, XPos: Integer; PixSrc, PixLeft, PixOldLeft: TColor32Rec; @@ -1886,7 +2022,7 @@ var if (XPos >= 0) and (XPos < Dst.Width) then begin for J := 0 to Bpp - 1 do - PixSrc.Channels[J] := PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]); + PixSrc.Channels[J] := ClampToByte(PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J])); CopyPixel(@PixSrc, @LineDst[XPos * Bpp], Bpp); end; PixOldLeft := PixLeft; @@ -1917,7 +2053,7 @@ var if (YPos >= 0) and (YPos < Dst.Height) then begin for J := 0 to Bpp - 1 do - PixSrc.Channels[J] := PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]); + PixSrc.Channels[J] := ClampToByte(PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J])); CopyPixel(@PixSrc, @PByteArray(Dst.Bits)[(YPos * Dst.Width + Col) * Bpp], Bpp); end; PixOldLeft := PixLeft; @@ -1955,6 +2091,7 @@ var // 1st shear (horizontal) DstWidth := Trunc(SrcWidth + SrcHeight * Abs(AngleTan) + 0.5); DstHeight := SrcHeight; + InitImage(TempImage1); NewImage(DstWidth, DstHeight, TempFormat, TempImage1); for I := 0 to DstHeight - 1 do @@ -1966,9 +2103,10 @@ var XShear(Image, TempImage1, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp); end; - // 2nd shear (vertical) + // 2nd shear (vertical) FreeImage(Image); DstHeight := Trunc(SrcWidth * Abs(AngleSin) + SrcHeight * AngleCos + 0.5) + 1; + InitImage(TempImage2); NewImage(DstWidth, DstHeight, TempFormat, TempImage2); if AngleSin >= 0 then @@ -2002,1608 +2140,2282 @@ var if Image.Format <> SrcFmt then ConvertImage(Image, SrcFmt); end; - - procedure RotateMul90(var Image: TImageData; Angle: Integer); - var - RotImage: TImageData; - X, Y, BytesPerPixel: Integer; - RotPix, Pix: PByte; - begin + + procedure RotateMul90(var Image: TImageData; Angle: Integer); + var + RotImage: TImageData; + X, Y, BytesPerPixel: Integer; + RotPix, Pix: PByte; + begin InitImage(RotImage); - BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel; - - if ((Angle = 90) or (Angle = 270)) and (Image.Width <> Image.Height) then - NewImage(Image.Height, Image.Width, Image.Format, RotImage) - else - NewImage(Image.Width, Image.Height, Image.Format, RotImage); - - RotPix := RotImage.Bits; - case Angle of - 90: - begin - for Y := 0 to RotImage.Height - 1 do - begin - Pix := @PByteArray(Image.Bits)[(Image.Width - Y - 1) * BytesPerPixel]; - for X := 0 to RotImage.Width - 1 do - begin - CopyPixel(Pix, RotPix, BytesPerPixel); - Inc(RotPix, BytesPerPixel); - Inc(Pix, Image.Width * BytesPerPixel); - end; - end; - end; - 180: - begin - Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + - (Image.Width - 1)) * BytesPerPixel]; - for Y := 0 to RotImage.Height - 1 do - for X := 0 to RotImage.Width - 1 do - begin - CopyPixel(Pix, RotPix, BytesPerPixel); - Inc(RotPix, BytesPerPixel); - Dec(Pix, BytesPerPixel); - end; - end; - 270: - begin - for Y := 0 to RotImage.Height - 1 do - begin - Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + Y) * BytesPerPixel]; - for X := 0 to RotImage.Width - 1 do - begin - CopyPixel(Pix, RotPix, BytesPerPixel); - Inc(RotPix, BytesPerPixel); - Dec(Pix, Image.Width * BytesPerPixel); - end; - end; - end; - end; - - FreeMemNil(Image.Bits); - RotImage.Palette := Image.Palette; + BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel; + + if ((Angle = 90) or (Angle = 270)) and (Image.Width <> Image.Height) then + NewImage(Image.Height, Image.Width, Image.Format, RotImage) + else + NewImage(Image.Width, Image.Height, Image.Format, RotImage); + + RotPix := RotImage.Bits; + case Angle of + 90: + begin + for Y := 0 to RotImage.Height - 1 do + begin + Pix := @PByteArray(Image.Bits)[(Image.Width - Y - 1) * BytesPerPixel]; + for X := 0 to RotImage.Width - 1 do + begin + CopyPixel(Pix, RotPix, BytesPerPixel); + Inc(RotPix, BytesPerPixel); + Inc(Pix, Image.Width * BytesPerPixel); + end; + end; + end; + 180: + begin + Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + + (Image.Width - 1)) * BytesPerPixel]; + for Y := 0 to RotImage.Height - 1 do + for X := 0 to RotImage.Width - 1 do + begin + CopyPixel(Pix, RotPix, BytesPerPixel); + Inc(RotPix, BytesPerPixel); + Dec(Pix, BytesPerPixel); + end; + end; + 270: + begin + for Y := 0 to RotImage.Height - 1 do + begin + Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + Y) * BytesPerPixel]; + for X := 0 to RotImage.Width - 1 do + begin + CopyPixel(Pix, RotPix, BytesPerPixel); + Inc(RotPix, BytesPerPixel); + Dec(Pix, Image.Width * BytesPerPixel); + end; + end; + end; + end; + + FreeMemNil(Image.Bits); + RotImage.Palette := Image.Palette; Image := RotImage; - end; + end; -begin - Result := False; - - if TestImage(Image) then - try - while Angle >= 360 do - Angle := Angle - 360; - while Angle < 0 do - Angle := Angle + 360; +begin + if TestImage(Image) then + try + while Angle >= 360 do + Angle := Angle - 360; + while Angle < 0 do + Angle := Angle + 360; - if (Angle = 0) or (Abs(Angle) = 360) then - begin - Result := True; - Exit; - end; - - OldFmt := Image.Format; - if ImageFormatInfos[Image.Format].IsSpecial then - ConvertImage(Image, ifDefault); - - if (Angle > 45) and (Angle <= 135) then - begin - RotateMul90(Image, 90); - Angle := Angle - 90; - end - else if (Angle > 135) and (Angle <= 225) then - begin - RotateMul90(Image, 180); - Angle := Angle - 180; - end - else if (Angle > 225) and (Angle <= 315) then - begin - RotateMul90(Image, 270); - Angle := Angle - 270; - end; + if (Angle = 0) or (Abs(Angle) = 360) then + Exit; + + OldFmt := Image.Format; + if ImageFormatInfos[Image.Format].IsSpecial then + ConvertImage(Image, ifDefault); + + if (Angle > 45) and (Angle <= 135) then + begin + RotateMul90(Image, 90); + Angle := Angle - 90; + end + else if (Angle > 135) and (Angle <= 225) then + begin + RotateMul90(Image, 180); + Angle := Angle - 180; + end + else if (Angle > 225) and (Angle <= 315) then + begin + RotateMul90(Image, 270); + Angle := Angle - 270; + end; if Angle <> 0 then Rotate45(Image, Angle); - - if OldFmt <> Image.Format then - ConvertImage(Image, OldFmt); - - Result := True; - except - RaiseImaging(SErrorRotateImage, [ImageToStr(Image), Angle]); - end; -end; - -{ Drawing/Pixel functions } - -function CopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt; - var DstImage: TImageData; DstX, DstY: LongInt): Boolean; -var - Info: PImageFormatInfo; - I, SrcWidthBytes, DstWidthBytes, MoveBytes: LongInt; - SrcPointer, DstPointer: PByte; - WorkImage: TImageData; - OldFormat: TImageFormat; -begin - Result := False; - OldFormat := ifUnknown; - if TestImage(SrcImage) and TestImage(DstImage) then - try - // Make sure we are still copying image to image, not invalid pointer to protected memory - ClipCopyBounds(SrcX, SrcY, Width, Height, DstX, DstY, SrcImage.Width, SrcImage.Height, - Rect(0, 0, DstImage.Width, DstImage.Height)); - - if (Width > 0) and (Height > 0) then - begin - Info := ImageFormatInfos[DstImage.Format]; - if Info.IsSpecial then - begin - // If dest image is in special format we convert it to default - OldFormat := Info.Format; - ConvertImage(DstImage, ifDefault); - Info := ImageFormatInfos[DstImage.Format]; - end; - if SrcImage.Format <> DstImage.Format then - begin - // If images are in different format source is converted to dest's format - InitImage(WorkImage); - CloneImage(SrcImage, WorkImage); - ConvertImage(WorkImage, DstImage.Format); - end - else - WorkImage := SrcImage; - - MoveBytes := Width * Info.BytesPerPixel; - DstWidthBytes := DstImage.Width * Info.BytesPerPixel; - DstPointer := @PByteArray(DstImage.Bits)[DstY * DstWidthBytes + - DstX * Info.BytesPerPixel]; - SrcWidthBytes := WorkImage.Width * Info.BytesPerPixel; - SrcPointer := @PByteArray(WorkImage.Bits)[SrcY * SrcWidthBytes + - SrcX * Info.BytesPerPixel]; - - for I := 0 to Height - 1 do - begin - Move(SrcPointer^, DstPointer^, MoveBytes); - Inc(SrcPointer, SrcWidthBytes); - Inc(DstPointer, DstWidthBytes); - end; - // If dest image was in special format we convert it back - if OldFormat <> ifUnknown then - ConvertImage(DstImage, OldFormat); - // Working image must be freed if it is not the same as source image - if WorkImage.Bits <> SrcImage.Bits then - FreeImage(WorkImage); - - Result := True; - end; - except - RaiseImaging(SErrorCopyRect, [ImageToStr(SrcImage), ImageToStr(DstImage)]); - end; -end; - -function FillRect(var Image: TImageData; X, Y, Width, Height: LongInt; - FillColor: Pointer): Boolean; -var - Info: PImageFormatInfo; - I, J, ImageWidthBytes, RectWidthBytes, Bpp: Longint; - LinePointer, PixPointer: PByte; - OldFmt: TImageFormat; -begin - Result := False; - if TestImage(Image) then - try - ClipRectBounds(X, Y, Width, Height, Rect(0, 0, Image.Width, Image.Height)); - - if (Width > 0) and (Height > 0) then - begin - OldFmt := Image.Format; - if ImageFormatInfos[OldFmt].IsSpecial then - ConvertImage(Image, ifDefault); - - Info := ImageFormatInfos[Image.Format]; - Bpp := Info.BytesPerPixel; - ImageWidthBytes := Image.Width * Bpp; - RectWidthBytes := Width * Bpp; - LinePointer := @PByteArray(Image.Bits)[Y * ImageWidthBytes + X * Bpp]; - - for I := 0 to Height - 1 do - begin - case Bpp of - 1: FillMemoryByte(LinePointer, RectWidthBytes, PByte(FillColor)^); - 2: FillMemoryWord(LinePointer, RectWidthBytes, PWord(FillColor)^); - 4: FillMemoryLongWord(LinePointer, RectWidthBytes, PLongWord(FillColor)^); - else - PixPointer := LinePointer; - for J := 0 to Width - 1 do - begin - CopyPixel(FillColor, PixPointer, Bpp); - Inc(PixPointer, Bpp); - end; - end; - Inc(LinePointer, ImageWidthBytes); - end; - - if OldFmt <> Image.Format then - ConvertImage(Image, OldFmt); - end; - - Result := True; - except - RaiseImaging(SErrorFillRect, [X, Y, Width, Height, ImageToStr(Image)]); - end; -end; - -function ReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt; - OldColor, NewColor: Pointer): Boolean; -var - Info: PImageFormatInfo; - I, J, WidthBytes, Bpp: Longint; - LinePointer, PixPointer: PByte; - OldFmt: TImageFormat; -begin - Assert((OldColor <> nil) and (NewColor <> nil)); - Result := False; - if TestImage(Image) then - try - ClipRectBounds(X, Y, Width, Height, Rect(0, 0, Image.Width, Image.Height)); - - if (Width > 0) and (Height > 0) then - begin - OldFmt := Image.Format; - if ImageFormatInfos[OldFmt].IsSpecial then - ConvertImage(Image, ifDefault); - - Info := ImageFormatInfos[Image.Format]; - Bpp := Info.BytesPerPixel; - WidthBytes := Image.Width * Bpp; - LinePointer := @PByteArray(Image.Bits)[Y * WidthBytes + X * Bpp]; - - for I := 0 to Height - 1 do - begin - PixPointer := LinePointer; - for J := 0 to Width - 1 do - begin - if ComparePixels(PixPointer, OldColor, Bpp) then - CopyPixel(NewColor, PixPointer, Bpp); - Inc(PixPointer, Bpp); - end; - Inc(LinePointer, WidthBytes); - end; - - if OldFmt <> Image.Format then - ConvertImage(Image, OldFmt); - end; - - Result := True; - except - RaiseImaging(SErrorReplaceColor, [X, Y, Width, Height, ImageToStr(Image)]); - end; -end; - -function StretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, - SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, - DstHeight: LongInt; Filter: TResizeFilter): Boolean; -var - Info: PImageFormatInfo; - WorkImage: TImageData; - OldFormat: TImageFormat; -begin - Result := False; - OldFormat := ifUnknown; - if TestImage(SrcImage) and TestImage(DstImage) then - try - // Make sure we are still copying image to image, not invalid pointer to protected memory - ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY, DstWidth, DstHeight, - SrcImage.Width, SrcImage.Height, Rect(0, 0, DstImage.Width, DstImage.Height)); - - if (SrcWidth = DstWidth) and (SrcHeight = DstHeight) then - begin - // If source and dest rectangles have the same size call CopyRect - Result := CopyRect(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY); - end - else if (SrcWidth > 0) and (SrcHeight > 0) and (DstWidth > 0) and (DstHeight > 0) then - begin - // If source and dest rectangles don't have the same size we do stretch - Info := ImageFormatInfos[DstImage.Format]; - - if Info.IsSpecial then - begin - // If dest image is in special format we convert it to default - OldFormat := Info.Format; - ConvertImage(DstImage, ifDefault); - Info := ImageFormatInfos[DstImage.Format]; - end; - - if SrcImage.Format <> DstImage.Format then - begin - // If images are in different format source is converted to dest's format - InitImage(WorkImage); - CloneImage(SrcImage, WorkImage); - ConvertImage(WorkImage, DstImage.Format); - end - else - WorkImage := SrcImage; - - // Only pixel resize is supported for indexed images - if Info.IsIndexed then - Filter := rfNearest; - - case Filter of - rfNearest: StretchNearest(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight, - DstImage, DstX, DstY, DstWidth, DstHeight); - rfBilinear: StretchResample(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight, - DstImage, DstX, DstY, DstWidth, DstHeight, sfLinear); - rfBicubic: StretchResample(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight, - DstImage, DstX, DstY, DstWidth, DstHeight, sfCatmullRom); - end; - - // If dest image was in special format we convert it back - if OldFormat <> ifUnknown then - ConvertImage(DstImage, OldFormat); - // Working image must be freed if it is not the same as source image - if WorkImage.Bits <> SrcImage.Bits then - FreeImage(WorkImage); - - Result := True; - end; - except - RaiseImaging(SErrorStretchRect, [ImageToStr(SrcImage), ImageToStr(DstImage)]); - end; -end; - -procedure GetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); -var - BytesPerPixel: LongInt; -begin - Assert(Pixel <> nil); - BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel; - CopyPixel(@PByteArray(Image.Bits)[(Y * Image.Width + X) * BytesPerPixel], - Pixel, BytesPerPixel); -end; - -procedure SetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); -var - BytesPerPixel: LongInt; -begin - Assert(Pixel <> nil); - BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel; - CopyPixel(Pixel, @PByteArray(Image.Bits)[(Y * Image.Width + X) * BytesPerPixel], - BytesPerPixel); -end; - -function GetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; -var - Info: PImageFormatInfo; - Data: PByte; -begin - Info := ImageFormatInfos[Image.Format]; - Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel]; - Result := GetPixel32Generic(Data, Info, Image.Palette); -end; - -procedure SetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); -var - Info: PImageFormatInfo; - Data: PByte; -begin - Info := ImageFormatInfos[Image.Format]; - Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel]; - SetPixel32Generic(Data, Info, Image.Palette, Color); -end; - -function GetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; -var - Info: PImageFormatInfo; - Data: PByte; -begin - Info := ImageFormatInfos[Image.Format]; - Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel]; - Result := GetPixelFPGeneric(Data, Info, Image.Palette); -end; - -procedure SetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); -var - Info: PImageFormatInfo; - Data: PByte; -begin - Info := ImageFormatInfos[Image.Format]; - Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel]; - SetPixelFPGeneric(Data, Info, Image.Palette, Color); -end; - -{ Palette Functions } - -procedure NewPalette(Entries: LongInt; var Pal: PPalette32); -begin - Assert((Entries > 2) and (Entries <= 65535)); - try - GetMem(Pal, Entries * SizeOf(TColor32Rec)); - FillChar(Pal^, Entries * SizeOf(TColor32Rec), $FF); - except - RaiseImaging(SErrorNewPalette, [Entries]); - end; -end; - -procedure FreePalette(var Pal: PPalette32); -begin - try - FreeMemNil(Pal); - except - RaiseImaging(SErrorFreePalette, [Pal]); - end; -end; - -procedure CopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt); -begin - Assert((SrcPal <> nil) and (DstPal <> nil)); - Assert((SrcIdx >= 0) and (DstIdx >= 0) and (Count >= 0)); - try - Move(SrcPal[SrcIdx], DstPal[DstIdx], Count * SizeOf(TColor32Rec)); - except - RaiseImaging(SErrorCopyPalette, [Count, SrcPal, DstPal]); - end; -end; - -function FindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): - LongInt; -var - Col: TColor32Rec; - I, MinDif, Dif: LongInt; -begin - Assert(Pal <> nil); - Result := -1; - Col.Color := Color; - try - // First try to find exact match - for I := 0 to Entries - 1 do - with Pal[I] do - begin - if (A = Col.A) and (R = Col.R) and - (G = Col.G) and (B = Col.B) then - begin - Result := I; - Exit; - end; - end; - - // If exact match was not found, find nearest color - MinDif := 1020; - for I := 0 to Entries - 1 do - with Pal[I] do - begin - Dif := Abs(R - Col.R); - if Dif > MinDif then Continue; - Dif := Dif + Abs(G - Col.G); - if Dif > MinDif then Continue; - Dif := Dif + Abs(B - Col.B); - if Dif > MinDif then Continue; - Dif := Dif + Abs(A - Col.A); - if Dif < MinDif then - begin - MinDif := Dif; - Result := I; - end; - end; - except - RaiseImaging(SErrorFindColor, [Pal, Entries]); - end; -end; - -procedure FillGrayscalePalette(Pal: PPalette32; Entries: LongInt); -var - I: LongInt; -begin - Assert(Pal <> nil); - try - for I := 0 to Entries - 1 do - with Pal[I] do - begin - A := $FF; - R := Byte(I); - G := Byte(I); - B := Byte(I); - end; - except - RaiseImaging(SErrorGrayscalePalette, [Pal, Entries]); - end; -end; - -procedure FillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits, - BBits: Byte; Alpha: Byte = $FF); -var - I, TotalBits, MaxEntries: LongInt; -begin - Assert(Pal <> nil); - TotalBits := RBits + GBits + BBits; - MaxEntries := Min(Pow2Int(TotalBits), Entries); - FillChar(Pal^, Entries * SizeOf(TColor32Rec), 0); - try - for I := 0 to MaxEntries - 1 do - with Pal[I] do - begin - A := Alpha; - if RBits > 0 then - R := ((I shr Max(0, GBits + BBits - 1)) and (1 shl RBits - 1)) * 255 div (1 shl RBits - 1); - if GBits > 0 then - G := ((I shr Max(0, BBits - 1)) and (1 shl GBits - 1)) * 255 div (1 shl GBits - 1); - if BBits > 0 then - B := ((I shr 0) and (1 shl BBits - 1)) * 255 div (1 shl BBits - 1); - end; - except - RaiseImaging(SErrorCustomPalette, [Pal, Entries]); - end; -end; - -procedure SwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel, - DstChannel: LongInt); -var - I: LongInt; - Swap: Byte; -begin - Assert(Pal <> nil); - Assert((SrcChannel in [0..3]) and (DstChannel in [0..3])); - try - for I := 0 to Entries - 1 do - with Pal[I] do - begin - Swap := Channels[SrcChannel]; - Channels[SrcChannel] := Channels[DstChannel]; - Channels[DstChannel] := Swap; - end; - except - RaiseImaging(SErrorSwapPalette, [Pal, Entries]); - end; -end; - -{ Options Functions } - -function SetOption(OptionId, Value: LongInt): Boolean; -begin - Result := False; - if (OptionId >= 0) and (OptionId < Length(Options)) and - (Options[OptionID] <> nil) then - begin - Options[OptionID]^ := CheckOptionValue(OptionId, Value); - Result := True; - end; -end; - -function GetOption(OptionId: LongInt): LongInt; -begin - Result := InvalidOption; - if (OptionId >= 0) and (OptionId < Length(Options)) and - (Options[OptionID] <> nil) then - begin - Result := Options[OptionID]^; - end; -end; - -function PushOptions: Boolean; -begin - Result := OptionStack.Push; -end; - -function PopOptions: Boolean; -begin - Result := OptionStack.Pop; -end; - -{ Image Format Functions } - -function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean; -begin - FillChar(Info, SizeOf(Info), 0); - if ImageFormatInfos[Format] <> nil then - begin - Info := ImageFormatInfos[Format]^; - Result := True; - end - else - Result := False; -end; - -function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; -begin - if ImageFormatInfos[Format] <> nil then - Result := ImageFormatInfos[Format].GetPixelsSize(Format, Width, Height) - else - Result := 0; -end; - -{ IO Functions } - -procedure SetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc: - TOpenWriteProc; - CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc; TellProc: - TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); -begin - FileIO.OpenRead := OpenReadProc; - FileIO.OpenWrite := OpenWriteProc; - FileIO.Close := CloseProc; - FileIO.Eof := EofProc; - FileIO.Seek := SeekProc; - FileIO.Tell := TellProc; - FileIO.Read := ReadProc; - FileIO.Write := WriteProc; -end; - -procedure ResetFileIO; -begin - FileIO := OriginalFileIO; -end; - - -{ ------------------------------------------------------------------------ - Other Imaging Stuff - ------------------------------------------------------------------------} - -function GetFormatName(Format: TImageFormat): string; -begin - if ImageFormatInfos[Format] <> nil then - Result := ImageFormatInfos[Format].Name - else - Result := SUnknownFormat; -end; - -function ImageToStr(const Image: TImageData): string; -var - ImgSize: Integer; -begin - if TestImage(Image) then - with Image do - begin - ImgSize := Size; - if ImgSize > 8192 then - ImgSize := ImgSize div 1024; - Result := SysUtils.Format(SImageInfo, [@Image, Width, Height, - GetFormatName(Format), ImgSize + 0.0, Iff(ImgSize = Size, 'B', 'KiB'), Bits, - Palette]); - end - else - Result := SysUtils.Format(SImageInfoInvalid, [@Image]); -end; - -function GetVersionStr: string; -begin - Result := Format('%.1d.%.2d.%.1d', [ImagingVersionMajor, - ImagingVersionMinor, ImagingVersionPatch]); -end; - -function IffFormat(Condition: Boolean; const TruePart, FalsePart: TImageFormat): TImageFormat; -begin - if Condition then - Result := TruePart - else - Result := FalsePart; -end; - -procedure RegisterImageFileFormat(AClass: TImageFileFormatClass); -begin - Assert(AClass <> nil); - if ImageFileFormats = nil then - ImageFileFormats := TList.Create; - if ImageFileFormats <> nil then - ImageFileFormats.Add(AClass.Create); -end; - -function RegisterOption(OptionId: LongInt; Variable: PLongInt): Boolean; -begin - Result := False; - if Options = nil then - InitOptions; - - Assert(Variable <> nil); - - if OptionId >= Length(Options) then - SetLength(Options, OptionId + InitialOptions); - if (OptionId >= 0) and (OptionId < Length(Options)) {and (Options[OptionId] = nil) - must be able to override existing } then - begin - Options[OptionId] := Variable; - Result := True; - end; -end; - -function FindImageFileFormatByExt(const Ext: string): TImageFileFormat; -var - I: LongInt; -begin - Result := nil; - for I := ImageFileFormats.Count - 1 downto 0 do - if TImageFileFormat(ImageFileFormats[I]).Extensions.IndexOf(Ext) >= 0 then - begin - Result := TImageFileFormat(ImageFileFormats[I]); - Exit; - end; -end; - -function FindImageFileFormatByName(const FileName: string): TImageFileFormat; -var - I: LongInt; -begin - Result := nil; - for I := ImageFileFormats.Count - 1 downto 0 do - if TImageFileFormat(ImageFileFormats[I]).TestFileName(FileName) then - begin - Result := TImageFileFormat(ImageFileFormats[I]); - Exit; - end; -end; - -function FindImageFileFormatByClass(AClass: TImageFileFormatClass): TImageFileFormat; -var - I: LongInt; -begin - Result := nil; - for I := 0 to ImageFileFormats.Count - 1 do - if TImageFileFormat(ImageFileFormats[I]) is AClass then - begin - Result := TObject(ImageFileFormats[I]) as TImageFileFormat; - Break; - end; -end; - -function GetFileFormatCount: LongInt; -begin - Result := ImageFileFormats.Count; -end; - -function GetFileFormatAtIndex(Index: LongInt): TImageFileFormat; -begin - if (Index >= 0) and (Index < ImageFileFormats.Count) then - Result := TImageFileFormat(ImageFileFormats[Index]) - else - Result := nil; -end; - -function GetImageFileFormatsFilter(OpenFileFilter: Boolean): string; -var - I, J, Count: LongInt; - Descriptions: string; - Filters, CurFilter: string; - FileFormat: TImageFileFormat; -begin - Descriptions := ''; - Filters := ''; - Count := 0; - - for I := 0 to ImageFileFormats.Count - 1 do - begin - FileFormat := TObject(ImageFileFormats[I]) as TImageFileFormat; - - // If we are creating filter for save dialog and this format cannot save - // files the we skip it - if not OpenFileFilter and not FileFormat.CanSave then - Continue; - - CurFilter := ''; - for J := 0 to FileFormat.Masks.Count - 1 do - begin - CurFilter := CurFilter + FileFormat.Masks[J]; - if J < FileFormat.Masks.Count - 1 then - CurFilter := CurFilter + ';'; - end; - - FmtStr(Descriptions, '%s%s (%s)|%2:s', [Descriptions, FileFormat.Name, CurFilter]); - if Filters <> '' then - FmtStr(Filters, '%s;%s', [Filters, CurFilter]) - else - Filters := CurFilter; - - if I < ImageFileFormats.Count - 1 then - Descriptions := Descriptions + '|'; - - Inc(Count); - end; - - if (Count > 1) and OpenFileFilter then - FmtStr(Descriptions, '%s (%s)|%1:s|%s', [SAllFilter, Filters, Descriptions]); - - Result := Descriptions; -end; - -function GetFilterIndexExtension(Index: LongInt; OpenFileFilter: Boolean): string; -var - I, Count: LongInt; - FileFormat: TImageFileFormat; -begin - // -1 because filter indices are in 1..n range - Index := Index - 1; - Result := ''; - if OpenFileFilter then - begin - if Index > 0 then - Index := Index - 1; - end; - - if (Index >= 0) and (Index < ImageFileFormats.Count) then - begin - Count := 0; - for I := 0 to ImageFileFormats.Count - 1 do - begin - FileFormat := TObject(ImageFileFormats[I]) as TImageFileFormat; - if not OpenFileFilter and not FileFormat.CanSave then - Continue; - if Index = Count then - begin - if FileFormat.Extensions.Count > 0 then - Result := FileFormat.Extensions[0]; - Exit; - end; - Inc(Count); - end; - end; -end; - -function GetFileNameFilterIndex(const FileName: string; OpenFileFilter: Boolean): LongInt; -var - I: LongInt; - FileFormat: TImageFileFormat; -begin - Result := 0; - for I := 0 to ImageFileFormats.Count - 1 do - begin - FileFormat := TObject(ImageFileFormats[I]) as TImageFileFormat; - if not OpenFileFilter and not FileFormat.CanSave then - Continue; - if FileFormat.TestFileName(FileName) then - begin - // +1 because filter indices are in 1..n range - Inc(Result); - if OpenFileFilter then - Inc(Result); - Exit; - end; - Inc(Result); - end; - Result := -1; -end; - -function GetIO: TIOFunctions; -begin - Result := IO; -end; - -procedure RaiseImaging(const Msg: string; const Args: array of const); -var - WholeMsg: string; -begin - WholeMsg := Msg; - if GetExceptObject <> nil then - WholeMsg := WholeMsg + ' ' + SExceptMsg + ': ' + - GetExceptObject.Message; - raise EImagingError.CreateFmt(WholeMsg, Args); -end; - -{ Internal unit functions } - -function CheckOptionValue(OptionId, Value: LongInt): LongInt; -begin - case OptionId of - ImagingColorReductionMask: - Result := ClampInt(Value, 0, $FF); - ImagingLoadOverrideFormat, ImagingSaveOverrideFormat: - Result := Iff(ImagingFormats.IsImageFormatValid(TImageFormat(Value)), - Value, LongInt(ifUnknown)); - ImagingMipMapFilter: Result := ClampInt(Value, Ord(Low(TSamplingFilter)), - Ord(High(TSamplingFilter))); - else - Result := Value; - end; -end; - -procedure SetFileIO; -begin - IO := FileIO; -end; - -procedure SetStreamIO; -begin - IO := StreamIO; -end; - -procedure SetMemoryIO; -begin - IO := MemoryIO; -end; - -procedure InitImageFormats; -begin - ImagingFormats.InitImageFormats(ImageFormatInfos); -end; - -procedure FreeImageFileFormats; -var - I: LongInt; -begin - if ImageFileFormats <> nil then - for I := 0 to ImageFileFormats.Count - 1 do - TImageFileFormat(ImageFileFormats[I]).Free; - FreeAndNil(ImageFileFormats); -end; - -procedure InitOptions; -begin - SetLength(Options, InitialOptions); - OptionStack := TOptionStack.Create; -end; - -procedure FreeOptions; -begin - SetLength(Options, 0); - FreeAndNil(OptionStack); -end; - -{ - TImageFileFormat class implementation -} - -constructor TImageFileFormat.Create; -begin - inherited Create; - FName := SUnknownFormat; - FExtensions := TStringList.Create; - FMasks := TStringList.Create; -end; - -destructor TImageFileFormat.Destroy; -begin - FExtensions.Free; - FMasks.Free; - inherited Destroy; -end; - -function TImageFileFormat.PrepareLoad(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstFrame: Boolean): Boolean; -begin - FreeImagesInArray(Images); - SetLength(Images, 0); - Result := Handle <> nil; -end; - -function TImageFileFormat.PostLoadCheck(var Images: TDynImageDataArray; - LoadResult: Boolean): Boolean; -var - I: LongInt; -begin - if not LoadResult then - begin - FreeImagesInArray(Images); - SetLength(Images, 0); - Result := False; - end - else - begin - Result := (Length(Images) > 0) and TestImagesInArray(Images); - - if Result then - begin - // Convert to overriden format if it is set - if LoadOverrideFormat <> ifUnknown then - for I := Low(Images) to High(Images) do - ConvertImage(Images[I], LoadOverrideFormat); - end; - end; -end; - -function TImageFileFormat.PrepareSave(Handle: TImagingHandle; - const Images: TDynImageDataArray; var Index: Integer): Boolean; -var - Len, I: LongInt; -begin - CheckOptionsValidity; - Result := False; - if FCanSave then - begin - Len := Length(Images); - Assert(Len > 0); - - // If there are no images to be saved exit - if Len = 0 then Exit; - - // Check index of image to be saved (-1 as index means save all images) - if FIsMultiImageFormat then - begin - if (Index >= Len) then - Index := 0; - - if Index < 0 then - begin - Index := 0; - FFirstIdx := 0; - FLastIdx := Len - 1; - end - else - begin - FFirstIdx := Index; - FLastIdx := Index; - end; - - for I := FFirstIdx to FLastIdx - 1 do - if not TestImage(Images[I]) then - Exit; - end - else - begin - if (Index >= Len) or (Index < 0) then - Index := 0; - if not TestImage(Images[Index]) then - Exit; - end; - - Result := True; - end; -end; - -procedure TImageFileFormat.AddMasks(const AMasks: string); -var - I: LongInt; - Ext: string; -begin - FExtensions.Clear; - FMasks.CommaText := AMasks; - FMasks.Delimiter := ';'; - - for I := 0 to FMasks.Count - 1 do - begin - FMasks[I] := Trim(FMasks[I]); - Ext := GetFileExt(FMasks[I]); - if (Ext <> '') and (Ext <> '*') then - FExtensions.Add(Ext); - end; -end; - -function TImageFileFormat.GetFormatInfo(Format: TImageFormat): TImageFormatInfo; -begin - Result := ImageFormatInfos[Format]^; -end; - -function TImageFileFormat.GetSupportedFormats: TImageFormats; -begin - Result := FSupportedFormats; -end; - -function TImageFileFormat.LoadData(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstFrame: Boolean): Boolean; -begin - Result := False; - RaiseImaging(SFileFormatCanNotLoad, [FName]); -end; - -function TImageFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: LongInt): Boolean; -begin - Result := False; - RaiseImaging(SFileFormatCanNotSave, [FName]); -end; - -procedure TImageFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -begin -end; - -function TImageFileFormat.IsSupported(const Image: TImageData): Boolean; -begin - Result := Image.Format in GetSupportedFormats; -end; - -function TImageFileFormat.LoadFromFile(const FileName: string; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - Handle: TImagingHandle; -begin - Result := False; - if FCanLoad then - try - // Set IO ops to file ops and open given file - SetFileIO; - Handle := IO.OpenRead(PChar(FileName)); - try - // Test if file contains valid image and if so then load it - if TestFormat(Handle) then - begin - Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and - LoadData(Handle, Images, OnlyFirstlevel); - Result := Result and PostLoadCheck(Images, Result); - end - else - RaiseImaging(SFileNotValid, [FileName, Name]); - finally - IO.Close(Handle); - end; - except - RaiseImaging(SErrorLoadingFile, [FileName, FExtensions[0]]); - end; -end; - -function TImageFileFormat.LoadFromStream(Stream: TStream; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - Handle: TImagingHandle; - OldPosition: Int64; -begin - Result := False; - OldPosition := Stream.Position; - if FCanLoad then - try - // Set IO ops to stream ops and "open" given memory - SetStreamIO; - Handle := IO.OpenRead(Pointer(Stream)); - try - // Test if stream contains valid image and if so then load it - if TestFormat(Handle) then - begin - Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and - LoadData(Handle, Images, OnlyFirstlevel); - Result := Result and PostLoadCheck(Images, Result); - end - else - RaiseImaging(SStreamNotValid, [@Stream, Name]); - finally - IO.Close(Handle); - end; - except - Stream.Position := OldPosition; - RaiseImaging(SErrorLoadingStream, [@Stream, FExtensions[0]]); - end; -end; - -function TImageFileFormat.LoadFromMemory(Data: Pointer; Size: LongInt; var - Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - Handle: TImagingHandle; - IORec: TMemoryIORec; -begin - Result := False; - if FCanLoad then - try - // Set IO ops to memory ops and "open" given memory - SetMemoryIO; - IORec := PrepareMemIO(Data, Size); - Handle := IO.OpenRead(@IORec); - try - // Test if memory contains valid image and if so then load it - if TestFormat(Handle) then - begin - Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and - LoadData(Handle, Images, OnlyFirstlevel); - Result := Result and PostLoadCheck(Images, Result); - end - else - RaiseImaging(SMemoryNotValid, [Data, Size, Name]); - finally - IO.Close(Handle); - end; - except - RaiseImaging(SErrorLoadingMemory, [Data, Size, FExtensions[0]]); - end; -end; - -function TImageFileFormat.SaveToFile(const FileName: string; - const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - Handle: TImagingHandle; - Len, Index, I: LongInt; - Ext, FName: string; -begin - Result := False; - if FCanSave and TestImagesInArray(Images) then - try - SetFileIO; - Len := Length(Images); - if FIsMultiImageFormat or - (not FIsMultiImageFormat and (OnlyFirstLevel or (Len = 1))) then - begin - Handle := IO.OpenWrite(PChar(FileName)); - try - if OnlyFirstLevel then - Index := 0 - else - Index := -1; - // Write multi image to one file - Result := PrepareSave(Handle, Images, Index) and SaveData(Handle, Images, Index); - finally - IO.Close(Handle); - end; - end - else - begin - // Write multi image to file sequence - Ext := ExtractFileExt(FileName); - FName := ChangeFileExt(FileName, ''); - Result := True; - for I := 0 to Len - 1 do - begin - Handle := IO.OpenWrite(PChar(Format(FName + '%.3d' + Ext, [I]))); - try - Index := I; - Result := Result and PrepareSave(Handle, Images, Index) and - SaveData(Handle, Images, Index); - if not Result then - Break; - finally - IO.Close(Handle); - end; - end; - end; - except - RaiseImaging(SErrorSavingFile, [FileName, FExtensions[0]]); - end; -end; - -function TImageFileFormat.SaveToStream(Stream: TStream; - const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - Handle: TImagingHandle; - Len, Index, I: LongInt; - OldPosition: Int64; -begin - Result := False; - OldPosition := Stream.Position; - if FCanSave and TestImagesInArray(Images) then - try - SetStreamIO; - Handle := IO.OpenWrite(PChar(Stream)); - try - if FIsMultiImageFormat or OnlyFirstLevel then - begin - if OnlyFirstLevel then - Index := 0 - else - Index := -1; - // Write multi image in one run - Result := PrepareSave(Handle, Images, Index) and SaveData(Handle, Images, Index); - end - else - begin - // Write multi image to sequence - Result := True; - Len := Length(Images); - for I := 0 to Len - 1 do - begin - Index := I; - Result := Result and PrepareSave(Handle, Images, Index) and - SaveData(Handle, Images, Index); - if not Result then - Break; - end; - end; - finally - IO.Close(Handle); - end; - except - Stream.Position := OldPosition; - RaiseImaging(SErrorSavingStream, [@Stream, FExtensions[0]]); - end; -end; - -function TImageFileFormat.SaveToMemory(Data: Pointer; var Size: LongInt; - const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - Handle: TImagingHandle; - Len, Index, I: LongInt; - IORec: TMemoryIORec; -begin - Result := False; - if FCanSave and TestImagesInArray(Images) then - try - SetMemoryIO; - IORec := PrepareMemIO(Data, Size); - Handle := IO.OpenWrite(PChar(@IORec)); - try - if FIsMultiImageFormat or OnlyFirstLevel then - begin - if OnlyFirstLevel then - Index := 0 - else - Index := -1; - // Write multi image in one run - Result := PrepareSave(Handle, Images, Index) and SaveData(Handle, Images, Index); - end - else - begin - // Write multi image to sequence - Result := True; - Len := Length(Images); - for I := 0 to Len - 1 do - begin - Index := I; - Result := Result and PrepareSave(Handle, Images, Index) and - SaveData(Handle, Images, Index); - if not Result then - Break; - end; - end; - Size := IORec.Position; - finally - IO.Close(Handle); - end; - except - RaiseImaging(SErrorSavingMemory, [Data, Size, FExtensions[0]]); - end; -end; - -function TImageFileFormat.MakeCompatible(const Image: TImageData; - var Compatible: TImageData; out MustBeFreed: Boolean): Boolean; -begin - InitImage(Compatible); - - if SaveOverrideFormat <> ifUnknown then - begin - // Save format override is active. Clone input and convert it to override format. - CloneImage(Image, Compatible); - ConvertImage(Compatible, SaveOverrideFormat); - // Now check if override format is supported by file format. If it is not - // then file format specific conversion (virtual method) is called. - Result := IsSupported(Compatible); - if not Result then - begin - ConvertToSupported(Compatible, GetFormatInfo(Compatible.Format)); - Result := IsSupported(Compatible); - end; - end // Add IsCompatible function! not only checking by Format - else if IsSupported(Image) then - begin - // No save format override and input is in format supported by this - // file format. Just copy Image's fields to Compatible - Compatible := Image; - Result := True; - end - else - begin - // No override and input's format is not compatible with file format. - // Clone it and the call file format specific conversion (virtual method). - CloneImage(Image, Compatible); - ConvertToSupported(Compatible, GetFormatInfo(Compatible.Format)); - Result := IsSupported(Compatible); - end; - // Tell the user that he must free Compatible after he's done with it - // (if necessary). - MustBeFreed := Image.Bits <> Compatible.Bits; -end; - -function TImageFileFormat.TestFormat(Handle: TImagingHandle): Boolean; -begin - Result := False; -end; - -function TImageFileFormat.TestFileName(const FileName: string): Boolean; -var - I: LongInt; - OnlyName: string; -begin - OnlyName := ExtractFileName(FileName); - // For each mask test if filename matches it - for I := 0 to FMasks.Count - 1 do - if MatchFileNameMask(OnlyName, FMasks[I], False) then - begin - Result := True; - Exit; - end; - Result := False; -end; - -procedure TImageFileFormat.CheckOptionsValidity; -begin -end; - -{ TOptionStack class implementation } - -constructor TOptionStack.Create; -begin - inherited Create; - FPosition := -1; -end; - -destructor TOptionStack.Destroy; -var - I: LongInt; -begin - for I := 0 to OptionStackDepth - 1 do - SetLength(FStack[I], 0); - inherited Destroy; -end; - -function TOptionStack.Pop: Boolean; -var - I: LongInt; -begin - Result := False; - if FPosition >= 0 then - begin - SetLength(Options, Length(FStack[FPosition])); - for I := 0 to Length(FStack[FPosition]) - 1 do - if Options[I] <> nil then - Options[I]^ := FStack[FPosition, I]; - Dec(FPosition); - Result := True; - end; -end; - -function TOptionStack.Push: Boolean; -var - I: LongInt; -begin - Result := False; - if FPosition < OptionStackDepth - 1 then - begin - Inc(FPosition); - SetLength(FStack[FPosition], Length(Options)); - for I := 0 to Length(Options) - 1 do - if Options[I] <> nil then - FStack[FPosition, I] := Options[I]^; - Result := True; - end; -end; - -initialization -{$IFDEF MEMCHECK} - {$IF CompilerVersion >= 18} - System.ReportMemoryLeaksOnShutdown := True; - {$IFEND} -{$ENDIF} - if ImageFileFormats = nil then - ImageFileFormats := TList.Create; - InitImageFormats; - RegisterOption(ImagingColorReductionMask, @ColorReductionMask); - RegisterOption(ImagingLoadOverrideFormat, @LoadOverrideFormat); - RegisterOption(ImagingSaveOverrideFormat, @SaveOverrideFormat); - RegisterOption(ImagingMipMapFilter, @MipMapFilter); -finalization - FreeOptions; - FreeImageFileFormats; - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.26.3 Changes/Bug Fixes --------------------------------- - - Extended RotateImage to allow arbitrary angle rotations. - - Reversed the order file formats list is searched so - if you register a new one it will be found sooner than - built in formats. - - Fixed memory leak in ResizeImage ocurring when resizing - indexed images. - - -- 0.26.1 Changes/Bug Fixes --------------------------------- - - Added position/size checks to LoadFromStream functions. - - Changed conditional compilation in impl. uses section to reflect changes - in LINK symbols. - - -- 0.24.3 Changes/Bug Fixes --------------------------------- - - GenerateMipMaps now generates all smaller levels from - original big image (better results when using more advanced filters). - Also conversion to compatible image format is now done here not - in FillMipMapLevel (that is called for every mipmap level). - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - MakePaletteForImages now works correctly for indexed and special format images - - Fixed bug in StretchRect: Image was not properly stretched if - src and dst dimensions differed only in height. - - ConvertImage now fills new image with zeroes to avoid random data in - some conversions (RGB->XRGB) - - Changed RegisterOption procedure to function - - Changed bunch of palette functions from low level interface to procedure - (there was no reason for them to be functions). - - Changed FreeImage and FreeImagesInArray functions to procedures. - - Added many assertions, come try-finally, other checks, and small code - and doc changes. - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - GenerateMipMaps threw failed assertion when input was indexed or special, - fixed. - - Added CheckOptionsValidity to TImageFileFormat and its decendants. - - Unit ImagingExtras which registers file formats in Extras package - is now automatically added to uses clause if LINK_EXTRAS symbol is - defined in ImagingOptions.inc file. - - Added EnumFileFormats function to low level interface. - - Fixed bug in SwapChannels which could cause AV when swapping alpha - channel of A8R8G8B8 images. - - Converting loaded images to ImagingOverrideFormat is now done - in PostLoadCheck method to avoid code duplicity. - - Added GetFileFormatCount and GetFileFormatAtIndex functions - - Bug in ConvertImage: if some format was converted to similar format - only with swapped channels (R16G16B16<>B16G16R16) then channels were - swapped correctly but new data format (swapped one) was not set. - - Made TImageFileFormat.MakeCompatible public non-virtual method - (and modified its function). Created new virtual - ConvertToSupported which should be overriden by descendants. - Main reason for doint this is to avoid duplicate code that was in all - TImageFileFormat's descendants. - - Changed TImageFileFormat.GetFormatInfo's result type to TImageFormatInfo. - - Split overloaded FindImageFileFormat functions to - FindImageFileFormatByClass and FindImageFileFormatByExt and created new - FindImageFileFormatByName which operates on whole filenames. - - Function GetExtensionFilterIndex renamed to GetFileNameFilterIndex - (because it now works with filenames not extensions). - - DetermineFileFormat now first searches by filename and if not found - then by data. - - Added TestFileName method to TImageFileFormat. - - Updated GetImageFileFormatsFilter to uses Masks instead of Extensions - property of TImageFileFormat. Also you can now request - OpenDialog and SaveDialog type filters - - Added Masks property and AddMasks method to TImageFileFormat. - AddMasks replaces AddExtensions, it uses filename masks instead - of sime filename extensions to identify supported files. - - Changed TImageFileFormat.LoadData procedure to function and - moved varios duplicate code from its descandats (check index,...) - here to TImageFileFormat helper methods. - - Changed TImageFileFormat.SaveData procedure to function and - moved varios duplicate code from its descandats (check index,...) - here to TImageFileFormat helper methods. - - Removed RAISE_EXCEPTIONS define, exceptions are now raised everytime - - Added MustBeFreed parameter to TImageFileFormat.MakeComptible method - that indicates that compatible image returned by this method must be - freed after its usage. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - fixed bug in NewImage: if given format was ifDefault it wasn't - replaced with DefaultImageFormat constant which caused problems later - in other units - - fixed bug in RotateImage which caused that rotated special format - images were whole black - - LoadImageFromXXX and LoadMultiImageFromXXX now use DetermineXXXFormat - when choosing proper loader, this eliminated need for Ext parameter - in stream and memory loading functions - - added GetVersionStr function - - fixed bug in ResizeImage which caued indexed images to lose their - palette during process resulting in whole black image - - Clipping in ...Rect functions now uses clipping procs from ImagingUtility, - it also works better - - FillRect optimization for 8, 16, and 32 bit formats - - added pixel set/get functions to low level interface: - GetPixelDirect, SetPixelDirect, GetPixel32, SetPixel32, - GetPixelFP, SetPixelFP - - removed GetPixelBytes low level intf function - redundant - (same data can be obtained by GetImageFormatInfo) - - made small changes in many parts of library to compile - on AMD64 CPU (Linux with FPC) - - changed InitImage to procedure (function was pointless) - - Method TestFormat of TImageFileFormat class made public - (was protected) - - added function IsFileFormatSupported to low level interface - (contributed by Paul Michell) - - fixed some missing format arguments from error strings - which caused Format function to raise exception - - removed forgotten debug code that disabled filtered resizing of images with - channel bitcounts > 8 - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - changed order of parameters of CopyRect function - - GenerateMipMaps now filters mipmap levels - - ResizeImage functions was extended to allow bilinear and bicubic filtering - - added StretchRect function to low level interface - - added functions GetImageFileFormatsFilter, GetFilterIndexExtension, - and GetExtensionFilterIndex - - -- 0.15 Changes/Bug Fixes ----------------------------------- - - added function RotateImage to low level interface - - moved TImageFormatInfo record and types required by it to - ImagingTypes unit, changed GetImageFormatInfo low level - interface function to return TImageFormatInfo instead of short info - - added checking of options values validity before they are used - - fixed possible memory leak in CloneImage - - added ReplaceColor function to low level interface - - new function FindImageFileFormat by class added - - -- 0.13 Changes/Bug Fixes ----------------------------------- - - added DetermineFileFormat, DetermineStreamFormat, DetermineMemoryFormat, - GetPixelsSize functions to low level interface - - added NewPalette, CopyPalette, FreePalette functions - to low level interface - - added MapImageToPalette, FillRect, SplitImage, MakePaletteForImages - functions to low level interface - - fixed buggy FillCustomPalette function (possible div by zero and others) - - added CopyRect function to low level interface - - Member functions of TImageFormatInfo record implemented for all formats - - before saving images TestImagesInArray is called now - - added TestImagesInArray function to low level interface - - added GenerateMipMaps function to low level interface - - stream position in load/save from/to stream is now set to position before - function was called if error occurs - - when error occured during load/save from/to file file handle - was not released - - CloneImage returned always False - -} -end. - + + if OldFmt <> Image.Format then + ConvertImage(Image, OldFmt); + except + raise UpdateExceptMessage(GetExceptObject, SErrorRotateImage, [ImageToStr(Image), Angle]); + end; +end; + +procedure RotateImageMul90(var Image: TImageData; AngleDeg: Integer); +var + RotImage: TImageData; + X, Y, BytesPerPixel: Integer; + RotPix, Pix: PByte; +begin + if TestImage(Image) then + try + InitImage(RotImage); + + while AngleDeg >= 360 do + AngleDeg := AngleDeg - 360; + while AngleDeg < 0 do + AngleDeg := AngleDeg + 360; + + if (AngleDeg = 0) or (Abs(AngleDeg) = 360) then + Exit; + + if not ((AngleDeg mod 90) = 0) then + raise EImagingError.CreateFmt('Angle must be multiple of 90 but was: %d', [AngleDeg]); + + if ((AngleDeg = 90) or (AngleDeg = 270)) and (Image.Width <> Image.Height) then + NewImage(Image.Height, Image.Width, Image.Format, RotImage) + else + NewImage(Image.Width, Image.Height, Image.Format, RotImage); + + BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel; + + RotPix := RotImage.Bits; + case AngleDeg of + 90: + begin + for Y := 0 to RotImage.Height - 1 do + begin + Pix := @PByteArray(Image.Bits)[(Image.Width - Y - 1) * BytesPerPixel]; + for X := 0 to RotImage.Width - 1 do + begin + CopyPixel(Pix, RotPix, BytesPerPixel); + Inc(RotPix, BytesPerPixel); + Inc(Pix, Image.Width * BytesPerPixel); + end; + end; + end; + 180: + begin + Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + + (Image.Width - 1)) * BytesPerPixel]; + for Y := 0 to RotImage.Height - 1 do + for X := 0 to RotImage.Width - 1 do + begin + CopyPixel(Pix, RotPix, BytesPerPixel); + Inc(RotPix, BytesPerPixel); + Dec(Pix, BytesPerPixel); + end; + end; + 270: + begin + for Y := 0 to RotImage.Height - 1 do + begin + Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + Y) * BytesPerPixel]; + for X := 0 to RotImage.Width - 1 do + begin + CopyPixel(Pix, RotPix, BytesPerPixel); + Inc(RotPix, BytesPerPixel); + Dec(Pix, Image.Width * BytesPerPixel); + end; + end; + end; + end; + + FreeMemNil(Image.Bits); + RotImage.Palette := Image.Palette; + Image := RotImage; + except + raise UpdateExceptMessage(GetExceptObject, 'Error while rotating image %s by %d degrees', + [ImageToStr(Image), AngleDeg]); + end; +end; + +{ Drawing/Pixel functions } + +function CopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt; + var DstImage: TImageData; DstX, DstY: LongInt): Boolean; +var + Info: PImageFormatInfo; + I, SrcWidthBytes, DstWidthBytes, MoveBytes: LongInt; + SrcPointer, DstPointer: PByte; + WorkImage: TImageData; + OldFormat: TImageFormat; +begin + Result := False; + OldFormat := ifUnknown; + if TestImage(SrcImage) and TestImage(DstImage) then + try + // Make sure we are still copying image to image, not invalid pointer to protected memory + ClipCopyBounds(SrcX, SrcY, Width, Height, DstX, DstY, SrcImage.Width, SrcImage.Height, + Rect(0, 0, DstImage.Width, DstImage.Height)); + + if (Width > 0) and (Height > 0) then + begin + Info := ImageFormatInfos[DstImage.Format]; + if Info.IsSpecial then + begin + // If dest image is in special format we convert it to default + OldFormat := Info.Format; + ConvertImage(DstImage, ifDefault); + Info := ImageFormatInfos[DstImage.Format]; + end; + if SrcImage.Format <> DstImage.Format then + begin + // If images are in different format source is converted to dest's format + InitImage(WorkImage); + CloneImage(SrcImage, WorkImage); + ConvertImage(WorkImage, DstImage.Format); + end + else + WorkImage := SrcImage; + + MoveBytes := Width * Info.BytesPerPixel; + DstWidthBytes := DstImage.Width * Info.BytesPerPixel; + DstPointer := @PByteArray(DstImage.Bits)[DstY * DstWidthBytes + + DstX * Info.BytesPerPixel]; + SrcWidthBytes := WorkImage.Width * Info.BytesPerPixel; + SrcPointer := @PByteArray(WorkImage.Bits)[SrcY * SrcWidthBytes + + SrcX * Info.BytesPerPixel]; + + for I := 0 to Height - 1 do + begin + Move(SrcPointer^, DstPointer^, MoveBytes); + Inc(SrcPointer, SrcWidthBytes); + Inc(DstPointer, DstWidthBytes); + end; + // If dest image was in special format we convert it back + if OldFormat <> ifUnknown then + ConvertImage(DstImage, OldFormat); + // Working image must be freed if it is not the same as source image + if WorkImage.Bits <> SrcImage.Bits then + FreeImage(WorkImage); + + Result := True; + end; + except + RaiseImaging(SErrorCopyRect, [ImageToStr(SrcImage), ImageToStr(DstImage)]); + end; +end; + +function FillRect(var Image: TImageData; X, Y, Width, Height: LongInt; + FillColor: Pointer): Boolean; +var + Info: PImageFormatInfo; + I, J, ImageWidthBytes, RectWidthBytes, Bpp: Longint; + LinePointer, PixPointer: PByte; + OldFmt: TImageFormat; +begin + Result := False; + if TestImage(Image) then + try + ClipRectBounds(X, Y, Width, Height, Rect(0, 0, Image.Width, Image.Height)); + + if (Width > 0) and (Height > 0) then + begin + OldFmt := Image.Format; + if ImageFormatInfos[OldFmt].IsSpecial then + ConvertImage(Image, ifDefault); + + Info := ImageFormatInfos[Image.Format]; + Bpp := Info.BytesPerPixel; + ImageWidthBytes := Image.Width * Bpp; + RectWidthBytes := Width * Bpp; + LinePointer := @PByteArray(Image.Bits)[Y * ImageWidthBytes + X * Bpp]; + + for I := 0 to Height - 1 do + begin + case Bpp of + 1: FillMemoryByte(LinePointer, RectWidthBytes, PByte(FillColor)^); + 2: FillMemoryWord(LinePointer, RectWidthBytes, PWord(FillColor)^); + 4: FillMemoryUInt32(LinePointer, RectWidthBytes, PUInt32(FillColor)^); + else + PixPointer := LinePointer; + for J := 0 to Width - 1 do + begin + CopyPixel(FillColor, PixPointer, Bpp); + Inc(PixPointer, Bpp); + end; + end; + Inc(LinePointer, ImageWidthBytes); + end; + + if OldFmt <> Image.Format then + ConvertImage(Image, OldFmt); + end; + + Result := True; + except + RaiseImaging(SErrorFillRect, [X, Y, Width, Height, ImageToStr(Image)]); + end; +end; + +function ReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt; + OldColor, NewColor: Pointer): Boolean; +var + Info: PImageFormatInfo; + I, J, WidthBytes, Bpp: Longint; + LinePointer, PixPointer: PByte; + OldFmt: TImageFormat; +begin + Assert((OldColor <> nil) and (NewColor <> nil)); + Result := False; + if TestImage(Image) then + try + ClipRectBounds(X, Y, Width, Height, Rect(0, 0, Image.Width, Image.Height)); + + if (Width > 0) and (Height > 0) then + begin + OldFmt := Image.Format; + if ImageFormatInfos[OldFmt].IsSpecial then + ConvertImage(Image, ifDefault); + + Info := ImageFormatInfos[Image.Format]; + Bpp := Info.BytesPerPixel; + WidthBytes := Image.Width * Bpp; + LinePointer := @PByteArray(Image.Bits)[Y * WidthBytes + X * Bpp]; + + for I := 0 to Height - 1 do + begin + PixPointer := LinePointer; + for J := 0 to Width - 1 do + begin + if ComparePixels(PixPointer, OldColor, Bpp) then + CopyPixel(NewColor, PixPointer, Bpp); + Inc(PixPointer, Bpp); + end; + Inc(LinePointer, WidthBytes); + end; + + if OldFmt <> Image.Format then + ConvertImage(Image, OldFmt); + end; + + Result := True; + except + RaiseImaging(SErrorReplaceColor, [X, Y, Width, Height, ImageToStr(Image)]); + end; +end; + +function StretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, + SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, + DstHeight: LongInt; Filter: TResizeFilter): Boolean; +var + Info: PImageFormatInfo; + WorkImage: TImageData; + OldFormat: TImageFormat; + Resampling: TSamplingFilter; +begin + Result := False; + OldFormat := ifUnknown; + if TestImage(SrcImage) and TestImage(DstImage) then + try + // Make sure we are still copying image to image, not invalid pointer to protected memory + ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY, DstWidth, DstHeight, + SrcImage.Width, SrcImage.Height, Rect(0, 0, DstImage.Width, DstImage.Height)); + + if (SrcWidth = DstWidth) and (SrcHeight = DstHeight) then + begin + // If source and dest rectangles have the same size call CopyRect + Result := CopyRect(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY); + end + else if (SrcWidth > 0) and (SrcHeight > 0) and (DstWidth > 0) and (DstHeight > 0) then + begin + // If source and dest rectangles don't have the same size we do stretch + Info := ImageFormatInfos[DstImage.Format]; + + if Info.IsSpecial then + begin + // If dest image is in special format we convert it to default + OldFormat := Info.Format; + ConvertImage(DstImage, ifDefault); + Info := ImageFormatInfos[DstImage.Format]; + end; + + if SrcImage.Format <> DstImage.Format then + begin + // If images are in different format source is converted to dest's format + InitImage(WorkImage); + CloneImage(SrcImage, WorkImage); + ConvertImage(WorkImage, DstImage.Format); + end + else + WorkImage := SrcImage; + + // Only pixel resize is supported for indexed images + if Info.IsIndexed then + Filter := rfNearest; + + if Filter = rfNearest then + begin + StretchNearest(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight, + DstImage, DstX, DstY, DstWidth, DstHeight); + end + else + begin + Resampling := sfNearest; + case Filter of + rfBilinear: Resampling := sfLinear; + rfBicubic: Resampling := DefaultCubicFilter; + rfLanczos: Resampling := sfLanczos; + end; + StretchResample(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight, + DstImage, DstX, DstY, DstWidth, DstHeight, Resampling); + end; + + // If dest image was in special format we convert it back + if OldFormat <> ifUnknown then + ConvertImage(DstImage, OldFormat); + // Working image must be freed if it is not the same as source image + if WorkImage.Bits <> SrcImage.Bits then + FreeImage(WorkImage); + + Result := True; + end; + except + RaiseImaging(SErrorStretchRect, [ImageToStr(SrcImage), ImageToStr(DstImage)]); + end; +end; + +procedure GetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); +var + BytesPerPixel: LongInt; +begin + Assert(Pixel <> nil); + BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel; + CopyPixel(@PByteArray(Image.Bits)[(Y * Image.Width + X) * BytesPerPixel], + Pixel, BytesPerPixel); +end; + +procedure SetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); +var + BytesPerPixel: LongInt; +begin + Assert(Pixel <> nil); + BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel; + CopyPixel(Pixel, @PByteArray(Image.Bits)[(Y * Image.Width + X) * BytesPerPixel], + BytesPerPixel); +end; + +function GetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; +var + Info: PImageFormatInfo; + Data: PByte; +begin + Info := ImageFormatInfos[Image.Format]; + Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel]; + Result := GetPixel32Generic(Data, Info, Image.Palette); +end; + +procedure SetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); +var + Info: PImageFormatInfo; + Data: PByte; +begin + Info := ImageFormatInfos[Image.Format]; + Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel]; + SetPixel32Generic(Data, Info, Image.Palette, Color); +end; + +function GetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; +var + Info: PImageFormatInfo; + Data: PByte; +begin + Info := ImageFormatInfos[Image.Format]; + Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel]; + Result := GetPixelFPGeneric(Data, Info, Image.Palette); +end; + +procedure SetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); +var + Info: PImageFormatInfo; + Data: PByte; +begin + Info := ImageFormatInfos[Image.Format]; + Data := @PByteArray(Image.Bits)[(Y * Image.Width + X) * Info.BytesPerPixel]; + SetPixelFPGeneric(Data, Info, Image.Palette, Color); +end; + +{ Palette Functions } + +procedure NewPalette(Entries: LongInt; var Pal: PPalette32); +begin + Assert((Entries > 2) and (Entries <= 65535)); + try + GetMem(Pal, Entries * SizeOf(TColor32Rec)); + FillChar(Pal^, Entries * SizeOf(TColor32Rec), $FF); + except + RaiseImaging(SErrorNewPalette, [Entries]); + end; +end; + +procedure FreePalette(var Pal: PPalette32); +begin + try + FreeMemNil(Pal); + except + RaiseImaging(SErrorFreePalette, [Pal]); + end; +end; + +procedure CopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt); +begin + Assert((SrcPal <> nil) and (DstPal <> nil)); + Assert((SrcIdx >= 0) and (DstIdx >= 0) and (Count >= 0)); + try + Move(SrcPal[SrcIdx], DstPal[DstIdx], Count * SizeOf(TColor32Rec)); + except + RaiseImaging(SErrorCopyPalette, [Count, SrcPal, DstPal]); + end; +end; + +function FindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): + LongInt; +var + Col: TColor32Rec; + I, MinDif, Dif: LongInt; +begin + Assert(Pal <> nil); + Result := -1; + Col.Color := Color; + try + // First try to find exact match + for I := 0 to Entries - 1 do + with Pal[I] do + begin + if (A = Col.A) and (R = Col.R) and + (G = Col.G) and (B = Col.B) then + begin + Result := I; + Exit; + end; + end; + + // If exact match was not found, find nearest color + MinDif := 1020; + for I := 0 to Entries - 1 do + with Pal[I] do + begin + Dif := Abs(R - Col.R); + if Dif > MinDif then Continue; + Dif := Dif + Abs(G - Col.G); + if Dif > MinDif then Continue; + Dif := Dif + Abs(B - Col.B); + if Dif > MinDif then Continue; + Dif := Dif + Abs(A - Col.A); + if Dif < MinDif then + begin + MinDif := Dif; + Result := I; + end; + end; + except + RaiseImaging(SErrorFindColor, [Pal, Entries]); + end; +end; + +procedure FillGrayscalePalette(Pal: PPalette32; Entries: LongInt); +var + I: LongInt; +begin + Assert(Pal <> nil); + try + for I := 0 to Entries - 1 do + with Pal[I] do + begin + A := $FF; + R := Byte(I); + G := Byte(I); + B := Byte(I); + end; + except + RaiseImaging(SErrorGrayscalePalette, [Pal, Entries]); + end; +end; + +procedure FillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits, + BBits: Byte; Alpha: Byte = $FF); +var + I, TotalBits, MaxEntries: LongInt; +begin + Assert(Pal <> nil); + TotalBits := RBits + GBits + BBits; + MaxEntries := Min(Pow2Int(TotalBits), Entries); + FillChar(Pal^, Entries * SizeOf(TColor32Rec), 0); + try + for I := 0 to MaxEntries - 1 do + with Pal[I] do + begin + A := Alpha; + if RBits > 0 then + R := ((I shr Max(0, GBits + BBits - 1)) and (1 shl RBits - 1)) * 255 div (1 shl RBits - 1); + if GBits > 0 then + G := ((I shr Max(0, BBits - 1)) and (1 shl GBits - 1)) * 255 div (1 shl GBits - 1); + if BBits > 0 then + B := ((I shr 0) and (1 shl BBits - 1)) * 255 div (1 shl BBits - 1); + end; + except + RaiseImaging(SErrorCustomPalette, [Pal, Entries]); + end; +end; + +procedure SwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel, + DstChannel: LongInt); +var + I: LongInt; + Swap: Byte; +begin + Assert(Pal <> nil); + Assert((SrcChannel in [0..3]) and (DstChannel in [0..3])); + try + for I := 0 to Entries - 1 do + with Pal[I] do + begin + Swap := Channels[SrcChannel]; + Channels[SrcChannel] := Channels[DstChannel]; + Channels[DstChannel] := Swap; + end; + except + RaiseImaging(SErrorSwapPalette, [Pal, Entries]); + end; +end; + +{ Options Functions } + +function SetOption(OptionId, Value: LongInt): Boolean; +begin + Result := False; + if (OptionId >= 0) and (OptionId < Length(Options)) and + (Options[OptionID] <> nil) then + begin + Options[OptionID]^ := CheckOptionValue(OptionId, Value); + Result := True; + end; +end; + +function GetOption(OptionId: LongInt): LongInt; +begin + Result := InvalidOption; + if (OptionId >= 0) and (OptionId < Length(Options)) and + (Options[OptionID] <> nil) then + begin + Result := Options[OptionID]^; + end; +end; + +function PushOptions: Boolean; +begin + Result := OptionStack.Push; +end; + +function PopOptions: Boolean; +begin + Result := OptionStack.Pop; +end; + +{ Image Format Functions } + +function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean; +begin + FillChar(Info, SizeOf(Info), 0); + if ImageFormatInfos[Format] <> nil then + begin + Info := ImageFormatInfos[Format]^; + Result := True; + end + else + Result := False; +end; + +function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; +begin + if ImageFormatInfos[Format] <> nil then + Result := ImageFormatInfos[Format].GetPixelsSize(Format, Width, Height) + else + Result := 0; +end; + +{ IO Functions } + +procedure SetUserFileIO(OpenProc: TOpenProc; + CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc; TellProc: + TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); +begin + FileIO.Open := OpenProc; + FileIO.Close := CloseProc; + FileIO.Eof := EofProc; + FileIO.Seek := SeekProc; + FileIO.Tell := TellProc; + FileIO.Read := ReadProc; + FileIO.Write := WriteProc; +end; + +procedure ResetFileIO; +begin + FileIO := OriginalFileIO; +end; + +{ Raw Image IO Functions } + +procedure ReadRawImage(Handle: TImagingHandle; Width, Height: Integer; + Format: TImageFormat; var Image: TImageData; Offset, RowLength: Integer); +var + WidthBytes, I: Integer; + Info: PImageFormatInfo; +begin + Info := ImageFormatInfos[Format]; + // Calc scanline size + WidthBytes := Info.GetPixelsSize(Format, Width, 1); + if RowLength = 0 then + RowLength := WidthBytes; + // Create new image if needed - don't need to allocate new one if there is already + // one with desired size and format + if (Image.Width <> Width) or (Image.Height <> Height) or (Image.Format <> Format) then + NewImage(Width, Height, Format, Image); + // Move past the header + IO.Seek(Handle, Offset, smFromCurrent); + // Read scanlines from input + for I := 0 to Height - 1 do + begin + IO.Read(Handle, @PByteArray(Image.Bits)[I * WidthBytes], WidthBytes); + IO.Seek(Handle, RowLength - WidthBytes, smFromCurrent); + end; +end; + +procedure ReadRawImageFromFile(const FileName: string; Width, Height: Integer; + Format: TImageFormat; var Image: TImageData; Offset, RowLength: Integer); +var + Handle: TImagingHandle; +begin + Assert(FileName <> ''); + // Set IO ops to file ops and open given file + SetFileIO; + Handle := IO.Open(PChar(FileName), omReadOnly); + try + ReadRawImage(Handle, Width, Height, Format, Image, Offset, RowLength); + finally + IO.Close(Handle); + end; +end; + +procedure ReadRawImageFromStream(Stream: TStream; Width, Height: Integer; + Format: TImageFormat; var Image: TImageData; Offset, RowLength: Integer); +var + Handle: TImagingHandle; +begin + Assert(Stream <> nil); + if Stream.Size - Stream.Position = 0 then + RaiseImaging(SErrorEmptyStream, []); + // Set IO ops to stream ops and open given stream + SetStreamIO; + Handle := IO.Open(Pointer(Stream), omReadOnly); + try + ReadRawImage(Handle, Width, Height, Format, Image, Offset, RowLength); + finally + IO.Close(Handle); + end; +end; + +procedure ReadRawImageFromMemory(Data: Pointer; DataSize: Integer; Width, Height: Integer; + Format: TImageFormat; var Image: TImageData; Offset, RowLength: Integer); +var + Handle: TImagingHandle; + MemRec: TMemoryIORec; +begin + Assert((Data <> nil) and (DataSize > 0)); + // Set IO ops to memory ops and open given stream + SetMemoryIO; + MemRec := PrepareMemIO(Data, DataSize); + Handle := IO.Open(@MemRec, omReadOnly); + try + ReadRawImage(Handle, Width, Height, Format, Image, Offset, RowLength); + finally + IO.Close(Handle); + end; +end; + +procedure ReadRawImageRect(Data: Pointer; Left, Top, Width, Height: Integer; + var Image: TImageData; Offset, RowLength: Integer); +var + DestScanBytes, RectBytes, I: Integer; + Info: PImageFormatInfo; + Src, Dest: PByte; +begin + Assert(Data <> nil); + Assert((Left + Width <= Image.Width) and (Top + Height <= Image.Height)); + Info := ImageFormatInfos[Image.Format]; + + // Calc scanline size + DestScanBytes := Info.GetPixelsSize(Info.Format, Image.Width, 1); + RectBytes := Info.GetPixelsSize(Info.Format, Width, 1); + if RowLength = 0 then + RowLength := RectBytes; + + Src := Data; + Dest := @PByteArray(Image.Bits)[Top * DestScanBytes + Info.GetPixelsSize(Info.Format, Left, 1)]; + // Move past the header + Inc(Src, Offset); + + // Read lines into rect in the existing image + for I := 0 to Height - 1 do + begin + Move(Src^, Dest^, RectBytes); + Inc(Src, RowLength); + Inc(Dest, DestScanBytes); + end; +end; + +procedure WriteRawImage(Handle: TImagingHandle; const Image: TImageData; + Offset, RowLength: Integer); +var + WidthBytes, I: Integer; + Info: PImageFormatInfo; +begin + Info := ImageFormatInfos[Image.Format]; + // Calc scanline size + WidthBytes := Info.GetPixelsSize(Image.Format, Image.Width, 1); + if RowLength = 0 then + RowLength := WidthBytes; + // Move past the header + IO.Seek(Handle, Offset, smFromCurrent); + // Write scanlines to output + for I := 0 to Image.Height - 1 do + begin + IO.Write(Handle, @PByteArray(Image.Bits)[I * WidthBytes], WidthBytes); + IO.Seek(Handle, RowLength - WidthBytes, smFromCurrent); + end; +end; + +procedure WriteRawImageToFile(const FileName: string; const Image: TImageData; + Offset, RowLength: Integer); +var + Handle: TImagingHandle; +begin + Assert(FileName <> ''); + // Set IO ops to file ops and open given file + SetFileIO; + Handle := IO.Open(PChar(FileName), omCreate); + try + WriteRawImage(Handle, Image, Offset, RowLength); + finally + IO.Close(Handle); + end; +end; + +procedure WriteRawImageToStream(Stream: TStream; const Image: TImageData; + Offset, RowLength: Integer); +var + Handle: TImagingHandle; +begin + Assert(Stream <> nil); + // Set IO ops to stream ops and open given stream + SetStreamIO; + Handle := IO.Open(Pointer(Stream), omCreate); + try + WriteRawImage(Handle, Image, Offset, RowLength); + finally + IO.Close(Handle); + end; +end; + +procedure WriteRawImageToMemory(Data: Pointer; DataSize: Integer; const Image: TImageData; + Offset, RowLength: Integer); +var + Handle: TImagingHandle; + MemRec: TMemoryIORec; +begin + Assert((Data <> nil) and (DataSize > 0)); + // Set IO ops to memory ops and open given stream + SetMemoryIO; + MemRec := PrepareMemIO(Data, DataSize); + Handle := IO.Open(@MemRec, omCreate); + try + WriteRawImage(Handle, Image, Offset, RowLength); + finally + IO.Close(Handle); + end; +end; + +procedure WriteRawImageRect(Data: Pointer; Left, Top, Width, Height: Integer; + const Image: TImageData; Offset, RowLength: Integer); +var + SrcScanBytes, RectBytes, I: Integer; + Info: PImageFormatInfo; + Src, Dest: PByte; +begin + Assert(Data <> nil); + Assert((Left + Width <= Image.Width) and (Top + Height <= Image.Height)); + Info := ImageFormatInfos[Image.Format]; + + // Calc scanline size + SrcScanBytes := Info.GetPixelsSize(Info.Format, Image.Width, 1); + RectBytes := Info.GetPixelsSize(Info.Format, Width, 1); + if RowLength = 0 then + RowLength := RectBytes; + + Src := @PByteArray(Image.Bits)[Top * SrcScanBytes + Info.GetPixelsSize(Info.Format, Left, 1)]; + Dest := Data; + // Move past the header + Inc(Dest, Offset); + + // Write lines from rect of the existing image + for I := 0 to Height - 1 do + begin + Move(Src^, Dest^, RectBytes); + Inc(Dest, RowLength); + Inc(Src, SrcScanBytes); + end; +end; + +{ Convenience/helper Functions } + +procedure ResizeImageToFit(const SrcImage: TImageData; FitWidth, FitHeight: Integer; + Filter: TResizeFilter; var DestImage: TImageData); +var + CurSize, FitSize, DestSize: TSize; +begin + if not TestImage(SrcImage) then + raise EImagingError.Create(SErrorInvalidInputImage); + + FitSize.CX := FitWidth; + FitSize.CY := FitHeight; + CurSize.CX := SrcImage.Width; + CurSize.CY := SrcImage.Height; + DestSize := ImagingUtility.ScaleSizeToFit(CurSize, FitSize); + + NewImage(Max(DestSize.CX, 1), Max(DestSize.CY, 1), SrcImage.Format, DestImage); + if SrcImage.Palette <> nil then + CopyPalette(SrcImage.Palette, DestImage.Palette, 0, 0, ImageFormatInfos[SrcImage.Format].PaletteEntries); + + StretchRect(SrcImage, 0, 0, CurSize.CX, CurSize.CY, DestImage, 0, 0, + DestSize.CX, DestSize.CY, Filter); +end; + +{ Color constructor functions } + +function Color24(R, G, B: Byte): TColor24Rec; +begin + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function Color32(A, R, G, B: Byte): TColor32Rec; +begin + Result.A := A; + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function Color48(R, G, B: Word): TColor48Rec; +begin + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function Color64(A, R, G, B: Word): TColor64Rec; +begin + Result.A := A; + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function ColorFP(A, R, G, B: Single): TColorFPRec; +begin + Result.A := A; + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; +begin + Result.A := A; + Result.R := R; + Result.G := G; + Result.B := B; +end; + +function GetAlphaValue(Color32: TColor32): Byte; +begin + Result := Color32 shr 24; +end; + +function GetRedValue(Color32: TColor32): Byte; +begin + Result := (Color32 shr 16) and $FF; +end; + +function GetGreenValue(Color32: TColor32): Byte; +begin + Result := (Color32 shr 8) and $FF; +end; + +function GetBlueValue(Color32: TColor32): Byte; +begin + Result := Color32 and $FF; +end; + +{ ------------------------------------------------------------------------ + Other Imaging Stuff + ------------------------------------------------------------------------} + +function GetFormatName(Format: TImageFormat): string; +begin + if ImageFormatInfos[Format] <> nil then + Result := ImageFormatInfos[Format].Name + else + Result := SUnknownFormat; +end; + +function ImageToStr(const Image: TImageData): string; +var + ImgSize: Integer; +begin + if TestImage(Image) then + with Image do + begin + ImgSize := Size; + if ImgSize > 8192 then + ImgSize := ImgSize div 1024; + Result := SysUtils.Format(SImageInfo, [@Image, Width, Height, + GetFormatName(Format), ImgSize + 0.0, Iff(ImgSize = Size, 'B', 'KiB'), Bits, + Palette]); + end + else + Result := SysUtils.Format(SImageInfoInvalid, [@Image]); +end; + +function GetVersionStr: string; +begin + Result := Format('%.1d.%.2d', [ImagingVersionMajor, ImagingVersionMinor]); +end; + +function IffFormat(Condition: Boolean; const TruePart, FalsePart: TImageFormat): TImageFormat; +begin + if Condition then + Result := TruePart + else + Result := FalsePart; +end; + +procedure RegisterImageFileFormat(AClass: TImageFileFormatClass); +begin + Assert(AClass <> nil); + if ImageFileFormats = nil then + ImageFileFormats := TList.Create; + if GlobalMetadata = nil then + GlobalMetadata := TMetadata.Create; + if ImageFileFormats <> nil then + ImageFileFormats.Add(AClass.Create); +end; + +function RegisterOption(OptionId: LongInt; Variable: PLongInt): Boolean; +begin + Result := False; + if Options = nil then + InitOptions; + + Assert(Variable <> nil); + + if OptionId >= Length(Options) then + SetLength(Options, OptionId + InitialOptions); + if (OptionId >= 0) and (OptionId < Length(Options)) {and (Options[OptionId] = nil) - must be able to override existing } then + begin + Options[OptionId] := Variable; + Result := True; + end; +end; + +function FindImageFileFormatByExt(const Ext: string): TImageFileFormat; +var + I: LongInt; + SearchedExt: string; +begin + Result := nil; + SearchedExt := TrimLeftSet(Ext, ['.']); + + for I := ImageFileFormats.Count - 1 downto 0 do + if TImageFileFormat(ImageFileFormats[I]).Extensions.IndexOf(SearchedExt) >= 0 then + begin + Result := TImageFileFormat(ImageFileFormats[I]); + Exit; + end; +end; + +function FindImageFileFormatByName(const FileName: string): TImageFileFormat; +var + I: LongInt; +begin + Result := nil; + + if FileName = '' then + Exit; + + for I := ImageFileFormats.Count - 1 downto 0 do + if TImageFileFormat(ImageFileFormats[I]).TestFileName(FileName) then + begin + Result := TImageFileFormat(ImageFileFormats[I]); + Exit; + end; +end; + +function FindImageFileFormatByClass(AClass: TImageFileFormatClass): TImageFileFormat; +var + I: LongInt; +begin + Result := nil; + for I := 0 to ImageFileFormats.Count - 1 do + if TImageFileFormat(ImageFileFormats[I]) is AClass then + begin + Result := TObject(ImageFileFormats[I]) as TImageFileFormat; + Break; + end; +end; + +function GetFileFormatCount: LongInt; +begin + Result := ImageFileFormats.Count; +end; + +function GetFileFormatAtIndex(Index: LongInt): TImageFileFormat; +begin + if (Index >= 0) and (Index < ImageFileFormats.Count) then + Result := TImageFileFormat(ImageFileFormats[Index]) + else + Result := nil; +end; + +function GetImageFileFormatsFilter(OpenFileFilter: Boolean): string; +var + I, J, Count: LongInt; + Descriptions: string; + Filters, CurFilter: string; + FileFormat: TImageFileFormat; +begin + Descriptions := ''; + Filters := ''; + Count := 0; + + for I := 0 to ImageFileFormats.Count - 1 do + begin + FileFormat := TObject(ImageFileFormats[I]) as TImageFileFormat; + + // If we are creating filter for save dialog and this format cannot save + // files the we skip it + if not OpenFileFilter and not FileFormat.CanSave then + Continue; + + CurFilter := ''; + for J := 0 to FileFormat.Masks.Count - 1 do + begin + CurFilter := CurFilter + FileFormat.Masks[J]; + if J < FileFormat.Masks.Count - 1 then + CurFilter := CurFilter + ';'; + end; + + FmtStr(Descriptions, '%s%s (%s)|%2:s', [Descriptions, FileFormat.Name, CurFilter]); + if Filters <> '' then + FmtStr(Filters, '%s;%s', [Filters, CurFilter]) + else + Filters := CurFilter; + + if I < ImageFileFormats.Count - 1 then + Descriptions := Descriptions + '|'; + + Inc(Count); + end; + + if (Count > 1) and OpenFileFilter then + FmtStr(Descriptions, '%s (%s)|%1:s|%s', [SAllFilter, Filters, Descriptions]); + + Result := Descriptions; +end; + +function GetFilterIndexExtension(Index: LongInt; OpenFileFilter: Boolean): string; +var + I, Count: LongInt; + FileFormat: TImageFileFormat; +begin + // -1 because filter indices are in 1..n range + Index := Index - 1; + Result := ''; + if OpenFileFilter then + begin + if Index > 0 then + Index := Index - 1; + end; + + if (Index >= 0) and (Index < ImageFileFormats.Count) then + begin + Count := 0; + for I := 0 to ImageFileFormats.Count - 1 do + begin + FileFormat := TObject(ImageFileFormats[I]) as TImageFileFormat; + if not OpenFileFilter and not FileFormat.CanSave then + Continue; + if Index = Count then + begin + if FileFormat.Extensions.Count > 0 then + Result := FileFormat.Extensions[0]; + Exit; + end; + Inc(Count); + end; + end; +end; + +function GetFileNameFilterIndex(const FileName: string; OpenFileFilter: Boolean): LongInt; +var + I: LongInt; + FileFormat: TImageFileFormat; +begin + Result := 0; + for I := 0 to ImageFileFormats.Count - 1 do + begin + FileFormat := TObject(ImageFileFormats[I]) as TImageFileFormat; + if not OpenFileFilter and not FileFormat.CanSave then + Continue; + if FileFormat.TestFileName(FileName) then + begin + // +1 because filter indices are in 1..n range + Inc(Result); + if OpenFileFilter then + Inc(Result); + Exit; + end; + Inc(Result); + end; + Result := -1; +end; + +function GetIO: TIOFunctions; +begin + Result := IO; +end; + +procedure RaiseImaging(const Msg: string; const Args: array of const); +var + WholeMsg: string; +begin + WholeMsg := Msg; + if GetExceptObject <> nil then + begin + WholeMsg := WholeMsg + ' ' + SExceptMsg + ': ' + + GetExceptObject.Message; + end; + raise EImagingError.CreateFmt(WholeMsg, Args); +end; + +procedure RaiseImaging(const Msg: string); +begin + RaiseImaging(Msg, []); +end; + +{ Internal unit functions } + +function CheckOptionValue(OptionId, Value: LongInt): LongInt; +begin + case OptionId of + ImagingColorReductionMask: + Result := ClampInt(Value, 0, $FF); + ImagingLoadOverrideFormat, ImagingSaveOverrideFormat: + Result := Iff(ImagingFormats.IsImageFormatValid(TImageFormat(Value)), + Value, LongInt(ifUnknown)); + ImagingMipMapFilter: Result := ClampInt(Value, Ord(Low(TSamplingFilter)), + Ord(High(TSamplingFilter))); + else + Result := Value; + end; +end; + +procedure SetFileIO; +begin + IO := FileIO; +end; + +procedure SetStreamIO; +begin + IO := StreamIO; +end; + +procedure SetMemoryIO; +begin + IO := MemoryIO; +end; + +procedure InitImageFormats; +begin + ImagingFormats.InitImageFormats(ImageFormatInfos); +end; + +procedure FreeImageFileFormats; +var + I: LongInt; +begin + if ImageFileFormats <> nil then + for I := 0 to ImageFileFormats.Count - 1 do + TImageFileFormat(ImageFileFormats[I]).Free; + FreeAndNil(ImageFileFormats); +end; + +procedure InitOptions; +begin + SetLength(Options, InitialOptions); + OptionStack := TOptionStack.Create; +end; + +procedure FreeOptions; +begin + SetLength(Options, 0); + FreeAndNil(OptionStack); +end; + +{ + TImageFileFormat class implementation +} + +constructor TImageFileFormat.Create(AMetadata: TMetadata); +begin + inherited Create; + FName := SUnknownFormat; + FExtensions := TStringList.Create; + FMasks := TStringList.Create; + if AMetadata = nil then + FMetadata := GlobalMetadata + else + FMetadata := AMetadata; + Define; +end; + +destructor TImageFileFormat.Destroy; +begin + FExtensions.Free; + FMasks.Free; + inherited Destroy; +end; + +procedure TImageFileFormat.Define; +begin +end; + +function TImageFileFormat.PrepareLoad(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstFrame: Boolean): Boolean; +begin + FMetadata.ClearMetaItems; // Clear old metadata + FreeImagesInArray(Images); + SetLength(Images, 0); + Result := Handle <> nil; +end; + +function TImageFileFormat.PostLoadCheck(var Images: TDynImageDataArray; + LoadResult: Boolean): Boolean; +var + I: LongInt; +begin + if not LoadResult then + begin + FreeImagesInArray(Images); + SetLength(Images, 0); + Result := False; + end + else + begin + Result := (Length(Images) > 0) and TestImagesInArray(Images); + + if Result then + begin + // Convert to overridden format if it is set + if LoadOverrideFormat <> ifUnknown then + for I := Low(Images) to High(Images) do + ConvertImage(Images[I], LoadOverrideFormat); + end; + end; +end; + +function TImageFileFormat.PrepareSave(Handle: TImagingHandle; + const Images: TDynImageDataArray; var Index: LongInt): Boolean; +var + Len, I: LongInt; +begin + CheckOptionsValidity; + Result := False; + if CanSave then + begin + Len := Length(Images); + Assert(Len > 0); + + // If there are no images to be saved exit + if Len = 0 then Exit; + + // Check index of image to be saved (-1 as index means save all images) + if IsMultiImageFormat then + begin + if (Index >= Len) then + Index := 0; + + if Index < 0 then + begin + Index := 0; + FFirstIdx := 0; + FLastIdx := Len - 1; + end + else + begin + FFirstIdx := Index; + FLastIdx := Index; + end; + + for I := FFirstIdx to FLastIdx - 1 do + begin + if not TestImage(Images[I]) then + Exit; + end; + end + else + begin + if (Index >= Len) or (Index < 0) then + Index := 0; + if not TestImage(Images[Index]) then + Exit; + end; + + Result := True; + end; +end; + +procedure TImageFileFormat.AddMasks(const AMasks: string); +var + I: LongInt; + Ext: string; +begin + FExtensions.Clear; + FMasks.CommaText := AMasks; + FMasks.Delimiter := ';'; + + for I := 0 to FMasks.Count - 1 do + begin + FMasks[I] := Trim(FMasks[I]); + Ext := GetFileExt(FMasks[I]); + if (Ext <> '') and (Ext <> '*') then + FExtensions.Add(Ext); + end; +end; + +function TImageFileFormat.GetFormatInfo(Format: TImageFormat): TImageFormatInfo; +begin + Result := ImageFormatInfos[Format]^; +end; + +function TImageFileFormat.GetSupportedFormats: TImageFormats; +begin + Result := FSupportedFormats; +end; + +function TImageFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstFrame: Boolean): Boolean; +begin + Result := False; + RaiseImaging(SFileFormatCanNotLoad, [FName]); +end; + +function TImageFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +begin + Result := False; + RaiseImaging(SFileFormatCanNotSave, [FName]); +end; + +procedure TImageFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +begin +end; + +function TImageFileFormat.IsSupported(const Image: TImageData): Boolean; +begin + Result := Image.Format in GetSupportedFormats; +end; + +function TImageFileFormat.LoadFromFile(const FileName: string; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + Handle: TImagingHandle; +begin + Result := False; + if CanLoad then + try + // Set IO ops to file ops and open given file + SetFileIO; + Handle := IO.Open(PChar(FileName), omReadOnly); + try + // Test if file contains valid image and if so then load it + if TestFormat(Handle) then + begin + Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and + LoadData(Handle, Images, OnlyFirstLevel); + Result := PostLoadCheck(Images, Result); + end + else + RaiseImaging(SFileNotValid, [FileName, Name]); + finally + IO.Close(Handle); + end; + except + RaiseImaging(SErrorLoadingFile, [FileName, FExtensions[0]]); + end; +end; + +function TImageFileFormat.LoadFromStream(Stream: TStream; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + Handle: TImagingHandle; + OldPosition: Int64; +begin + Result := False; + OldPosition := Stream.Position; + if CanLoad then + try + // Set IO ops to stream ops and "open" given memory + SetStreamIO; + Handle := IO.Open(Pointer(Stream), omReadOnly); + try + // Test if stream contains valid image and if so then load it + if TestFormat(Handle) then + begin + Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and + LoadData(Handle, Images, OnlyFirstLevel); + Result := PostLoadCheck(Images, Result); + end + else + RaiseImaging(SStreamNotValid, [@Stream, Name]); + finally + IO.Close(Handle); + end; + except + Stream.Position := OldPosition; + FreeImagesInArray(Images); + RaiseImaging(SErrorLoadingStream, [@Stream, FExtensions[0]]); + end; +end; + +function TImageFileFormat.LoadFromMemory(Data: Pointer; Size: LongInt; var + Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + Handle: TImagingHandle; + IORec: TMemoryIORec; +begin + Result := False; + if CanLoad then + try + // Set IO ops to memory ops and "open" given memory + SetMemoryIO; + IORec := PrepareMemIO(Data, Size); + Handle := IO.Open(@IORec,omReadOnly); + try + // Test if memory contains valid image and if so then load it + if TestFormat(Handle) then + begin + Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and + LoadData(Handle, Images, OnlyFirstLevel); + Result := PostLoadCheck(Images, Result); + end + else + RaiseImaging(SMemoryNotValid, [Data, Size, Name]); + finally + IO.Close(Handle); + end; + except + RaiseImaging(SErrorLoadingMemory, [Data, Size, FExtensions[0]]); + end; +end; + +function TImageFileFormat.SaveToFile(const FileName: string; + const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + Handle: TImagingHandle; + Len, Index, I: LongInt; + Ext, FName: string; +begin + Result := False; + if CanSave and TestImagesInArray(Images) then + try + SetFileIO; + Len := Length(Images); + if IsMultiImageFormat or + (not IsMultiImageFormat and (OnlyFirstLevel or (Len = 1))) then + begin + Handle := IO.Open(PChar(FileName), GetSaveOpenMode); + try + if OnlyFirstLevel then + Index := 0 + else + Index := -1; + // Write multi image to one file + Result := PrepareSave(Handle, Images, Index) and SaveData(Handle, Images, Index); + finally + IO.Close(Handle); + end; + end + else + begin + // Write multi image to file sequence + Ext := ExtractFileExt(FileName); + FName := ChangeFileExt(FileName, ''); + Result := True; + for I := 0 to Len - 1 do + begin + Handle := IO.Open(PChar(Format(FName + '%.3d' + Ext, [I])), GetSaveOpenMode); + try + Index := I; + Result := Result and PrepareSave(Handle, Images, Index) and + SaveData(Handle, Images, Index); + if not Result then + Break; + finally + IO.Close(Handle); + end; + end; + end; + except + raise UpdateExceptMessage(GetExceptObject, SErrorSavingFile, [FileName, FExtensions[0]]); + end; +end; + +function TImageFileFormat.SaveToStream(Stream: TStream; + const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + Handle: TImagingHandle; + Len, Index, I: LongInt; + OldPosition: Int64; +begin + Result := False; + OldPosition := Stream.Position; + if CanSave and TestImagesInArray(Images) then + try + SetStreamIO; + Handle := IO.Open(PChar(Stream), GetSaveOpenMode); + try + if IsMultiImageFormat or OnlyFirstLevel then + begin + if OnlyFirstLevel then + Index := 0 + else + Index := -1; + // Write multi image in one run + Result := PrepareSave(Handle, Images, Index) and SaveData(Handle, Images, Index); + end + else + begin + // Write multi image to sequence + Result := True; + Len := Length(Images); + for I := 0 to Len - 1 do + begin + Index := I; + Result := Result and PrepareSave(Handle, Images, Index) and + SaveData(Handle, Images, Index); + if not Result then + Break; + end; + end; + finally + IO.Close(Handle); + end; + except + Stream.Position := OldPosition; + raise UpdateExceptMessage(GetExceptObject, SErrorSavingStream, [@Stream, FExtensions[0]]); + end; +end; + +function TImageFileFormat.SaveToMemory(Data: Pointer; var Size: LongInt; + const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + Handle: TImagingHandle; + Len, Index, I: LongInt; + IORec: TMemoryIORec; +begin + Result := False; + if CanSave and TestImagesInArray(Images) then + try + SetMemoryIO; + IORec := PrepareMemIO(Data, Size); + Handle := IO.Open(PChar(@IORec), GetSaveOpenMode); + try + if IsMultiImageFormat or OnlyFirstLevel then + begin + if OnlyFirstLevel then + Index := 0 + else + Index := -1; + // Write multi image in one run + Result := PrepareSave(Handle, Images, Index) and SaveData(Handle, Images, Index); + end + else + begin + // Write multi image to sequence + Result := True; + Len := Length(Images); + for I := 0 to Len - 1 do + begin + Index := I; + Result := Result and PrepareSave(Handle, Images, Index) and + SaveData(Handle, Images, Index); + if not Result then + Break; + end; + end; + Size := IORec.Position; + finally + IO.Close(Handle); + end; + except + raise UpdateExceptMessage(GetExceptObject, SErrorSavingMemory, [Data, Size, FExtensions[0]]); + end; +end; + +function TImageFileFormat.MakeCompatible(const Image: TImageData; + var Compatible: TImageData; out MustBeFreed: Boolean): Boolean; +begin + InitImage(Compatible); + + if SaveOverrideFormat <> ifUnknown then + begin + // Save format override is active. Clone input and convert it to override format. + CloneImage(Image, Compatible); + ConvertImage(Compatible, SaveOverrideFormat); + // Now check if override format is supported by file format. If it is not + // then file format specific conversion (virtual method) is called. + Result := IsSupported(Compatible); + if not Result then + begin + ConvertToSupported(Compatible, GetFormatInfo(Compatible.Format)); + Result := IsSupported(Compatible); + end; + end // Add IsCompatible function! not only checking by Format + else if IsSupported(Image) then + begin + // No save format override and input is in format supported by this + // file format. Just copy Image's fields to Compatible + Compatible := Image; + Result := True; + end + else + begin + // No override and input's format is not compatible with file format. + // Clone it and the call file format specific conversion (virtual method). + CloneImage(Image, Compatible); + ConvertToSupported(Compatible, GetFormatInfo(Compatible.Format)); + Result := IsSupported(Compatible); + end; + // Tell the user that he must free Compatible after he's done with it + // (if necessary). + MustBeFreed := Image.Bits <> Compatible.Bits; +end; + +function TImageFileFormat.TestFormat(Handle: TImagingHandle): Boolean; +begin + Result := False; +end; + +function TImageFileFormat.TestFileName(const FileName: string): Boolean; +var + I: LongInt; + OnlyName: string; +begin + OnlyName := ExtractFileName(FileName); + // For each mask test if filename matches it + for I := 0 to FMasks.Count - 1 do + if StrMaskMatch(OnlyName, FMasks[I], False) then + begin + Result := True; + Exit; + end; + Result := False; +end; + +procedure TImageFileFormat.CheckOptionsValidity; +begin +end; + +function TImageFileFormat.GetCanLoad: Boolean; +begin + Result := ffLoad in FFeatures; +end; + +function TImageFileFormat.GetCanSave: Boolean; +begin + Result := ffSave in FFeatures; +end; + +function TImageFileFormat.GetIsMultiImageFormat: Boolean; +begin + Result := ffMultiImage in FFeatures; +end; + +function TImageFileFormat.GetSaveOpenMode: TOpenMode; +begin + // TODO: fix + //if ffReadOnSave in FFeatures then + // Result := omReadWrite + //else + Result := omCreate; +end; + +{ TOptionStack class implementation } + +constructor TOptionStack.Create; +begin + inherited Create; + FPosition := -1; +end; + +destructor TOptionStack.Destroy; +var + I: LongInt; +begin + for I := 0 to OptionStackDepth - 1 do + SetLength(FStack[I], 0); + inherited Destroy; +end; + +function TOptionStack.Pop: Boolean; +var + I: LongInt; +begin + Result := False; + if FPosition >= 0 then + begin + SetLength(Options, Length(FStack[FPosition])); + for I := 0 to Length(FStack[FPosition]) - 1 do + if Options[I] <> nil then + Options[I]^ := FStack[FPosition, I]; + Dec(FPosition); + Result := True; + end; +end; + +function TOptionStack.Push: Boolean; +var + I: LongInt; +begin + Result := False; + if FPosition < OptionStackDepth - 1 then + begin + Inc(FPosition); + SetLength(FStack[FPosition], Length(Options)); + for I := 0 to Length(Options) - 1 do + if Options[I] <> nil then + FStack[FPosition, I] := Options[I]^; + Result := True; + end; +end; + +{ TMetadata } + +procedure TMetadata.SetMetaItem(const Id: string; const Value: Variant; + ImageIndex: Integer); +begin + AddMetaToList(FLoadMetaItems, Id, Value, ImageIndex); +end; + +procedure TMetadata.SetMetaItemForSaving(const Id: string; const Value: Variant; + ImageIndex: Integer); +begin + AddMetaToList(FSaveMetaItems, Id, Value, ImageIndex); +end; + +procedure TMetadata.AddMetaToList(List: TStringList; const Id: string; + const Value: Variant; ImageIndex: Integer); +var + Item: TMetadataItem; + Idx: Integer; + FullId: string; +begin + FullId := GetMetaItemName(Id, ImageIndex); + if List.Find(FullId, Idx) then + (List.Objects[Idx] as TMetadataItem).Value := Value + else + begin + Item := TMetadataItem.Create; + Item.Id := Id; + Item.ImageIndex := ImageIndex; + Item.Value := Value; + List.AddObject(FullId, Item); + end; +end; + +procedure TMetadata.ClearMetaItems; +begin + ClearMetaList(FLoadMetaItems); +end; + +procedure TMetadata.ClearMetaItemsForSaving; +begin + ClearMetaList(FSaveMetaItems); +end; + +procedure TMetadata.ClearMetaList(List: TStringList); +var + I: Integer; +begin + for I := 0 to List.Count - 1 do + List.Objects[I].Free; + List.Clear; +end; + +procedure TMetadata.CopyLoadedMetaItemsForSaving; +var + I: Integer; + Copy, Orig: TMetadataItem; +begin + ClearMetaItemsForSaving; + for I := 0 to FLoadMetaItems.Count - 1 do + begin + Orig := TMetadataItem(FLoadMetaItems.Objects[I]); + Copy := TMetadataItem.Create; + Copy.Id := Orig.Id; + Copy.ImageIndex := Orig.ImageIndex; + Copy.Value := Orig.Value; + FSaveMetaItems.AddObject(GetMetaItemName(Copy.Id, Copy.ImageIndex), Copy); + end; +end; + +constructor TMetadata.Create; +begin + inherited; + FLoadMetaItems := TStringList.Create; + FLoadMetaItems.Sorted := True; + FSaveMetaItems := TStringList.Create; + FSaveMetaItems.Sorted := True; +end; + +destructor TMetadata.Destroy; +begin + ClearMetaItems; + ClearMetaItemsForSaving; + FLoadMetaItems.Free; + FSaveMetaItems.Free; + inherited; +end; + +function TMetadata.GetMetaById(const Id: string): Variant; +var + Idx: Integer; +begin + if FLoadMetaItems.Find(Id, Idx) then + Result := (FLoadMetaItems.Objects[Idx] as TMetadataItem).Value + else + Result := Variants.Null; +end; + +function TMetadata.GetMetaByIdMulti(const Id: string; ImageIndex: Integer): Variant; +begin + Result := GetMetaById(GetMetaItemName(Id, ImageIndex)); +end; + +function TMetadata.GetSaveMetaById(const Id: string): Variant; +var + Idx: Integer; +begin + if FSaveMetaItems.Find(Id, Idx) then + Result := (FSaveMetaItems.Objects[Idx] as TMetadataItem).Value + else + Result := Variants.Null; +end; + +function TMetadata.GetSaveMetaByIdMulti(const Id: string; + ImageIndex: Integer): Variant; +begin + Result := GetSaveMetaById(GetMetaItemName(Id, ImageIndex)); +end; + +function TMetadata.GetMetaByIdx(Index: Integer): TMetadataItem; +begin + Result := FLoadMetaItems.Objects[Index] as TMetadataItem; +end; + +function TMetadata.GetMetaCount: Integer; +begin + Result := FLoadMetaItems.Count; +end; + +function TMetadata.GetMetaItemName(const Id: string; + ImageIndex: Integer): string; +begin + Result := Iff(ImageIndex = 0, Id, Format(SMetaIdForSubImage, [Id, ImageIndex])); +end; + +function TMetadata.GetPhysicalPixelSize(ResUnit: TResolutionUnit; out XSize, + YSize: Double; MetaForSave: Boolean; ImageIndex: Integer): Boolean; +type + TGetter = function(const Id: string; ImageIndex: Integer): Variant of object; +var + Getter: TGetter; + XMeta, YMeta: Variant; +begin + if MetaForSave then + Getter := GetSaveMetaByIdMulti + else + Getter := GetMetaByIdMulti; + + XMeta := Getter(SMetaPhysicalPixelSizeX, ImageIndex); + YMeta := Getter(SMetaPhysicalPixelSizeY, ImageIndex); + XSize := -1; + YSize := -1; + + Result := not VarIsNull(XMeta) or not VarIsNull(YMeta); + + if not Result then + Exit; + + if not VarIsNull(XMeta) then + XSize := XMeta; + if not VarIsNull(YMeta) then + YSize := YMeta; + + if XSize < 0 then + XSize := YSize; + if YSize < 0 then + YSize := XSize; + + TranslateUnits(ResUnit, XSize, YSize); +end; + +procedure TMetadata.SetPhysicalPixelSize(ResUnit: TResolutionUnit; XSize, + YSize: Double; MetaForSave: Boolean; ImageIndex: Integer); +type + TAdder = procedure(const Id: string; const Value: Variant; ImageIndex: Integer) of object; +var + Adder: TAdder; +begin + TranslateUnits(ResUnit, XSize, YSize); + + if MetaForSave then + Adder := SetMetaItemForSaving + else + Adder := SetMetaItem; + + Adder(SMetaPhysicalPixelSizeX, XSize, ImageIndex); + Adder(SMetaPhysicalPixelSizeY, YSize, ImageIndex); +end; + +procedure TMetadata.TranslateUnits(ResolutionUnit: TResolutionUnit; var XRes, + YRes: Double); +var + UnitSize: Double; +begin + case ResolutionUnit of + ruDpi: UnitSize := 25400; + ruDpm: UnitSize := 1e06; + ruDpcm: UnitSize := 1e04; + else + UnitSize := 1; + end; + if ResolutionUnit <> ruSizeInMicroMeters then + begin + XRes := UnitSize / XRes; + YRes := UnitSize / YRes; + end; +end; + +function TMetadata.HasMetaItem(const Id: string; ImageIndex: Integer): Boolean; +begin + Result := GetMetaByIdMulti(Id, ImageIndex) <> Variants.Null; +end; + +function TMetadata.HasMetaItemForSaving(const Id: string; ImageIndex: Integer): Boolean; +begin + Result := GetSaveMetaByIdMulti(Id, ImageIndex) <> Variants.Null; +end; + +initialization +{$IFDEF MEMCHECK} + {$IF CompilerVersion >= 18} + System.ReportMemoryLeaksOnShutdown := True; + {$IFEND} +{$ENDIF} + if GlobalMetadata = nil then + GlobalMetadata := TMetadata.Create; + if ImageFileFormats = nil then + ImageFileFormats := TList.Create; + InitImageFormats; + RegisterOption(ImagingColorReductionMask, @ColorReductionMask); + RegisterOption(ImagingLoadOverrideFormat, @LoadOverrideFormat); + RegisterOption(ImagingSaveOverrideFormat, @SaveOverrideFormat); + RegisterOption(ImagingMipMapFilter, @MipMapFilter); + RegisterOption(ImagingBinaryThreshold, @BinaryThreshold); +finalization + FreeOptions; + FreeImageFileFormats; + GlobalMetadata.Free; + +{ + File Notes (obsolete): + + -- 0.80 ------------------------------------------------------ + - Added new color records constructor functions (Color24(..), Color32(..)). + - Added convenience channel getters for TColor32 (GetGreenValue, ...). + + -- 0.77.1 --------------------------------------------------- + - Updated IO Open functions according to changes in ImagingTypes. + - Fixed bug in SplitImage that could cause wrong size of edge chunks. + - Metadata support fixes and extensions (frame delays, animation loops). + + -- 0.26.5 Changes/Bug Fixes --------------------------------- + - Started reworking exception raising to keep the original class type + (e.g. in NewImage EOutOfMemory could be raised but was hidden + by EImagingError raised afterwards in NewImage try/except). + - Fixed possible AV in Rotate45 subproc of RotateImage. + - Added ReadRawXXX and WriteRawXXX functions for raw image bits IO. + - Implemented ImagingBinaryThreshold option. + - Added support for simple image metadata loading/saving. + - Moved file format definition (name, exts, caps, ...) from + constructor to new Define method. + - Fixed some memory leaks caused by failures during image loading. + + -- 0.26.3 Changes/Bug Fixes --------------------------------- + - Extended RotateImage to allow arbitrary angle rotations. + - Reversed the order file formats list is searched so + if you register a new one it will be found sooner than + built in formats. + - Fixed memory leak in ResizeImage occurring when resizing + indexed images. + + -- 0.26.1 Changes/Bug Fixes --------------------------------- + - Added position/size checks to LoadFromStream functions. + - Changed conditional compilation in impl. uses section to reflect changes + in LINK symbols. + + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - GenerateMipMaps now generates all smaller levels from + original big image (better results when using more advanced filters). + Also conversion to compatible image format is now done here not + in FillMipMapLevel (that is called for every mipmap level). + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - MakePaletteForImages now works correctly for indexed and special format images + - Fixed bug in StretchRect: Image was not properly stretched if + src and dst dimensions differed only in height. + - ConvertImage now fills new image with zeroes to avoid random data in + some conversions (RGB->XRGB) + - Changed RegisterOption procedure to function + - Changed bunch of palette functions from low level interface to procedure + (there was no reason for them to be functions). + - Changed FreeImage and FreeImagesInArray functions to procedures. + - Added many assertions, come try-finally, other checks, and small code + and doc changes. + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - GenerateMipMaps threw failed assertion when input was indexed or special, + fixed. + - Added CheckOptionsValidity to TImageFileFormat and its descendants. + - Unit ImagingExtras which registers file formats in Extras package + is now automatically added to uses clause if LINK_EXTRAS symbol is + defined in ImagingOptions.inc file. + - Added EnumFileFormats function to low level interface. + - Fixed bug in SwapChannels which could cause AV when swapping alpha + channel of A8R8G8B8 images. + - Converting loaded images to ImagingOverrideFormat is now done + in PostLoadCheck method to avoid code duplicity. + - Added GetFileFormatCount and GetFileFormatAtIndex functions + - Bug in ConvertImage: if some format was converted to similar format + only with swapped channels (R16G16B16<>B16G16R16) then channels were + swapped correctly but new data format (swapped one) was not set. + - Made TImageFileFormat.MakeCompatible public non-virtual method + (and modified its function). Created new virtual + ConvertToSupported which should be overridden by descendants. + Main reason for doing this is to avoid duplicate code that was in all + TImageFileFormat's descendants. + - Changed TImageFileFormat.GetFormatInfo's result type to TImageFormatInfo. + - Split overloaded FindImageFileFormat functions to + FindImageFileFormatByClass and FindImageFileFormatByExt and created new + FindImageFileFormatByName which operates on whole filenames. + - Function GetExtensionFilterIndex renamed to GetFileNameFilterIndex + (because it now works with filenames not extensions). + - DetermineFileFormat now first searches by filename and if not found + then by data. + - Added TestFileName method to TImageFileFormat. + - Updated GetImageFileFormatsFilter to uses Masks instead of Extensions + property of TImageFileFormat. Also you can now request + OpenDialog and SaveDialog type filters + - Added Masks property and AddMasks method to TImageFileFormat. + AddMasks replaces AddExtensions, it uses filename masks instead + of some filename extensions to identify supported files. + - Changed TImageFileFormat.LoadData procedure to function and + moved various duplicate code from its descendants (check index,...) + here to TImageFileFormat helper methods. + - Changed TImageFileFormat.SaveData procedure to function and + moved various duplicate code from its descendants (check index,...) + here to TImageFileFormat helper methods. + - Removed RAISE_EXCEPTIONS define, exceptions are now raised every time + - Added MustBeFreed parameter to TImageFileFormat.MakeCompatible method + that indicates that compatible image returned by this method must be + freed after its usage. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - fixed bug in NewImage: if given format was ifDefault it wasn't + replaced with DefaultImageFormat constant which caused problems later + in other units + - fixed bug in RotateImage which caused that rotated special format + images were whole black + - LoadImageFromXXX and LoadMultiImageFromXXX now use DetermineXXXFormat + when choosing proper loader, this eliminated need for Ext parameter + in stream and memory loading functions + - added GetVersionStr function + - fixed bug in ResizeImage which caused indexed images to lose their + palette during process resulting in whole black image + - Clipping in ...Rect functions now uses clipping procs from ImagingUtility, + it also works better + - FillRect optimization for 8, 16, and 32 bit formats + - added pixel set/get functions to low level interface: + GetPixelDirect, SetPixelDirect, GetPixel32, SetPixel32, + GetPixelFP, SetPixelFP + - removed GetPixelBytes low level intf function - redundant + (same data can be obtained by GetImageFormatInfo) + - made small changes in many parts of library to compile + on AMD64 CPU (Linux with FPC) + - changed InitImage to procedure (function was pointless) + - Method TestFormat of TImageFileFormat class made public + (was protected) + - added function IsFileFormatSupported to low level interface + (contributed by Paul Michell) + - fixed some missing format arguments from error strings + which caused Format function to raise exception + - removed forgotten debug code that disabled filtered resizing of images with + channel bitcounts > 8 + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - changed order of parameters of CopyRect function + - GenerateMipMaps now filters mipmap levels + - ResizeImage functions was extended to allow bilinear and bicubic filtering + - added StretchRect function to low level interface + - added functions GetImageFileFormatsFilter, GetFilterIndexExtension, + and GetExtensionFilterIndex + + -- 0.15 Changes/Bug Fixes ----------------------------------- + - added function RotateImage to low level interface + - moved TImageFormatInfo record and types required by it to + ImagingTypes unit, changed GetImageFormatInfo low level + interface function to return TImageFormatInfo instead of short info + - added checking of options values validity before they are used + - fixed possible memory leak in CloneImage + - added ReplaceColor function to low level interface + - new function FindImageFileFormat by class added + + -- 0.13 Changes/Bug Fixes ----------------------------------- + - added DetermineFileFormat, DetermineStreamFormat, DetermineMemoryFormat, + GetPixelsSize functions to low level interface + - added NewPalette, CopyPalette, FreePalette functions + to low level interface + - added MapImageToPalette, FillRect, SplitImage, MakePaletteForImages + functions to low level interface + - fixed buggy FillCustomPalette function (possible div by zero and others) + - added CopyRect function to low level interface + - Member functions of TImageFormatInfo record implemented for all formats + - before saving images TestImagesInArray is called now + - added TestImagesInArray function to low level interface + - added GenerateMipMaps function to low level interface + - stream position in load/save from/to stream is now set to position before + function was called if error occurs + - when error occurred during load/save from/to file file handle + was not released + - CloneImage returned always False + +} +end. + diff --git a/Imaging/ImagingBitmap.pas b/Imaging/ImagingBitmap.pas index 771a698..d3ff4e2 100644 --- a/Imaging/ImagingBitmap.pas +++ b/Imaging/ImagingBitmap.pas @@ -1,857 +1,840 @@ -{ - $Id: ImagingBitmap.pas 129 2008-08-06 20:01:30Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains image format loader/saver for Windows Bitmap images.} -unit ImagingBitmap; - -{$I ImagingOptions.inc} - -interface - -uses - ImagingTypes, Imaging, ImagingUtility, ImagingFormats, ImagingIO; - -type - { Class for loading and saving Windows Bitmap images. - It can load/save 8bit indexed, 16, 24, 32 bit RGB or ARGB - images with or without RLE compression. It can also load 1/4 bit - indexed images and OS2 bitmaps.} - TBitmapFileFormat = class(TImageFileFormat) - protected - FUseRLE: LongBool; - function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean): Boolean; override; - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); override; - public - constructor Create; override; - function TestFormat(Handle: TImagingHandle): Boolean; override; - published - { Controls that RLE compression is used during saving. Accessible trough - ImagingBitmapRLE option.} - property UseRLE: LongBool read FUseRLE write FUseRLE; - end; - -implementation - -const - SBitmapFormatName = 'Windows Bitmap Image'; - SBitmapMasks = '*.bmp,*.dib'; - BitmapSupportedFormats: TImageFormats = [ifIndex8, ifA1R5G5B5, ifA4R4G4B4, - ifR5G6B5, ifR8G8B8, ifA8R8G8B8, ifX1R5G5B5, ifX4R4G4B4, ifX8R8G8B8]; - BitmapDefaultRLE = True; - -const - { Bitmap file identifier 'BM'.} - BMMagic: Word = 19778; - - { Constants for the TBitmapInfoHeader.Compression field.} - BI_RGB = 0; - BI_RLE8 = 1; - BI_RLE4 = 2; - BI_BITFIELDS = 3; - - V3InfoHeaderSize = 40; - V4InfoHeaderSize = 108; - -type - { File Header for Windows/OS2 bitmap file.} - TBitmapFileHeader = packed record - ID: Word; // Is always 19778 : 'BM' - Size: LongWord; // Filesize - Reserved1: Word; - Reserved2: Word; - Offset: LongWord; // Offset from start pos to beginning of image bits - end; - - { Info Header for Windows bitmap file version 4.} - TBitmapInfoHeader = packed record - Size: LongWord; - Width: LongInt; - Height: LongInt; - Planes: Word; - BitCount: Word; - Compression: LongWord; - SizeImage: LongWord; - XPelsPerMeter: LongInt; - YPelsPerMeter: LongInt; - ClrUsed: LongInt; - ClrImportant: LongInt; - RedMask: LongWord; - GreenMask: LongWord; - BlueMask: LongWord; - AlphaMask: LongWord; - CSType: LongWord; - EndPoints: array[0..8] of LongWord; - GammaRed: LongWord; - GammaGreen: LongWord; - GammaBlue: LongWord; - end; - - { Info Header for OS2 bitmaps.} - TBitmapCoreHeader = packed record - Size: LongWord; - Width: Word; - Height: Word; - Planes: Word; - BitCount: Word; - end; - - { Used in RLE encoding and decoding.} - TRLEOpcode = packed record - Count: Byte; - Command: Byte; - end; - PRLEOpcode = ^TRLEOpcode; - -{ TBitmapFileFormat class implementation } - -constructor TBitmapFileFormat.Create; -begin - inherited Create; - FName := SBitmapFormatName; - FCanLoad := True; - FCanSave := True; - FIsMultiImageFormat := False; - FSupportedFormats := BitmapSupportedFormats; - - FUseRLE := BitmapDefaultRLE; - - AddMasks(SBitmapMasks); - RegisterOption(ImagingBitmapRLE, @FUseRLE); -end; - -function TBitmapFileFormat.LoadData(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - BF: TBitmapFileHeader; - BI: TBitmapInfoHeader; - BC: TBitmapCoreHeader; - IsOS2: Boolean; - PalRGB: PPalette24; - I, FPalSize, AlignedSize, StartPos, HeaderSize, AlignedWidthBytes, WidthBytes: LongInt; - Info: TImageFormatInfo; - Data: Pointer; - - procedure LoadRGB; - var - I: LongInt; - LineBuffer: PByte; - begin - with Images[0], GetIO do - begin - // If BI.Height is < 0 then image data are stored non-flipped - // but default in windows is flipped so if Height is positive we must - // flip it - - if BI.BitCount < 8 then - begin - // For 1 and 4 bit images load aligned data, they will be converted to - // 8 bit and unaligned later - GetMem(Data, AlignedSize); - - if BI.Height < 0 then - Read(Handle, Data, AlignedSize) - else - for I := Height - 1 downto 0 do - Read(Handle, @PByteArray(Data)[I * AlignedWidthBytes], AlignedWidthBytes); - end - else - begin - // Images with pixels of size >= 1 Byte are read line by line and - // copied to image bits without padding bytes - GetMem(LineBuffer, AlignedWidthBytes); - try - if BI.Height < 0 then - for I := 0 to Height - 1 do - begin - Read(Handle, LineBuffer, AlignedWidthBytes); - Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes); - end - else - for I := Height - 1 downto 0 do - begin - Read(Handle, LineBuffer, AlignedWidthBytes); - Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes); - end; - finally - FreeMemNil(LineBuffer); - end; - end; - end; - end; - - procedure LoadRLE4; - var - RLESrc: PByteArray; - Row, Col, WriteRow, I: LongInt; - SrcPos: LongWord; - DeltaX, DeltaY, Low, High: Byte; - Pixels: PByteArray; - OpCode: TRLEOpcode; - NegHeightBitmap: Boolean; - begin - GetMem(RLESrc, BI.SizeImage); - GetIO.Read(Handle, RLESrc, BI.SizeImage); - with Images[0] do - try - Low := 0; - Pixels := Bits; - SrcPos := 0; - NegHeightBitmap := BI.Height < 0; - Row := 0; // Current row in dest image - Col := 0; // Current column in dest image - // Row in dest image where actuall writting will be done - WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row); - while (Row < Height) and (SrcPos < BI.SizeImage) do - begin - // Read RLE op-code - OpCode := PRLEOpcode(@RLESrc[SrcPos])^; - Inc(SrcPos, SizeOf(OpCode)); - if OpCode.Count = 0 then - begin - // A byte Count of zero means that this is a special - // instruction. - case OpCode.Command of - 0: - begin - // Move to next row - Inc(Row); - WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row); - Col := 0; - end ; - 1: Break; // Image is finished - 2: - begin - // Move to a new relative position - DeltaX := RLESrc[SrcPos]; - DeltaY := RLESrc[SrcPos + 1]; - Inc(SrcPos, 2); - Inc(Col, DeltaX); - Inc(Row, DeltaY); - end - else - // Do not read data after EOF - if SrcPos + OpCode.Command > BI.SizeImage then - OpCode.Command := BI.SizeImage - SrcPos; - // Take padding bytes and nibbles into account - if Col + OpCode.Command > Width then - OpCode.Command := Width - Col; - // Store absolute data. Command code is the - // number of absolute bytes to store - for I := 0 to OpCode.Command - 1 do - begin - if (I and 1) = 0 then - begin - High := RLESrc[SrcPos] shr 4; - Low := RLESrc[SrcPos] and $F; - Pixels[WriteRow * Width + Col] := High; - Inc(SrcPos); - end - else - Pixels[WriteRow * Width + Col] := Low; - Inc(Col); - end; - // Odd number of bytes is followed by a pad byte - if (OpCode.Command mod 4) in [1, 2] then - Inc(SrcPos); - end; - end - else - begin - // Take padding bytes and nibbles into account - if Col + OpCode.Count > Width then - OpCode.Count := Width - Col; - // Store a run of the same color value - for I := 0 to OpCode.Count - 1 do - begin - if (I and 1) = 0 then - Pixels[WriteRow * Width + Col] := OpCode.Command shr 4 - else - Pixels[WriteRow * Width + Col] := OpCode.Command and $F; - Inc(Col); - end; - end; - end; - finally - FreeMem(RLESrc); - end; - end; - - procedure LoadRLE8; - var - RLESrc: PByteArray; - SrcCount, Row, Col, WriteRow: LongInt; - SrcPos: LongWord; - DeltaX, DeltaY: Byte; - Pixels: PByteArray; - OpCode: TRLEOpcode; - NegHeightBitmap: Boolean; - begin - GetMem(RLESrc, BI.SizeImage); - GetIO.Read(Handle, RLESrc, BI.SizeImage); - with Images[0] do - try - Pixels := Bits; - SrcPos := 0; - NegHeightBitmap := BI.Height < 0; - Row := 0; // Current row in dest image - Col := 0; // Current column in dest image - // Row in dest image where actuall writting will be done - WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row); - while (Row < Height) and (SrcPos < BI.SizeImage) do - begin - // Read RLE op-code - OpCode := PRLEOpcode(@RLESrc[SrcPos])^; - Inc(SrcPos, SizeOf(OpCode)); - if OpCode.Count = 0 then - begin - // A byte Count of zero means that this is a special - // instruction. - case OpCode.Command of - 0: - begin - // Move to next row - Inc(Row); - WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row); - Col := 0; - end ; - 1: Break; // Image is finished - 2: - begin - // Move to a new relative position - DeltaX := RLESrc[SrcPos]; - DeltaY := RLESrc[SrcPos + 1]; - Inc(SrcPos, 2); - Inc(Col, DeltaX); - Inc(Row, DeltaY); - end - else - SrcCount := OpCode.Command; - // Do not read data after EOF - if SrcPos + OpCode.Command > BI.SizeImage then - OpCode.Command := BI.SizeImage - SrcPos; - // Take padding bytes into account - if Col + OpCode.Command > Width then - OpCode.Command := Width - Col; - // Store absolute data. Command code is the - // number of absolute bytes to store - Move(RLESrc[SrcPos], Pixels[WriteRow * Width + Col], OpCode.Command); - Inc(SrcPos, SrcCount); - Inc(Col, OpCode.Command); - // Odd number of bytes is followed by a pad byte - if (SrcCount mod 2) = 1 then - Inc(SrcPos); - end; - end - else - begin - // Take padding bytes into account - if Col + OpCode.Count > Width then - OpCode.Count := Width - Col; - // Store a run of the same color value. Count is number of bytes to store - FillChar(Pixels [WriteRow * Width + Col], OpCode.Count, OpCode.Command); - Inc(Col, OpCode.Count); - end; - end; - finally - FreeMem(RLESrc); - end; - end; - -begin - Data := nil; - SetLength(Images, 1); - with GetIO, Images[0] do - try - FillChar(BI, SizeOf(BI), 0); - StartPos := Tell(Handle); - Read(Handle, @BF, SizeOf(BF)); - Read(Handle, @BI.Size, SizeOf(BI.Size)); - IsOS2 := BI.Size = SizeOf(TBitmapCoreHeader); - - // Bitmap Info reading - if IsOS2 then - begin - // OS/2 type bitmap, reads info header without 4 already read bytes - Read(Handle, @PByteArray(@BC)[SizeOf(BI.Size)], - SizeOf(TBitmapCoreHeader) - SizeOf(BI.Size)); - with BI do - begin - ClrUsed := 0; - Compression := BI_RGB; - BitCount := BC.BitCount; - Height := BC.Height; - Width := BC.Width; - end; - end - else - begin - // Windows type bitmap - HeaderSize := Min(BI.Size - SizeOf(BI.Size), SizeOf(BI) - SizeOf(BI.Size)); // do not read more than size of BI! - Read(Handle, @PByteArray(@BI)[SizeOf(BI.Size)], HeaderSize); - // SizeImage can be 0 for BI_RGB images, but it is here because of: - // I saved 8bit bitmap in Paint Shop Pro 8 as OS2 RLE compressed. - // It wrote strange 64 Byte Info header with SizeImage set to 0 - // Some progs were able to open it, some were not. - if BI.SizeImage = 0 then - BI.SizeImage := BF.Size - BF.Offset; - end; - // Bit mask reading. Only read it if there is V3 header, V4 header has - // masks laoded already (only masks for RGB in V3). - if (BI.Compression = BI_BITFIELDS) and (BI.Size = V3InfoHeaderSize) then - Read(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3); - - case BI.BitCount of - 1, 4, 8: Format := ifIndex8; - 16: - if BI.RedMask = $0F00 then - // Set XRGB4 or ARGB4 according to value of alpha mask - Format := IffFormat(BI.AlphaMask = 0, ifX4R4G4B4, ifA4R4G4B4) - else if BI.RedMask = $F800 then - Format := ifR5G6B5 - else - // R5G5B5 is default 16bit format (with Compression = BI_RGB or masks). - // We set it to A1.. and later there is a check if there are any alpha values - // and if not it is changed to X1R5G5B5 - Format := ifA1R5G5B5; - 24: Format := ifR8G8B8; - 32: Format := ifA8R8G8B8; // As with R5G5B5 there is alpha check later - end; - - NewImage(BI.Width, Abs(BI.Height), Format, Images[0]); - Info := GetFormatInfo(Format); - WidthBytes := Width * Info.BytesPerPixel; - AlignedWidthBytes := (((Width * BI.BitCount) + 31) shr 5) * 4; - AlignedSize := Height * LongInt(AlignedWidthBytes); - - // Palette settings and reading - if BI.BitCount <= 8 then - begin - // Seek to the begining of palette - Seek(Handle, StartPos + SizeOf(TBitmapFileHeader) + LongInt(BI.Size), - smFromBeginning); - if IsOS2 then - begin - // OS/2 type - FPalSize := 1 shl BI.BitCount; - GetMem(PalRGB, FPalSize * SizeOf(TColor24Rec)); - try - Read(Handle, PalRGB, FPalSize * SizeOf(TColor24Rec)); - for I := 0 to FPalSize - 1 do - with PalRGB[I] do - begin - Palette[I].R := R; - Palette[I].G := G; - Palette[I].B := B; - end; - finally - FreeMemNil(PalRGB); - end; - end - else - begin - // Windows type - FPalSize := BI.ClrUsed; - if FPalSize = 0 then - FPalSize := 1 shl BI.BitCount; - Read(Handle, Palette, FPalSize * SizeOf(TColor32Rec)); - end; - for I := 0 to Info.PaletteEntries - 1 do - Palette[I].A := $FF; - end; - - // Seek to the beginning of image bits - Seek(Handle, StartPos + LongInt(BF.Offset), smFromBeginning); - - case BI.Compression of - BI_RGB: LoadRGB; - BI_RLE4: LoadRLE4; - BI_RLE8: LoadRLE8; - BI_BITFIELDS: LoadRGB; - end; - - if BI.AlphaMask = 0 then - begin - // Alpha mask is not stored in file (V3) or not defined. - // Check alpha channels of loaded images if they might contain them. - if Format = ifA1R5G5B5 then - begin - // Check if there is alpha channel present in A1R5GB5 images, if it is not - // change format to X1R5G5B5 - if not Has16BitImageAlpha(Width * Height, Bits) then - Format := ifX1R5G5B5; - end - else if Format = ifA8R8G8B8 then - begin - // Check if there is alpha channel present in A8R8G8B8 images, if it is not - // change format to X8R8G8B8 - if not Has32BitImageAlpha(Width * Height, Bits) then - Format := ifX8R8G8B8; - end; - end; - - if BI.BitCount < 8 then - begin - // 1 and 4 bpp images are supported only for loading which is now - // so we now convert them to 8bpp (and unalign scanlines). - case BI.BitCount of - 1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes); - 4: - begin - // RLE4 bitmaps are translated to 8bit during RLE decoding - if BI.Compression <> BI_RLE4 then - Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes); - end; - end; - // Enlarge palette - ReallocMem(Palette, Info.PaletteEntries * SizeOf(TColor32Rec)); - end; - - Result := True; - finally - FreeMemNil(Data); - end; -end; - -function TBitmapFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: LongInt): Boolean; -var - StartPos, EndPos, I, Pad, PadSize, WidthBytes: LongInt; - BF: TBitmapFileHeader; - BI: TBitmapInfoHeader; - Info: TImageFormatInfo; - ImageToSave: TImageData; - MustBeFreed: Boolean; - - procedure SaveRLE8; - const - BufferSize = 8 * 1024; - var - X, Y, I, SrcPos: LongInt; - DiffCount, SameCount: Byte; - Pixels: PByteArray; - Buffer: array[0..BufferSize - 1] of Byte; - BufferPos: LongInt; - - procedure WriteByte(ByteToWrite: Byte); - begin - if BufferPos = BufferSize then - begin - // Flush buffer if necessary - GetIO.Write(Handle, @Buffer, BufferPos); - BufferPos := 0; - end; - Buffer[BufferPos] := ByteToWrite; - Inc(BufferPos); - end; - - begin - BufferPos := 0; - with GetIO, ImageToSave do - begin - for Y := Height - 1 downto 0 do - begin - X := 0; - SrcPos := 0; - Pixels := @PByteArray(Bits)[Y * Width]; - - while X < Width do - begin - SameCount := 1; - DiffCount := 0; - // Determine run length - while X + SameCount < Width do - begin - // If we reach max run length or byte with different value - // we end this run - if (SameCount = 255) or (Pixels[SrcPos + SameCount] <> Pixels[SrcPos]) then - Break; - Inc(SameCount); - end; - - if SameCount = 1 then - begin - // If there are not some bytes with the same value we - // compute how many different bytes are there - while X + DiffCount < Width do - begin - // Stop diff byte counting if there two bytes with the same value - // or DiffCount is too big - if (DiffCount = 255) or (Pixels[SrcPos + DiffCount + 1] = - Pixels[SrcPos + DiffCount]) then - Break; - Inc(DiffCount); - end; - end; - - // Now store absolute data (direct copy image->file) or - // store RLE code only (number of repeats + byte to be repeated) - if DiffCount > 2 then - begin - // Save 'Absolute Data' (0 + number of bytes) but only - // if number is >2 because (0+1) and (0+2) are other special commands - WriteByte(0); - WriteByte(DiffCount); - // Write absolute data to buffer - for I := 0 to DiffCount - 1 do - WriteByte(Pixels[SrcPos + I]); - Inc(X, DiffCount); - Inc(SrcPos, DiffCount); - // Odd number of bytes must be padded - if (DiffCount mod 2) = 1 then - WriteByte(0); - end - else - begin - // Save number of repeats and byte that should be repeated - WriteByte(SameCount); - WriteByte(Pixels[SrcPos]); - Inc(X, SameCount); - Inc(SrcPos, SameCount); - end; - end; - // Save 'End Of Line' command - WriteByte(0); - WriteByte(0); - end; - // Save 'End Of Bitmap' command - WriteByte(0); - WriteByte(1); - // Flush buffer - GetIO.Write(Handle, @Buffer, BufferPos); - end; - end; - -begin - Result := False; - if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then - with GetIO, ImageToSave do - try - Info := GetFormatInfo(Format); - StartPos := Tell(Handle); - FillChar(BF, SizeOf(BF), 0); - FillChar(BI, SizeOf(BI), 0); - // Other fields will be filled later - we don't know all values now - BF.ID := BMMagic; - Write(Handle, @BF, SizeOf(BF)); - if Info.HasAlphaChannel and (Info.BytesPerPixel = 2){V4 temp hack} then - // Save images with alpha in V4 format - BI.Size := V4InfoHeaderSize - else - // Save images without alpha in V3 format - for better compatibility - BI.Size := V3InfoHeaderSize; - BI.Width := Width; - BI.Height := Height; - BI.Planes := 1; - BI.BitCount := Info.BytesPerPixel * 8; - BI.XPelsPerMeter := 2835; // 72 dpi - BI.YPelsPerMeter := 2835; // 72 dpi - // Set compression - if (Info.BytesPerPixel = 1) and FUseRLE then - BI.Compression := BI_RLE8 - else if (Info.HasAlphaChannel or - ((BI.BitCount = 16) and (Format <> ifX1R5G5B5))) and (Info.BytesPerPixel = 2){V4 temp hack} then - BI.Compression := BI_BITFIELDS - else - BI.Compression := BI_RGB; - // Write header (first time) - Write(Handle, @BI, BI.Size); - - // Write mask info - if BI.Compression = BI_BITFIELDS then - begin - if BI.BitCount = 16 then - with Info.PixelFormat^ do - begin - BI.RedMask := RBitMask; - BI.GreenMask := GBitMask; - BI.BlueMask := BBitMask; - BI.AlphaMask := ABitMask; - end - else - begin - // Set masks for A8R8G8B8 - BI.RedMask := $00FF0000; - BI.GreenMask := $0000FF00; - BI.BlueMask := $000000FF; - BI.AlphaMask := $FF000000; - end; - // If V3 header is used RGB masks must be written to file separately. - // V4 header has embedded masks (V4 is default for formats with alpha). - if BI.Size = V3InfoHeaderSize then - Write(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3); - end; - // Write palette - if Palette <> nil then - Write(Handle, Palette, Info.PaletteEntries * SizeOf(TColor32Rec)); - - BF.Offset := Tell(Handle) - StartPos; - - if BI.Compression <> BI_RLE8 then - begin - // Save uncompressed data, scanlines must be filled with pad bytes - // to be multiples of 4, save as bottom-up (Windows native) bitmap - Pad := 0; - WidthBytes := Width * Info.BytesPerPixel; - PadSize := ((Width * BI.BitCount + 31) div 32) * 4 - WidthBytes; - - for I := Height - 1 downto 0 do - begin - Write(Handle, @PByteArray(Bits)[I * WidthBytes], WidthBytes); - if PadSize > 0 then - Write(Handle, @Pad, PadSize); - end; - end - else - begin - // Save data with RLE8 compression - SaveRLE8; - end; - - EndPos := Tell(Handle); - Seek(Handle, StartPos, smFromBeginning); - // Rewrite header with new values - BF.Size := EndPos - StartPos; - BI.SizeImage := BF.Size - BF.Offset; - Write(Handle, @BF, SizeOf(BF)); - Write(Handle, @BI, BI.Size); - Seek(Handle, EndPos, smFromBeginning); - - Result := True; - finally - if MustBeFreed then - FreeImage(ImageToSave); - end; -end; - -procedure TBitmapFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -var - ConvFormat: TImageFormat; -begin - if Info.IsFloatingPoint then - // Convert FP image to RGB/ARGB according to presence of alpha channel - ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8) - else if Info.HasGrayChannel or Info.IsIndexed then - // Convert all grayscale and indexed images to Index8 unless they have alpha - // (preserve it) - ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifIndex8) - else if Info.HasAlphaChannel then - // Convert images with alpha channel to A8R8G8B8 - ConvFormat := ifA8R8G8B8 - else if Info.UsePixelFormat then - // Convert 16bit RGB images (no alpha) to X1R5G5B5 - ConvFormat := ifX1R5G5B5 - else - // Convert all other formats to R8G8B8 - ConvFormat := ifR8G8B8; - - ConvertImage(Image, ConvFormat); -end; - -function TBitmapFileFormat.TestFormat(Handle: TImagingHandle): Boolean; -var - Hdr: TBitmapFileHeader; - ReadCount: LongInt; -begin - Result := False; - if Handle <> nil then - with GetIO do - begin - ReadCount := Read(Handle, @Hdr, SizeOf(Hdr)); - Seek(Handle, -ReadCount, smFromCurrent); - Result := (Hdr.ID = BMMagic) and (ReadCount = SizeOf(Hdr)); - end; -end; - -initialization - RegisterImageFileFormat(TBitmapFileFormat); - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - Add option to choose to save V3 or V4 headers. - - -- 0.25.0 Changes/Bug Fixes --------------------------------- - - Fixed problem with indexed BMP loading - some pal entries - could end up with alpha=0. - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Now saves bitmaps as bottom-up for better compatibility - (mainly Lazarus' TImage!). - - Fixed crash when loading bitmaps with headers larger than V4. - - Temp hacks to disable V4 headers for 32bit images (compatibility with - other soft). - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Removed temporary data allocation for image with aligned scanlines. - They are now directly written to output so memory requirements are - much lower now. - - Now uses and recognizes BITMAPINFOHEADERV4 when loading/saving. - Mainly for formats with alpha channels. - - Added ifR5G6B5 to supported formats, changed converting to supported - formats little bit. - - Rewritten SaveRLE8 nested procedure. Old code was long and - mysterious - new is short and much more readable. - - MakeCompatible method moved to base class, put ConvertToSupported here. - GetSupportedFormats removed, it is now set in constructor. - - Rewritten LoadRLE4 and LoadRLE8 nested procedures. - Should be less buggy an more readable (load inspired by Colosseum Builders' code). - - Made public properties for options registered to SetOption/GetOption - functions. - - Addded alpha check to 32b bitmap loading too (teh same as in 16b - bitmap loading). - - Moved Convert1To8 and Convert4To8 to ImagingFormats - - Changed extensions to filename masks. - - Changed SaveData, LoadData, and MakeCompatible methods according - to changes in base class in Imaging unit. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - fixed wrong const that caused A4R4G4B4 BMPs to load as A1R5G5B5 - - fixed the bug that caused 8bit RLE compressed bitmaps to load as - whole black - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - 16 bit images are usually without alpha but some has alpha - channel and there is no indication of it - so I have added - a check: if all pixels of image are with alpha = 0 image is treated - as X1R5G5B5 otherwise as A1R5G5B5 - - -- 0.13 Changes/Bug Fixes ----------------------------------- - - when loading 1/4 bit images with dword aligned dimensions - there was ugly memory rewritting bug causing image corruption - -} - -end. - +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ + This unit contains image format loader/saver for Windows Bitmap images. +} +unit ImagingBitmap; + +{$I ImagingOptions.inc} + +interface + +uses + ImagingTypes, Imaging, ImagingUtility, ImagingFormats, ImagingIO; + +type + { Class for loading and saving Windows Bitmap images. + It can load/save 8bit indexed, 16, 24, 32 bit RGB or ARGB + images with or without RLE compression. It can also load 1/4 bit + indexed images and OS2 bitmaps.} + TBitmapFileFormat = class(TImageFileFormat) + protected + FUseRLE: LongBool; + procedure Define; override; + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean): Boolean; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + public + function TestFormat(Handle: TImagingHandle): Boolean; override; + published + { Controls that RLE compression is used during saving. Accessible trough + ImagingBitmapRLE option.} + property UseRLE: LongBool read FUseRLE write FUseRLE; + end; + +implementation + +const + SBitmapFormatName = 'Windows Bitmap Image'; + SBitmapMasks = '*.bmp,*.dib'; + BitmapSupportedFormats: TImageFormats = [ifIndex8, ifA1R5G5B5, ifA4R4G4B4, + ifR5G6B5, ifR8G8B8, ifA8R8G8B8, ifX1R5G5B5, ifX4R4G4B4, ifX8R8G8B8]; + BitmapDefaultRLE = True; + +const + { Bitmap file identifier 'BM'.} + BMMagic: Word = 19778; + + { Constants for the TBitmapInfoHeader.Compression field.} + BI_RGB = 0; + BI_RLE8 = 1; + BI_RLE4 = 2; + BI_BITFIELDS = 3; + + V3InfoHeaderSize = 40; + V4InfoHeaderSize = 108; + +type + { File Header for Windows/OS2 bitmap file.} + TBitmapFileHeader = packed record + ID: Word; // Is always 19778 : 'BM' + Size: UInt32; // File size + Reserved1: Word; + Reserved2: Word; + Offset: UInt32; // Offset from start pos to beginning of image bits + end; + + { Info Header for Windows bitmap file version 4.} + TBitmapInfoHeader = packed record + Size: UInt32; + Width: Int32; + Height: Int32; + Planes: Word; + BitCount: Word; + Compression: UInt32; + SizeImage: UInt32; + XPelsPerMeter: Int32; + YPelsPerMeter: Int32; + ClrUsed: UInt32; + ClrImportant: UInt32; + RedMask: UInt32; + GreenMask: UInt32; + BlueMask: UInt32; + AlphaMask: UInt32; + CSType: UInt32; + EndPoints: array[0..8] of UInt32; + GammaRed: UInt32; + GammaGreen: UInt32; + GammaBlue: UInt32; + end; + + { Info Header for OS2 bitmaps.} + TBitmapCoreHeader = packed record + Size: UInt32; + Width: Word; + Height: Word; + Planes: Word; + BitCount: Word; + end; + + { Used in RLE encoding and decoding.} + TRLEOpcode = packed record + Count: Byte; + Command: Byte; + end; + PRLEOpcode = ^TRLEOpcode; + +{ TBitmapFileFormat class implementation } + +procedure TBitmapFileFormat.Define; +begin + inherited; + FName := SBitmapFormatName; + FFeatures := [ffLoad, ffSave]; + FSupportedFormats := BitmapSupportedFormats; + + FUseRLE := BitmapDefaultRLE; + + AddMasks(SBitmapMasks); + RegisterOption(ImagingBitmapRLE, @FUseRLE); +end; + +function TBitmapFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + BF: TBitmapFileHeader; + BI: TBitmapInfoHeader; + BC: TBitmapCoreHeader; + IsOS2: Boolean; + PalRGB: PPalette24; + I, FPalSize, AlignedSize, StartPos, HeaderSize, AlignedWidthBytes, WidthBytes: LongInt; + Info: TImageFormatInfo; + Data: Pointer; + + procedure LoadRGB; + var + I: LongInt; + LineBuffer: PByte; + begin + with Images[0], GetIO do + begin + // If BI.Height is < 0 then image data are stored non-flipped + // but default in windows is flipped so if Height is positive we must + // flip it + + if BI.BitCount < 8 then + begin + // For 1 and 4 bit images load aligned data, they will be converted to + // 8 bit and unaligned later + GetMem(Data, AlignedSize); + + if BI.Height < 0 then + Read(Handle, Data, AlignedSize) + else + for I := Height - 1 downto 0 do + Read(Handle, @PByteArray(Data)[I * AlignedWidthBytes], AlignedWidthBytes); + end + else + begin + // Images with pixels of size >= 1 Byte are read line by line and + // copied to image bits without padding bytes + GetMem(LineBuffer, AlignedWidthBytes); + try + if BI.Height < 0 then + for I := 0 to Height - 1 do + begin + Read(Handle, LineBuffer, AlignedWidthBytes); + Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes); + end + else + for I := Height - 1 downto 0 do + begin + Read(Handle, LineBuffer, AlignedWidthBytes); + Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes); + end; + finally + FreeMemNil(LineBuffer); + end; + end; + end; + end; + + procedure LoadRLE4; + var + RLESrc: PByteArray; + Row, Col, WriteRow, I: Integer; + SrcPos: UInt32; + DeltaX, DeltaY, Low, High: Byte; + Pixels: PByteArray; + OpCode: TRLEOpcode; + NegHeightBitmap: Boolean; + begin + GetMem(RLESrc, BI.SizeImage); + GetIO.Read(Handle, RLESrc, BI.SizeImage); + with Images[0] do + try + Low := 0; + Pixels := Bits; + SrcPos := 0; + NegHeightBitmap := BI.Height < 0; + Row := 0; // Current row in dest image + Col := 0; // Current column in dest image + // Row in dest image where actual writing will be done + WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row); + while (Row < Height) and (SrcPos < BI.SizeImage) do + begin + // Read RLE op-code + OpCode := PRLEOpcode(@RLESrc[SrcPos])^; + Inc(SrcPos, SizeOf(OpCode)); + if OpCode.Count = 0 then + begin + // A byte Count of zero means that this is a special + // instruction. + case OpCode.Command of + 0: + begin + // Move to next row + Inc(Row); + WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row); + Col := 0; + end ; + 1: Break; // Image is finished + 2: + begin + // Move to a new relative position + DeltaX := RLESrc[SrcPos]; + DeltaY := RLESrc[SrcPos + 1]; + Inc(SrcPos, 2); + Inc(Col, DeltaX); + Inc(Row, DeltaY); + end + else + // Do not read data after EOF + if SrcPos + OpCode.Command > BI.SizeImage then + OpCode.Command := BI.SizeImage - SrcPos; + // Take padding bytes and nibbles into account + if Col + OpCode.Command > Width then + OpCode.Command := Width - Col; + // Store absolute data. Command code is the + // number of absolute bytes to store + for I := 0 to OpCode.Command - 1 do + begin + if (I and 1) = 0 then + begin + High := RLESrc[SrcPos] shr 4; + Low := RLESrc[SrcPos] and $F; + Pixels[WriteRow * Width + Col] := High; + Inc(SrcPos); + end + else + Pixels[WriteRow * Width + Col] := Low; + Inc(Col); + end; + // Odd number of bytes is followed by a pad byte + if (OpCode.Command mod 4) in [1, 2] then + Inc(SrcPos); + end; + end + else + begin + // Take padding bytes and nibbles into account + if Col + OpCode.Count > Width then + OpCode.Count := Width - Col; + // Store a run of the same color value + for I := 0 to OpCode.Count - 1 do + begin + if (I and 1) = 0 then + Pixels[WriteRow * Width + Col] := OpCode.Command shr 4 + else + Pixels[WriteRow * Width + Col] := OpCode.Command and $F; + Inc(Col); + end; + end; + end; + finally + FreeMem(RLESrc); + end; + end; + + procedure LoadRLE8; + var + RLESrc: PByteArray; + SrcCount, Row, Col, WriteRow: Integer; + SrcPos: UInt32; + DeltaX, DeltaY: Byte; + Pixels: PByteArray; + OpCode: TRLEOpcode; + NegHeightBitmap: Boolean; + begin + GetMem(RLESrc, BI.SizeImage); + GetIO.Read(Handle, RLESrc, BI.SizeImage); + with Images[0] do + try + Pixels := Bits; + SrcPos := 0; + NegHeightBitmap := BI.Height < 0; + Row := 0; // Current row in dest image + Col := 0; // Current column in dest image + // Row in dest image where actual writing will be done + WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row); + while (Row < Height) and (SrcPos < BI.SizeImage) do + begin + // Read RLE op-code + OpCode := PRLEOpcode(@RLESrc[SrcPos])^; + Inc(SrcPos, SizeOf(OpCode)); + if OpCode.Count = 0 then + begin + // A byte Count of zero means that this is a special + // instruction. + case OpCode.Command of + 0: + begin + // Move to next row + Inc(Row); + WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row); + Col := 0; + end ; + 1: Break; // Image is finished + 2: + begin + // Move to a new relative position + DeltaX := RLESrc[SrcPos]; + DeltaY := RLESrc[SrcPos + 1]; + Inc(SrcPos, 2); + Inc(Col, DeltaX); + Inc(Row, DeltaY); + end + else + SrcCount := OpCode.Command; + // Do not read data after EOF + if SrcPos + OpCode.Command > BI.SizeImage then + OpCode.Command := BI.SizeImage - SrcPos; + // Take padding bytes into account + if Col + OpCode.Command > Width then + OpCode.Command := Width - Col; + // Store absolute data. Command code is the + // number of absolute bytes to store + Move(RLESrc[SrcPos], Pixels[WriteRow * Width + Col], OpCode.Command); + Inc(SrcPos, SrcCount); + Inc(Col, OpCode.Command); + // Odd number of bytes is followed by a pad byte + if (SrcCount mod 2) = 1 then + Inc(SrcPos); + end; + end + else + begin + // Take padding bytes into account + if Col + OpCode.Count > Width then + OpCode.Count := Width - Col; + // Store a run of the same color value. Count is number of bytes to store + FillChar(Pixels [WriteRow * Width + Col], OpCode.Count, OpCode.Command); + Inc(Col, OpCode.Count); + end; + end; + finally + FreeMem(RLESrc); + end; + end; + +begin + Data := nil; + SetLength(Images, 1); + with GetIO, Images[0] do + try + FillChar(BI, SizeOf(BI), 0); + StartPos := Tell(Handle); + Read(Handle, @BF, SizeOf(BF)); + Read(Handle, @BI.Size, SizeOf(BI.Size)); + IsOS2 := BI.Size = SizeOf(TBitmapCoreHeader); + + // Bitmap Info reading + if IsOS2 then + begin + // OS/2 type bitmap, reads info header without 4 already read bytes + Read(Handle, @PByteArray(@BC)[SizeOf(BI.Size)], + SizeOf(TBitmapCoreHeader) - SizeOf(BI.Size)); + with BI do + begin + ClrUsed := 0; + Compression := BI_RGB; + BitCount := BC.BitCount; + Height := BC.Height; + Width := BC.Width; + end; + end + else + begin + // Windows type bitmap + HeaderSize := Min(BI.Size - SizeOf(BI.Size), SizeOf(BI) - SizeOf(BI.Size)); // do not read more than size of BI! + Read(Handle, @PByteArray(@BI)[SizeOf(BI.Size)], HeaderSize); + // SizeImage can be 0 for BI_RGB images, but it is here because of: + // I saved 8bit bitmap in Paint Shop Pro 8 as OS2 RLE compressed. + // It wrote strange 64 Byte Info header with SizeImage set to 0 + // Some progs were able to open it, some were not. + if BI.SizeImage = 0 then + BI.SizeImage := BF.Size - BF.Offset; + end; + // Bit mask reading. Only read it if there is V3 header, V4 header has + // masks loaded already (only masks for RGB in V3). + if (BI.Compression = BI_BITFIELDS) and (BI.Size = V3InfoHeaderSize) then + Read(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3); + + case BI.BitCount of + 1, 4, 8: Format := ifIndex8; + 16: + if BI.RedMask = $0F00 then + // Set XRGB4 or ARGB4 according to value of alpha mask + Format := IffFormat(BI.AlphaMask = 0, ifX4R4G4B4, ifA4R4G4B4) + else if BI.RedMask = $F800 then + Format := ifR5G6B5 + else + // R5G5B5 is default 16bit format (with Compression = BI_RGB or masks). + // We set it to A1.. and later there is a check if there are any alpha values + // and if not it is changed to X1R5G5B5 + Format := ifA1R5G5B5; + 24: Format := ifR8G8B8; + 32: Format := ifA8R8G8B8; // As with R5G5B5 there is alpha check later + end; + + NewImage(BI.Width, Abs(BI.Height), Format, Images[0]); + Info := GetFormatInfo(Format); + WidthBytes := Width * Info.BytesPerPixel; + AlignedWidthBytes := (((Width * BI.BitCount) + 31) shr 5) * 4; + AlignedSize := Height * LongInt(AlignedWidthBytes); + + // Palette settings and reading + if BI.BitCount <= 8 then + begin + // Seek to the beginning of palette + Seek(Handle, StartPos + SizeOf(TBitmapFileHeader) + LongInt(BI.Size), + smFromBeginning); + if IsOS2 then + begin + // OS/2 type + FPalSize := 1 shl BI.BitCount; + GetMem(PalRGB, FPalSize * SizeOf(TColor24Rec)); + try + Read(Handle, PalRGB, FPalSize * SizeOf(TColor24Rec)); + for I := 0 to FPalSize - 1 do + with PalRGB[I] do + begin + Palette[I].R := R; + Palette[I].G := G; + Palette[I].B := B; + end; + finally + FreeMemNil(PalRGB); + end; + end + else + begin + // Windows type + FPalSize := BI.ClrUsed; + if FPalSize = 0 then + FPalSize := 1 shl BI.BitCount; + Read(Handle, Palette, FPalSize * SizeOf(TColor32Rec)); + end; + for I := 0 to Info.PaletteEntries - 1 do + Palette[I].A := $FF; + end; + + // Seek to the beginning of image bits + Seek(Handle, StartPos + LongInt(BF.Offset), smFromBeginning); + + case BI.Compression of + BI_RGB: LoadRGB; + BI_RLE4: LoadRLE4; + BI_RLE8: LoadRLE8; + BI_BITFIELDS: LoadRGB; + end; + + if BI.AlphaMask = 0 then + begin + // Alpha mask is not stored in file (V3) or not defined. + // Check alpha channels of loaded images if they might contain them. + if Format = ifA1R5G5B5 then + begin + // Check if there is alpha channel present in A1R5GB5 images, if it is not + // change format to X1R5G5B5 + if not Has16BitImageAlpha(Width * Height, Bits) then + Format := ifX1R5G5B5; + end + else if Format = ifA8R8G8B8 then + begin + // Check if there is alpha channel present in A8R8G8B8 images, if it is not + // change format to X8R8G8B8 + if not Has32BitImageAlpha(Width * Height, Bits) then + Format := ifX8R8G8B8; + end; + end; + + if BI.BitCount < 8 then + begin + // 1 and 4 bpp images are supported only for loading which is now + // so we now convert them to 8bpp (and unalign scanlines). + case BI.BitCount of + 1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes, False); + 4: + begin + // RLE4 bitmaps are translated to 8bit during RLE decoding + if BI.Compression <> BI_RLE4 then + Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes, False); + end; + end; + // Enlarge palette + ReallocMem(Palette, Info.PaletteEntries * SizeOf(TColor32Rec)); + end; + + Result := True; + finally + FreeMemNil(Data); + end; +end; + +function TBitmapFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + StartPos, EndPos, I, Pad, PadSize, WidthBytes: LongInt; + BF: TBitmapFileHeader; + BI: TBitmapInfoHeader; + Info: TImageFormatInfo; + ImageToSave: TImageData; + MustBeFreed: Boolean; + + procedure SaveRLE8; + const + BufferSize = 8 * 1024; + var + X, Y, I, SrcPos: LongInt; + DiffCount, SameCount: Byte; + Pixels: PByteArray; + Buffer: array[0..BufferSize - 1] of Byte; + BufferPos: LongInt; + + procedure WriteByte(ByteToWrite: Byte); + begin + if BufferPos = BufferSize then + begin + // Flush buffer if necessary + GetIO.Write(Handle, @Buffer, BufferPos); + BufferPos := 0; + end; + Buffer[BufferPos] := ByteToWrite; + Inc(BufferPos); + end; + + begin + BufferPos := 0; + with GetIO, ImageToSave do + begin + for Y := Height - 1 downto 0 do + begin + X := 0; + SrcPos := 0; + Pixels := @PByteArray(Bits)[Y * Width]; + + while X < Width do + begin + SameCount := 1; + DiffCount := 0; + // Determine run length + while X + SameCount < Width do + begin + // If we reach max run length or byte with different value + // we end this run + if (SameCount = 255) or (Pixels[SrcPos + SameCount] <> Pixels[SrcPos]) then + Break; + Inc(SameCount); + end; + + if SameCount = 1 then + begin + // If there are not some bytes with the same value we + // compute how many different bytes are there + while X + DiffCount < Width do + begin + // Stop diff byte counting if there two bytes with the same value + // or DiffCount is too big + if (DiffCount = 255) or (Pixels[SrcPos + DiffCount + 1] = + Pixels[SrcPos + DiffCount]) then + Break; + Inc(DiffCount); + end; + end; + + // Now store absolute data (direct copy image->file) or + // store RLE code only (number of repeats + byte to be repeated) + if DiffCount > 2 then + begin + // Save 'Absolute Data' (0 + number of bytes) but only + // if number is >2 because (0+1) and (0+2) are other special commands + WriteByte(0); + WriteByte(DiffCount); + // Write absolute data to buffer + for I := 0 to DiffCount - 1 do + WriteByte(Pixels[SrcPos + I]); + Inc(X, DiffCount); + Inc(SrcPos, DiffCount); + // Odd number of bytes must be padded + if (DiffCount mod 2) = 1 then + WriteByte(0); + end + else + begin + // Save number of repeats and byte that should be repeated + WriteByte(SameCount); + WriteByte(Pixels[SrcPos]); + Inc(X, SameCount); + Inc(SrcPos, SameCount); + end; + end; + // Save 'End Of Line' command + WriteByte(0); + WriteByte(0); + end; + // Save 'End Of Bitmap' command + WriteByte(0); + WriteByte(1); + // Flush buffer + GetIO.Write(Handle, @Buffer, BufferPos); + end; + end; + +begin + Result := False; + if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then + with GetIO, ImageToSave do + try + Info := GetFormatInfo(Format); + StartPos := Tell(Handle); + FillChar(BF, SizeOf(BF), 0); + FillChar(BI, SizeOf(BI), 0); + // Other fields will be filled later - we don't know all values now + BF.ID := BMMagic; + Write(Handle, @BF, SizeOf(BF)); + if Info.HasAlphaChannel and (Info.BytesPerPixel = 2){V4 temp hack} then + // Save images with alpha in V4 format + BI.Size := V4InfoHeaderSize + else + // Save images without alpha in V3 format - for better compatibility + BI.Size := V3InfoHeaderSize; + BI.Width := Width; + BI.Height := Height; + BI.Planes := 1; + BI.BitCount := Info.BytesPerPixel * 8; + BI.XPelsPerMeter := 2835; // 72 dpi + BI.YPelsPerMeter := 2835; // 72 dpi + // Set compression + if (Info.BytesPerPixel = 1) and FUseRLE then + BI.Compression := BI_RLE8 + else if (Info.HasAlphaChannel or + ((BI.BitCount = 16) and (Format <> ifX1R5G5B5))) and (Info.BytesPerPixel = 2){V4 temp hack} then + BI.Compression := BI_BITFIELDS + else + BI.Compression := BI_RGB; + // Write header (first time) + Write(Handle, @BI, BI.Size); + + // Write mask info + if BI.Compression = BI_BITFIELDS then + begin + if BI.BitCount = 16 then + with Info.PixelFormat^ do + begin + BI.RedMask := RBitMask; + BI.GreenMask := GBitMask; + BI.BlueMask := BBitMask; + BI.AlphaMask := ABitMask; + end + else + begin + // Set masks for A8R8G8B8 + BI.RedMask := $00FF0000; + BI.GreenMask := $0000FF00; + BI.BlueMask := $000000FF; + BI.AlphaMask := $FF000000; + end; + // If V3 header is used RGB masks must be written to file separately. + // V4 header has embedded masks (V4 is default for formats with alpha). + if BI.Size = V3InfoHeaderSize then + Write(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3); + end; + // Write palette + if Palette <> nil then + Write(Handle, Palette, Info.PaletteEntries * SizeOf(TColor32Rec)); + + BF.Offset := Tell(Handle) - StartPos; + + if BI.Compression <> BI_RLE8 then + begin + // Save uncompressed data, scanlines must be filled with pad bytes + // to be multiples of 4, save as bottom-up (Windows native) bitmap + Pad := 0; + WidthBytes := Width * Info.BytesPerPixel; + PadSize := ((Width * BI.BitCount + 31) div 32) * 4 - WidthBytes; + + for I := Height - 1 downto 0 do + begin + Write(Handle, @PByteArray(Bits)[I * WidthBytes], WidthBytes); + if PadSize > 0 then + Write(Handle, @Pad, PadSize); + end; + end + else + begin + // Save data with RLE8 compression + SaveRLE8; + end; + + EndPos := Tell(Handle); + Seek(Handle, StartPos, smFromBeginning); + // Rewrite header with new values + BF.Size := EndPos - StartPos; + BI.SizeImage := BF.Size - BF.Offset; + Write(Handle, @BF, SizeOf(BF)); + Write(Handle, @BI, BI.Size); + Seek(Handle, EndPos, smFromBeginning); + + Result := True; + finally + if MustBeFreed then + FreeImage(ImageToSave); + end; +end; + +procedure TBitmapFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +var + ConvFormat: TImageFormat; +begin + if Info.IsFloatingPoint then + // Convert FP image to RGB/ARGB according to presence of alpha channel + ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8) + else if Info.HasGrayChannel or Info.IsIndexed then + // Convert all grayscale and indexed images to Index8 unless they have alpha + // (preserve it) + ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifIndex8) + else if Info.HasAlphaChannel then + // Convert images with alpha channel to A8R8G8B8 + ConvFormat := ifA8R8G8B8 + else if Info.UsePixelFormat then + // Convert 16bit RGB images (no alpha) to X1R5G5B5 + ConvFormat := ifX1R5G5B5 + else + // Convert all other formats to R8G8B8 + ConvFormat := ifR8G8B8; + + ConvertImage(Image, ConvFormat); +end; + +function TBitmapFileFormat.TestFormat(Handle: TImagingHandle): Boolean; +var + Hdr: TBitmapFileHeader; + ReadCount: LongInt; +begin + Result := False; + if Handle <> nil then + with GetIO do + begin + ReadCount := Read(Handle, @Hdr, SizeOf(Hdr)); + Seek(Handle, -ReadCount, smFromCurrent); + Result := (Hdr.ID = BMMagic) and (ReadCount = SizeOf(Hdr)); + end; +end; + +initialization + RegisterImageFileFormat(TBitmapFileFormat); + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - nothing now + - Add option to choose to save V3 or V4 headers. + + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - Fixed problem with indexed BMP loading - some pal entries + could end up with alpha=0. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Now saves bitmaps as bottom-up for better compatibility + (mainly Lazarus' TImage!). + - Fixed crash when loading bitmaps with headers larger than V4. + - Temp hacks to disable V4 headers for 32bit images (compatibility with + other soft). + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Removed temporary data allocation for image with aligned scanlines. + They are now directly written to output so memory requirements are + much lower now. + - Now uses and recognizes BITMAPINFOHEADERV4 when loading/saving. + Mainly for formats with alpha channels. + - Added ifR5G6B5 to supported formats, changed converting to supported + formats little bit. + - Rewritten SaveRLE8 nested procedure. Old code was long and + mysterious - new is short and much more readable. + - MakeCompatible method moved to base class, put ConvertToSupported here. + GetSupportedFormats removed, it is now set in constructor. + - Rewritten LoadRLE4 and LoadRLE8 nested procedures. + Should be less buggy an more readable (load inspired by Colosseum Builders' code). + - Made public properties for options registered to SetOption/GetOption + functions. + - Added alpha check to 32b bitmap loading too (teh same as in 16b + bitmap loading). + - Moved Convert1To8 and Convert4To8 to ImagingFormats + - Changed extensions to filename masks. + - Changed SaveData, LoadData, and MakeCompatible methods according + to changes in base class in Imaging unit. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - fixed wrong const that caused A4R4G4B4 BMPs to load as A1R5G5B5 + - fixed the bug that caused 8bit RLE compressed bitmaps to load as + whole black + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - 16 bit images are usually without alpha but some has alpha + channel and there is no indication of it - so I have added + a check: if all pixels of image are with alpha = 0 image is treated + as X1R5G5B5 otherwise as A1R5G5B5 + + -- 0.13 Changes/Bug Fixes ----------------------------------- + - when loading 1/4 bit images with dword aligned dimensions + there was ugly memory rewriting bug causing image corruption + +} + +end. + diff --git a/Imaging/ImagingCanvases.pas b/Imaging/ImagingCanvases.pas index c7c238c..57ab070 100644 --- a/Imaging/ImagingCanvases.pas +++ b/Imaging/ImagingCanvases.pas @@ -1,2177 +1,2114 @@ -{ - $Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ - This unit contains canvas classes for drawing and applying effects. -} -unit ImagingCanvases; - -{$I ImagingOptions.inc} - -interface - -uses - SysUtils, Types, Classes, ImagingTypes, Imaging, ImagingClasses, - ImagingFormats, ImagingUtility; - -const - { Color constants in ifA8R8G8B8 format.} - pcClear = $00000000; - pcBlack = $FF000000; - pcWhite = $FFFFFFFF; - pcMaroon = $FF800000; - pcGreen = $FF008000; - pcOlive = $FF808000; - pcNavy = $FF000080; - pcPurple = $FF800080; - pcTeal = $FF008080; - pcGray = $FF808080; - pcSilver = $FFC0C0C0; - pcRed = $FFFF0000; - pcLime = $FF00FF00; - pcYellow = $FFFFFF00; - pcBlue = $FF0000FF; - pcFuchsia = $FFFF00FF; - pcAqua = $FF00FFFF; - pcLtGray = $FFC0C0C0; - pcDkGray = $FF808080; - - MaxPenWidth = 256; - -type - EImagingCanvasError = class(EImagingError); - EImagingCanvasBlendingError = class(EImagingError); - - { Fill mode used when drawing filled objects on canvas.} - TFillMode = ( - fmSolid, // Solid fill using current fill color - fmClear // No filling done - ); - - { Pen mode used when drawing lines, object outlines, and similar on canvas.} - TPenMode = ( - pmSolid, // Draws solid lines using current pen color. - pmClear // No drawing done - ); - - { Source and destination blending factors for drawing functions with blending. - Blending formula: SrcColor * SrcFactor + DestColor * DestFactor } - TBlendingFactor = ( - bfIgnore, // Don't care - bfZero, // For Src and Dest, Factor = (0, 0, 0, 0) - bfOne, // For Src and Dest, Factor = (1, 1, 1, 1) - bfSrcAlpha, // For Src and Dest, Factor = (Src.A, Src.A, Src.A, Src.A) - bfOneMinusSrcAlpha, // For Src and Dest, Factor = (1 - Src.A, 1 - Src.A, 1 - Src.A, 1 - Src.A) - bfDstAlpha, // For Src and Dest, Factor = (Dest.A, Dest.A, Dest.A, Dest.A) - bfOneMinusDstAlpha, // For Src and Dest, Factor = (1 - Dest.A, 1 - Dest.A, 1 - Dest.A, 1 - Dest.A) - bfSrcColor, // For Dest, Factor = (Src.R, Src.R, Src.B, Src.A) - bfOneMinusSrcColor, // For Dest, Factor = (1 - Src.R, 1 - Src.G, 1 - Src.B, 1 - Src.A) - bfDstColor, // For Src, Factor = (Dest.R, Dest.G, Dest.B, Dest.A) - bfOneMinusDstColor // For Src, Factor = (1 - Dest.R, 1 - Dest.G, 1 - Dest.B, 1 - Dest.A) - ); - - { Procedure for custom pixel write modes with blending.} - TPixelWriteProc = procedure(const SrcPix: TColorFPRec; DestPtr: PByte; - DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); - - { Represents 3x3 convolution filter kernel.} - TConvolutionFilter3x3 = record - Kernel: array[0..2, 0..2] of LongInt; - Divisor: LongInt; - Bias: Single; - end; - - { Represents 5x5 convolution filter kernel.} - TConvolutionFilter5x5 = record - Kernel: array[0..4, 0..4] of LongInt; - Divisor: LongInt; - Bias: Single; - end; - - TPointTransformFunction = function(const Pixel: TColorFPRec; - Param1, Param2, Param3: Single): TColorFPRec; - - TDynFPPixelArray = array of TColorFPRec; - - THistogramArray = array[Byte] of Integer; - - TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec; - - { Base canvas class for drawing objects, applying effects, and other. - Constructor takes TBaseImage (or pointer to TImageData). Source image - bits are not copied but referenced so all canvas functions affect - source image and vice versa. When you change format or resolution of - source image you must call UpdateCanvasState method (so canvas could - recompute some data size related stuff). - - TImagingCanvas works for all image data formats except special ones - (compressed). Because of this its methods are quite slow (they usually work - with colors in ifA32R32G32B32F format). If you want fast drawing you - can use one of fast canvas clases. These descendants of TImagingCanvas - work only for few select formats (or only one) but they are optimized thus - much faster. - } - TImagingCanvas = class(TObject) - private - FDataSizeOnUpdate: LongInt; - FLineRecursion: Boolean; - function GetPixel32(X, Y: LongInt): TColor32; virtual; - function GetPixelFP(X, Y: LongInt): TColorFPRec; virtual; - function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetPixel32(X, Y: LongInt; const Value: TColor32); virtual; - procedure SetPixelFP(X, Y: LongInt; const Value: TColorFPRec); virtual; - procedure SetPenColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetPenColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetPenWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetFillColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetFillColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetClipRect(const Value: TRect); - procedure CheckBeforeBlending(SrcFactor, DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas); - protected - FPData: PImageData; - FClipRect: TRect; - FPenColorFP: TColorFPRec; - FPenColor32: TColor32; - FPenMode: TPenMode; - FPenWidth: LongInt; - FFillColorFP: TColorFPRec; - FFillColor32: TColor32; - FFillMode: TFillMode; - FNativeColor: TColorFPRec; - FFormatInfo: TImageFormatInfo; - - { Returns pointer to pixel at given position.} - function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} - { Translates given FP color to native format of canvas and stores it - in FNativeColor field (its bit copy) or user pointer (in overloaded method).} - procedure TranslateFPToNative(const Color: TColorFPRec); overload; {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure TranslateFPToNative(const Color: TColorFPRec; Native: Pointer); overload; {$IFDEF USE_INLINE}inline;{$ENDIF} - { Clipping function used by horizontal and vertical line drawing functions.} - function ClipAxisParallelLine(var A1, A2, B: LongInt; - AStart, AStop, BStart, BStop: LongInt): Boolean; - { Internal horizontal line drawer used mainly for filling inside of objects - like ellipses and circles.} - procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual; - procedure CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; - DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc); - procedure StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; - const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; - Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc); - public - constructor CreateForData(ImageDataPointer: PImageData); - constructor CreateForImage(Image: TBaseImage); - destructor Destroy; override; - - { Call this method when you change size or format of image this canvas - operates on (like calling ResizeImage, ConvertImage, or changing Format - property of TBaseImage descendants).} - procedure UpdateCanvasState; virtual; - { Resets clipping rectangle to Rect(0, 0, ImageWidth, ImageHeight).} - procedure ResetClipRect; - - { Clears entire canvas with current fill color (ignores clipping rectangle - and always uses fmSolid fill mode).} - procedure Clear; - - { Draws horizontal line with current pen settings.} - procedure HorzLine(X1, X2, Y: LongInt); virtual; - { Draws vertical line with current pen settings.} - procedure VertLine(X, Y1, Y2: LongInt); virtual; - { Draws line from [X1, Y1] to [X2, Y2] with current pen settings.} - procedure Line(X1, Y1, X2, Y2: LongInt); virtual; - { Draws a rectangle using current pen settings.} - procedure FrameRect(const Rect: TRect); - { Fills given rectangle with current fill settings.} - procedure FillRect(const Rect: TRect); virtual; - { Fills given rectangle with current fill settings and pixel blending.} - procedure FillRectBlend(const Rect: TRect; SrcFactor, DestFactor: TBlendingFactor); - { Draws rectangle which is outlined by using the current pen settings and - filled by using the current fill settings.} - procedure Rectangle(const Rect: TRect); - { Draws ellipse which is outlined by using the current pen settings and - filled by using the current fill settings. Rect specifies bounding rectangle - of ellipse to be drawn.} - procedure Ellipse(const Rect: TRect); - { Fills area of canvas with current fill color starting at point [X, Y] and - coloring its neighbors. Default flood fill mode changes color of all - neighbors with the same color as pixel [X, Y]. With BoundaryFillMode - set to True neighbors are recolored regardless of their old color, - but area which will be recolored has boundary (specified by current pen color).} - procedure FloodFill(X, Y: Integer; BoundaryFillMode: Boolean = False); - - { Draws contents of this canvas onto another canvas with pixel blending. - Blending factors are chosen using TBlendingFactor parameters. - Resulting destination pixel color is: - SrcColor * SrcFactor + DstColor * DstFactor} - procedure DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; - DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor); - { Draws contents of this canvas onto another one with typical alpha - blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} - procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); virtual; - { Draws contents of this canvas onto another one using additive blending - (source and dest factors are bfOne).} - procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); - { Draws stretched and filtered contents of this canvas onto another canvas - with pixel blending. Blending factors are chosen using TBlendingFactor parameters. - Resulting destination pixel color is: - SrcColor * SrcFactor + DstColor * DstFactor} - procedure StretchDrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; - const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; - Filter: TResizeFilter = rfBilinear); - { Draws contents of this canvas onto another one with typical alpha - blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} - procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; - const DestRect: TRect; Filter: TResizeFilter = rfBilinear); virtual; - { Draws contents of this canvas onto another one using additive blending - (source and dest factors are bfOne).} - procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; - const DestRect: TRect; Filter: TResizeFilter = rfBilinear); - - { Convolves canvas' image with given 3x3 filter kernel. You can use - predefined filter kernels or define your own.} - procedure ApplyConvolution3x3(const Filter: TConvolutionFilter3x3); - { Convolves canvas' image with given 5x5 filter kernel. You can use - predefined filter kernels or define your own.} - procedure ApplyConvolution5x5(const Filter: TConvolutionFilter5x5); - { Computes 2D convolution of canvas' image and given filter kernel. - Kernel is in row format and KernelSize must be odd number >= 3. Divisor - is normalizing value based on Kernel (usually sum of all kernel's cells). - The Bias number shifts each color value by a fixed amount (color values - are usually in range [0, 1] during processing). If ClampChannels - is True all output color values are clamped to [0, 1]. You can use - predefined filter kernels or define your own.} - procedure ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt; - Bias: Single = 0.0; ClampChannels: Boolean = True); virtual; - - { Applies custom non-linear filter. Filter size is diameter of pixel - neighborhood. Typical values are 3, 5, or 7. } - procedure ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction); - { Applies median non-linear filter with user defined pixel neighborhood. - Selects median pixel from the neighborhood as new pixel - (current implementation is quite slow).} - procedure ApplyMedianFilter(FilterSize: Integer); - { Applies min non-linear filter with user defined pixel neighborhood. - Selects min pixel from the neighborhood as new pixel.} - procedure ApplyMinFilter(FilterSize: Integer); - { Applies max non-linear filter with user defined pixel neighborhood. - Selects max pixel from the neighborhood as new pixel.} - procedure ApplyMaxFilter(FilterSize: Integer); - - { Transforms pixels one by one by given function. Pixel neighbors are - not taken into account. Param 1-3 are optional parameters - for transform function.} - procedure PointTransform(Transform: TPointTransformFunction; - Param1, Param2, Param3: Single); - { Modifies image contrast and brightness. Parameters should be - in range <-100; 100>.} - procedure ModifyContrastBrightness(Contrast, Brightness: Single); - { Gamma correction of individual color channels. Range is (0, +inf), - 1.0 means no change.} - procedure GammaCorection(Red, Green, Blue: Single); - { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.} - procedure InvertColors; virtual; - { Simple single level thresholding with threshold level (in range [0, 1]) - for each color channel.} - procedure Threshold(Red, Green, Blue: Single); - { Adjusts the color levels of the image by scaling the - colors falling between specified white and black points to full [0, 1] range. - The black point specifies the darkest color in the image, white point - specifies the lightest color, and mid point is gamma aplied to image. - Black and white point must be in range [0, 1].} - procedure AdjustColorLevels(BlackPoint, WhitePoint: Single; MidPoint: Single = 1.0); - { Premultiplies color channel values by alpha. Needed for some platforms/APIs - to display images with alpha properly.} - procedure PremultiplyAlpha; - { Reverses PremultiplyAlpha operation.} - procedure UnPremultiplyAlpha; - - { Calculates image histogram for each channel and also gray values. Each - channel has 256 values available. Channel values of data formats with higher - precision are scaled and rounded. Example: Red[126] specifies number of pixels - in image with red channel = 126.} - procedure GetHistogram(out Red, Green, Blue, Alpha, Gray: THistogramArray); - { Fills image channel with given value leaving other channels intact. - Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as - channel identifier.} - procedure FillChannel(ChannelId: Integer; NewChannelValue: Byte); overload; - { Fills image channel with given value leaving other channels intact. - Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as - channel identifier.} - procedure FillChannelFP(ChannelId: Integer; NewChannelValue: Single); overload; - - { Color used when drawing lines, frames, and outlines of objects.} - property PenColor32: TColor32 read FPenColor32 write SetPenColor32; - { Color used when drawing lines, frames, and outlines of objects.} - property PenColorFP: TColorFPRec read FPenColorFP write SetPenColorFP; - { Pen mode used when drawing lines, object outlines, and similar on canvas.} - property PenMode: TPenMode read FPenMode write FPenMode; - { Width with which objects like lines, frames, etc. (everything which uses - PenColor) are drawn.} - property PenWidth: LongInt read FPenWidth write SetPenWidth; - { Color used for filling when drawing various objects.} - property FillColor32: TColor32 read FFillColor32 write SetFillColor32; - { Color used for filling when drawing various objects.} - property FillColorFP: TColorFPRec read FFillColorFP write SetFillColorFP; - { Fill mode used when drawing filled objects on canvas.} - property FillMode: TFillMode read FFillMode write FFillMode; - { Specifies the current color of the pixels of canvas. Native pixel is - read from canvas and then translated to 32bit ARGB. Reverse operation - is made when setting pixel color.} - property Pixels32[X, Y: LongInt]: TColor32 read GetPixel32 write SetPixel32; - { Specifies the current color of the pixels of canvas. Native pixel is - read from canvas and then translated to FP ARGB. Reverse operation - is made when setting pixel color.} - property PixelsFP[X, Y: LongInt]: TColorFPRec read GetPixelFP write SetPixelFP; - { Clipping rectangle of this canvas. No pixels outside this rectangle are - altered by canvas methods if Clipping property is True. Clip rect gets - reseted when UpdateCanvasState is called.} - property ClipRect: TRect read FClipRect write SetClipRect; - { Extended format information.} - property FormatInfo: TImageFormatInfo read FFormatInfo; - { Indicates that this canvas is in valid state. If False canvas oprations - may crash.} - property Valid: Boolean read GetValid; - - { Returns all formats supported by this canvas class.} - class function GetSupportedFormats: TImageFormats; virtual; - end; - - TImagingCanvasClass = class of TImagingCanvas; - - TScanlineArray = array[0..MaxInt div SizeOf(Pointer) - 1] of PColor32RecArray; - PScanlineArray = ^TScanlineArray; - - { Fast canvas class for ifA8R8G8B8 format images.} - TFastARGB32Canvas = class(TImagingCanvas) - protected - FScanlines: PScanlineArray; - procedure AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetPixel32(X, Y: LongInt): TColor32; override; - procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override; - public - destructor Destroy; override; - - procedure UpdateCanvasState; override; - - procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); override; - procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; - const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override; - procedure InvertColors; override; - - property Scanlines: PScanlineArray read FScanlines; - - class function GetSupportedFormats: TImageFormats; override; - end; - -const - { Kernel for 3x3 average smoothing filter.} - FilterAverage3x3: TConvolutionFilter3x3 = ( - Kernel: ((1, 1, 1), - (1, 1, 1), - (1, 1, 1)); - Divisor: 9); - - { Kernel for 5x5 average smoothing filter.} - FilterAverage5x5: TConvolutionFilter5x5 = ( - Kernel: ((1, 1, 1, 1, 1), - (1, 1, 1, 1, 1), - (1, 1, 1, 1, 1), - (1, 1, 1, 1, 1), - (1, 1, 1, 1, 1)); - Divisor: 25); - - { Kernel for 3x3 Gaussian smoothing filter.} - FilterGaussian3x3: TConvolutionFilter3x3 = ( - Kernel: ((1, 2, 1), - (2, 4, 2), - (1, 2, 1)); - Divisor: 16); - - { Kernel for 5x5 Gaussian smoothing filter.} - FilterGaussian5x5: TConvolutionFilter5x5 = ( - Kernel: ((1, 4, 6, 4, 1), - (4, 16, 24, 16, 4), - (6, 24, 36, 24, 6), - (4, 16, 24, 16, 4), - (1, 4, 6, 4, 1)); - Divisor: 256); - - { Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).} - FilterSobelHorz3x3: TConvolutionFilter3x3 = ( - Kernel: (( 1, 2, 1), - ( 0, 0, 0), - (-1, -2, -1)); - Divisor: 1); - - { Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).} - FilterSobelVert3x3: TConvolutionFilter3x3 = ( - Kernel: ((-1, 0, 1), - (-2, 0, 2), - (-1, 0, 1)); - Divisor: 1); - - { Kernel for 3x3 Prewitt horizontal edge detection filter.} - FilterPrewittHorz3x3: TConvolutionFilter3x3 = ( - Kernel: (( 1, 1, 1), - ( 0, 0, 0), - (-1, -1, -1)); - Divisor: 1); - - { Kernel for 3x3 Prewitt vertical edge detection filter.} - FilterPrewittVert3x3: TConvolutionFilter3x3 = ( - Kernel: ((-1, 0, 1), - (-1, 0, 1), - (-1, 0, 1)); - Divisor: 1); - - { Kernel for 3x3 Kirsh horizontal edge detection filter.} - FilterKirshHorz3x3: TConvolutionFilter3x3 = ( - Kernel: (( 5, 5, 5), - (-3, 0, -3), - (-3, -3, -3)); - Divisor: 1); - - { Kernel for 3x3 Kirsh vertical edge detection filter.} - FilterKirshVert3x3: TConvolutionFilter3x3 = ( - Kernel: ((5, -3, -3), - (5, 0, -3), - (5, -3, -3)); - Divisor: 1); - - { Kernel for 3x3 Laplace omni-directional edge detection filter - (2nd derivative approximation).} - FilterLaplace3x3: TConvolutionFilter3x3 = ( - Kernel: ((-1, -1, -1), - (-1, 8, -1), - (-1, -1, -1)); - Divisor: 1); - - { Kernel for 5x5 Laplace omni-directional edge detection filter - (2nd derivative approximation).} - FilterLaplace5x5: TConvolutionFilter5x5 = ( - Kernel: ((-1, -1, -1, -1, -1), - (-1, -1, -1, -1, -1), - (-1, -1, 24, -1, -1), - (-1, -1, -1, -1, -1), - (-1, -1, -1, -1, -1)); - Divisor: 1); - - { Kernel for 3x3 spharpening filter (Laplacian + original color).} - FilterSharpen3x3: TConvolutionFilter3x3 = ( - Kernel: ((-1, -1, -1), - (-1, 9, -1), - (-1, -1, -1)); - Divisor: 1); - - { Kernel for 5x5 spharpening filter (Laplacian + original color).} - FilterSharpen5x5: TConvolutionFilter5x5 = ( - Kernel: ((-1, -1, -1, -1, -1), - (-1, -1, -1, -1, -1), - (-1, -1, 25, -1, -1), - (-1, -1, -1, -1, -1), - (-1, -1, -1, -1, -1)); - Divisor: 1); - - { Kernel for 5x5 glow filter.} - FilterGlow5x5: TConvolutionFilter5x5 = ( - Kernel: (( 1, 2, 2, 2, 1), - ( 2, 0, 0, 0, 2), - ( 2, 0, -20, 0, 2), - ( 2, 0, 0, 0, 2), - ( 1, 2, 2, 2, 1)); - Divisor: 8); - - { Kernel for 3x3 edge enhancement filter.} - FilterEdgeEnhance3x3: TConvolutionFilter3x3 = ( - Kernel: ((-1, -2, -1), - (-2, 16, -2), - (-1, -2, -1)); - Divisor: 4); - - { Kernel for 3x3 contour enhancement filter.} - FilterTraceControur3x3: TConvolutionFilter3x3 = ( - Kernel: ((-6, -6, -2), - (-1, 32, -1), - (-6, -2, -6)); - Divisor: 4; - Bias: 240/255); - - { Kernel for filter that negates all images pixels.} - FilterNegative3x3: TConvolutionFilter3x3 = ( - Kernel: ((0, 0, 0), - (0, -1, 0), - (0, 0, 0)); - Divisor: 1; - Bias: 1); - - { Kernel for 3x3 horz/vert embossing filter.} - FilterEmboss3x3: TConvolutionFilter3x3 = ( - Kernel: ((2, 0, 0), - (0, -1, 0), - (0, 0, -1)); - Divisor: 1; - Bias: 0.5); - - -{ You can register your own canvas class. List of registered canvases is used - by FindBestCanvasForImage functions to find best canvas for given image. - If two different canvases which support the same image data format are - registered then the one that was registered later is returned (so you can - override builtin Imaging canvases).} -procedure RegisterCanvas(CanvasClass: TImagingCanvasClass); -{ Returns best canvas for given TImageFormat.} -function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload; -{ Returns best canvas for given TImageData.} -function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass; overload; -{ Returns best canvas for given TBaseImage.} -function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass; overload; - -implementation - -resourcestring - SConstructorInvalidPointer = 'Invalid pointer (%p) to TImageData passed to TImagingCanvas constructor.'; - SConstructorInvalidImage = 'Invalid image data passed to TImagingCanvas constructor (%s).'; - SConstructorUnsupportedFormat = 'Image passed to TImagingCanvas constructor is in unsupported format (%s)'; - -var - // list with all registered TImagingCanvas classes - CanvasClasses: TList = nil; - -procedure RegisterCanvas(CanvasClass: TImagingCanvasClass); -begin - Assert(CanvasClass <> nil); - if CanvasClasses = nil then - CanvasClasses := TList.Create; - if CanvasClasses.IndexOf(CanvasClass) < 0 then - CanvasClasses.Add(CanvasClass); -end; - -function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload; -var - I: LongInt; -begin - for I := CanvasClasses.Count - 1 downto 0 do - begin - if ImageFormat in TImagingCanvasClass(CanvasClasses[I]).GetSupportedFormats then - begin - Result := TImagingCanvasClass(CanvasClasses[I]); - Exit; - end; - end; - Result := TImagingCanvas; -end; - -function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass; -begin - Result := FindBestCanvasForImage(ImageData.Format); -end; - -function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass; -begin - Result := FindBestCanvasForImage(Image.Format); -end; - -{ Canvas helper functions } - -procedure PixelBlendProc(const SrcPix: TColorFPRec; DestPtr: PByte; - DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); -var - DestPix, FSrc, FDst: TColorFPRec; -begin - // Get set pixel color - DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); - // Determine current blending factors - case SrcFactor of - bfZero: FSrc := ColorFP(0, 0, 0, 0); - bfOne: FSrc := ColorFP(1, 1, 1, 1); - bfSrcAlpha: FSrc := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A); - bfOneMinusSrcAlpha: FSrc := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A); - bfDstAlpha: FSrc := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A); - bfOneMinusDstAlpha: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A); - bfDstColor: FSrc := ColorFP(DestPix.A, DestPix.R, DestPix.G, DestPix.B); - bfOneMinusDstColor: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.R, 1 - DestPix.G, 1 - DestPix.B); - end; - case DestFactor of - bfZero: FDst := ColorFP(0, 0, 0, 0); - bfOne: FDst := ColorFP(1, 1, 1, 1); - bfSrcAlpha: FDst := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A); - bfOneMinusSrcAlpha: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A); - bfDstAlpha: FDst := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A); - bfOneMinusDstAlpha: FDst := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A); - bfSrcColor: FDst := ColorFP(SrcPix.A, SrcPix.R, SrcPix.G, SrcPix.B); - bfOneMinusSrcColor: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.R, 1 - SrcPix.G, 1 - SrcPix.B); - end; - // Compute blending formula - DestPix.R := SrcPix.R * FSrc.R + DestPix.R * FDst.R; - DestPix.G := SrcPix.G * FSrc.G + DestPix.G * FDst.G; - DestPix.B := SrcPix.B * FSrc.B + DestPix.B * FDst.B; - DestPix.A := SrcPix.A * FSrc.A + DestPix.A * FDst.A; - // Write blended pixel - DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); -end; - -procedure PixelAlphaProc(const SrcPix: TColorFPRec; DestPtr: PByte; - DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); -var - DestPix: TColorFPRec; - SrcAlpha, DestAlpha: Single; -begin - DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); - // Blend the two pixels (Src 'over' Dest alpha composition operation) - DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A; - SrcAlpha := IffFloat(DestPix.A = 0, 0, SrcPix.A / DestPix.A); - DestAlpha := 1.0 - SrcAlpha; - DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha; - DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha; - DestPix.B := SrcPix.B * SrcAlpha + DestPix.B * DestAlpha; - // Write blended pixel - DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); -end; - -procedure PixelAddProc(const SrcPix: TColorFPRec; DestPtr: PByte; - DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); -var - DestPix: TColorFPRec; -begin - // Just add Src and Dest - DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); - DestPix.R := SrcPix.R + DestPix.R; - DestPix.G := SrcPix.G + DestPix.G; - DestPix.B := SrcPix.B + DestPix.B; - DestPix.A := SrcPix.A + DestPix.A; - DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); -end; - -function CompareColors(const C1, C2: TColorFPRec): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} -begin - Result := (C1.R * GrayConv.R + C1.G * GrayConv.G + C1.B * GrayConv.B) - - (C2.R * GrayConv.R + C2.G * GrayConv.G + C2.B * GrayConv.B); -end; - -function MedianSelect(var Pixels: TDynFPPixelArray): TColorFPRec; - - procedure QuickSort(L, R: Integer); - var - I, J: Integer; - P, Temp: TColorFPRec; - begin - repeat - I := L; - J := R; - P := Pixels[(L + R) shr 1]; - repeat - while CompareColors(Pixels[I], P) < 0 do Inc(I); - while CompareColors(Pixels[J], P) > 0 do Dec(J); - if I <= J then - begin - Temp := Pixels[I]; - Pixels[I] := Pixels[J]; - Pixels[J] := Temp; - Inc(I); - Dec(J); - end; - until I > J; - if L < J then - QuickSort(L, J); - L := I; - until I >= R; - end; - -begin - // First sort pixels - QuickSort(0, High(Pixels)); - // Select middle pixel - Result := Pixels[Length(Pixels) div 2]; -end; - -function MinSelect(var Pixels: TDynFPPixelArray): TColorFPRec; -var - I: Integer; -begin - Result := Pixels[0]; - for I := 1 to High(Pixels) do - begin - if CompareColors(Pixels[I], Result) < 0 then - Result := Pixels[I]; - end; -end; - -function MaxSelect(var Pixels: TDynFPPixelArray): TColorFPRec; -var - I: Integer; -begin - Result := Pixels[0]; - for I := 1 to High(Pixels) do - begin - if CompareColors(Pixels[I], Result) > 0 then - Result := Pixels[I]; - end; -end; - -function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, P3: Single): TColorFPRec; -begin - Result.A := Pixel.A; - Result.R := Pixel.R * C + B; - Result.G := Pixel.G * C + B; - Result.B := Pixel.B * C + B; -end; - -function TransformGamma(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec; -begin - Result.A := Pixel.A; - Result.R := Power(Pixel.R, 1.0 / R); - Result.G := Power(Pixel.G, 1.0 / G); - Result.B := Power(Pixel.B, 1.0 / B); -end; - -function TransformInvert(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; -begin - Result.A := Pixel.A; - Result.R := 1.0 - Pixel.R; - Result.G := 1.0 - Pixel.G; - Result.B := 1.0 - Pixel.B; -end; - -function TransformThreshold(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec; -begin - Result.A := Pixel.A; - Result.R := IffFloat(Pixel.R >= R, 1.0, 0.0); - Result.G := IffFloat(Pixel.G >= G, 1.0, 0.0); - Result.B := IffFloat(Pixel.B >= B, 1.0, 0.0); -end; - -function TransformLevels(const Pixel: TColorFPRec; BlackPoint, WhitePoint, Exp: Single): TColorFPRec; -begin - Result.A := Pixel.A; - if Pixel.R > BlackPoint then - Result.R := Power((Pixel.R - BlackPoint) / (WhitePoint - BlackPoint), Exp) - else - Result.R := 0.0; - if Pixel.G > BlackPoint then - Result.G := Power((Pixel.G - BlackPoint) / (WhitePoint - BlackPoint), Exp) - else - Result.G := 0.0; - if Pixel.B > BlackPoint then - Result.B := Power((Pixel.B - BlackPoint) / (WhitePoint - BlackPoint), Exp) - else - Result.B := 0.0; -end; - -function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; -begin - Result.A := Pixel.A; - Result.R := Result.R * Pixel.A; - Result.G := Result.G * Pixel.A; - Result.B := Result.B * Pixel.A; -end; - -function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; -begin - Result.A := Pixel.A; - if Pixel.A <> 0.0 then - begin - Result.R := Result.R / Pixel.A; - Result.G := Result.G / Pixel.A; - Result.B := Result.B / Pixel.A; - end - else - begin - Result.R := 0; - Result.G := 0; - Result.B := 0; - end; -end; - - -{ TImagingCanvas class implementation } - -constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData); -begin - if ImageDataPointer = nil then - raise EImagingCanvasError.CreateFmt(SConstructorInvalidPointer, [ImageDataPointer]); - - if not TestImage(ImageDataPointer^) then - raise EImagingCanvasError.CreateFmt(SConstructorInvalidImage, [Imaging.ImageToStr(ImageDataPointer^)]); - - if not (ImageDataPointer.Format in GetSupportedFormats) then - raise EImagingCanvasError.CreateFmt(SConstructorUnsupportedFormat, [Imaging.ImageToStr(ImageDataPointer^)]); - - FPData := ImageDataPointer; - FPenWidth := 1; - SetPenColor32(pcWhite); - SetFillColor32(pcBlack); - FFillMode := fmSolid; - - UpdateCanvasState; -end; - -constructor TImagingCanvas.CreateForImage(Image: TBaseImage); -begin - CreateForData(Image.ImageDataPointer); -end; - -destructor TImagingCanvas.Destroy; -begin - inherited Destroy; -end; - -function TImagingCanvas.GetPixel32(X, Y: LongInt): TColor32; -begin - Result := Imaging.GetPixel32(FPData^, X, Y).Color; -end; - -function TImagingCanvas.GetPixelFP(X, Y: LongInt): TColorFPRec; -begin - Result := Imaging.GetPixelFP(FPData^, X, Y); -end; - -function TImagingCanvas.GetValid: Boolean; -begin - Result := (FPData <> nil) and (FDataSizeOnUpdate = FPData.Size); -end; - -procedure TImagingCanvas.SetPixel32(X, Y: LongInt; const Value: TColor32); -begin - if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and - (X < FClipRect.Right) and (Y < FClipRect.Bottom) then - begin - Imaging.SetPixel32(FPData^, X, Y, TColor32Rec(Value)); - end; -end; - -procedure TImagingCanvas.SetPixelFP(X, Y: LongInt; const Value: TColorFPRec); -begin - if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and - (X < FClipRect.Right) and (Y < FClipRect.Bottom) then - begin - Imaging.SetPixelFP(FPData^, X, Y, TColorFPRec(Value)); - end; -end; - -procedure TImagingCanvas.SetPenColor32(const Value: TColor32); -begin - FPenColor32 := Value; - TranslatePixel(@FPenColor32, @FPenColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil); -end; - -procedure TImagingCanvas.SetPenColorFP(const Value: TColorFPRec); -begin - FPenColorFP := Value; - TranslatePixel(@FPenColorFP, @FPenColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil); -end; - -procedure TImagingCanvas.SetPenWidth(const Value: LongInt); -begin - FPenWidth := ClampInt(Value, 0, MaxPenWidth); -end; - -procedure TImagingCanvas.SetFillColor32(const Value: TColor32); -begin - FFillColor32 := Value; - TranslatePixel(@FFillColor32, @FFillColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil); -end; - -procedure TImagingCanvas.SetFillColorFP(const Value: TColorFPRec); -begin - FFillColorFP := Value; - TranslatePixel(@FFillColorFP, @FFillColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil); -end; - -procedure TImagingCanvas.SetClipRect(const Value: TRect); -begin - FClipRect := Value; - SwapMin(FClipRect.Left, FClipRect.Right); - SwapMin(FClipRect.Top, FClipRect.Bottom); - IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height)); -end; - -procedure TImagingCanvas.CheckBeforeBlending(SrcFactor, - DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas); -begin - if SrcFactor in [bfSrcColor, bfOneMinusSrcColor] then - raise EImagingCanvasBlendingError.Create('Invalid source blending factor. Check the documentation for TBlendingFactor.'); - if DestFactor in [bfDstColor, bfOneMinusDstColor] then - raise EImagingCanvasBlendingError.Create('Invalid destination blending factor. Check the documentation for TBlendingFactor.'); - if DestCanvas.FormatInfo.IsIndexed then - raise EImagingCanvasBlendingError.Create('Blending destination canvas cannot be in indexed mode.'); -end; - -function TImagingCanvas.GetPixelPointer(X, Y: LongInt): Pointer; -begin - Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * FFormatInfo.BytesPerPixel] -end; - -procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec); -begin - TranslateFPToNative(Color, @FNativeColor); -end; - -procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec; - Native: Pointer); -begin - ImagingFormats.TranslatePixel(@Color, Native, ifA32R32G32B32F, - FPData.Format, nil, FPData.Palette); -end; - -procedure TImagingCanvas.UpdateCanvasState; -begin - FDataSizeOnUpdate := FPData.Size; - ResetClipRect; - Imaging.GetImageFormatInfo(FPData.Format, FFormatInfo) -end; - -procedure TImagingCanvas.ResetClipRect; -begin - FClipRect := Rect(0, 0, FPData.Width, FPData.Height) -end; - -procedure TImagingCanvas.Clear; -begin - TranslateFPToNative(FFillColorFP); - Imaging.FillRect(FPData^, 0, 0, FPData.Width, FPData.Height, @FNativeColor); -end; - -function TImagingCanvas.ClipAxisParallelLine(var A1, A2, B: LongInt; - AStart, AStop, BStart, BStop: LongInt): Boolean; -begin - if (B >= BStart) and (B < BStop) then - begin - SwapMin(A1, A2); - if A1 < AStart then A1 := AStart; - if A2 >= AStop then A2 := AStop - 1; - Result := True; - end - else - Result := False; -end; - -procedure TImagingCanvas.HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; - Bpp: LongInt); -var - I, WidthBytes: LongInt; - PixelPtr: PByte; -begin - if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then - begin - SwapMin(X1, X2); - X1 := Max(X1, FClipRect.Left); - X2 := Min(X2, FClipRect.Right); - PixelPtr := GetPixelPointer(X1, Y); - WidthBytes := (X2 - X1) * Bpp; - case Bpp of - 1: FillMemoryByte(PixelPtr, WidthBytes, PByte(Color)^); - 2: FillMemoryWord(PixelPtr, WidthBytes, PWord(Color)^); - 4: FillMemoryLongWord(PixelPtr, WidthBytes, PLongWord(Color)^); - else - for I := X1 to X2 do - begin - ImagingFormats.CopyPixel(Color, PixelPtr, Bpp); - Inc(PixelPtr, Bpp); - end; - end; - end; -end; - -procedure TImagingCanvas.CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; - Bpp: LongInt); -begin - if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and - (X < FClipRect.Right) and (Y < FClipRect.Bottom) then - begin - ImagingFormats.CopyPixel(Pixel, GetPixelPointer(X, Y), Bpp); - end; -end; - -procedure TImagingCanvas.HorzLine(X1, X2, Y: LongInt); -var - DstRect: TRect; -begin - if FPenMode = pmClear then Exit; - SwapMin(X1, X2); - if IntersectRect(DstRect, Rect(X1, Y - FPenWidth div 2, X2, - Y + FPenWidth div 2 + FPenWidth mod 2), FClipRect) then - begin - TranslateFPToNative(FPenColorFP); - Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, - DstRect.Bottom - DstRect.Top, @FNativeColor); - end; -end; - -procedure TImagingCanvas.VertLine(X, Y1, Y2: LongInt); -var - DstRect: TRect; -begin - if FPenMode = pmClear then Exit; - SwapMin(Y1, Y2); - if IntersectRect(DstRect, Rect(X - FPenWidth div 2, Y1, - X + FPenWidth div 2 + FPenWidth mod 2, Y2), FClipRect) then - begin - TranslateFPToNative(FPenColorFP); - Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, - DstRect.Bottom - DstRect.Top, @FNativeColor); - end; -end; - -procedure TImagingCanvas.Line(X1, Y1, X2, Y2: LongInt); -var - Steep: Boolean; - Error, YStep, DeltaX, DeltaY, X, Y, I, Bpp, W1, W2, Code1, Code2: LongInt; -begin - if FPenMode = pmClear then Exit; - - // If line is vertical or horizontal just call appropriate method - if X2 - X1 = 0 then - begin - HorzLine(X1, X2, Y1); - Exit; - end; - if Y2 - Y1 = 0 then - begin - VertLine(X1, Y1, Y2); - Exit; - end; - - // Determine if line is steep (angle with X-axis > 45 degrees) - Steep := Abs(Y2 - Y1) > Abs(X2 - X1); - - // If we need to draw thick line we just draw more 1 pixel lines around - // the one we already drawn. Setting FLineRecursion assures that we - // won't be doing recursions till the end of the world. - if (FPenWidth > 1) and not FLineRecursion then - begin - FLineRecursion := True; - W1 := FPenWidth div 2; - W2 := W1; - if FPenWidth mod 2 = 0 then - Dec(W1); - if Steep then - begin - // Add lines left/right - for I := 1 to W1 do - Line(X1, Y1 - I, X2, Y2 - I); - for I := 1 to W2 do - Line(X1, Y1 + I, X2, Y2 + I); - end - else - begin - // Add lines above/under - for I := 1 to W1 do - Line(X1 - I, Y1, X2 - I, Y2); - for I := 1 to W2 do - Line(X1 + I, Y1, X2 + I, Y2); - end; - FLineRecursion := False; - end; - - with FClipRect do - begin - // Use part of Cohen-Sutherland line clipping to determine if any part of line - // is in ClipRect - Code1 := Ord(X1 < Left) + Ord(X1 > Right) shl 1 + Ord(Y1 < Top) shl 2 + Ord(Y1 > Bottom) shl 3; - Code2 := Ord(X2 < Left) + Ord(X2 > Right) shl 1 + Ord(Y2 < Top) shl 2 + Ord(Y2 > Bottom) shl 3; - end; - - if (Code1 and Code2) = 0 then - begin - TranslateFPToNative(FPenColorFP); - Bpp := FFormatInfo.BytesPerPixel; - - // If line is steep swap X and Y coordinates so later we just have one loop - // of two (where only one is used according to steepness). - if Steep then - begin - SwapValues(X1, Y1); - SwapValues(X2, Y2); - end; - if X1 > X2 then - begin - SwapValues(X1, X2); - SwapValues(Y1, Y2); - end; - - DeltaX := X2 - X1; - DeltaY := Abs(Y2 - Y1); - YStep := Iff(Y2 > Y1, 1, -1); - Error := 0; - Y := Y1; - - // Draw line using Bresenham algorithm. No real line clipping here, - // just don't draw pixels outsize clip rect. - for X := X1 to X2 do - begin - if Steep then - CopyPixelInternal(Y, X, @FNativeColor, Bpp) - else - CopyPixelInternal(X, Y, @FNativeColor, Bpp); - Error := Error + DeltaY; - if Error * 2 >= DeltaX then - begin - Inc(Y, YStep); - Dec(Error, DeltaX); - end; - end; - end; -end; - -procedure TImagingCanvas.FrameRect(const Rect: TRect); -var - HalfPen, PenMod: LongInt; -begin - if FPenMode = pmClear then Exit; - HalfPen := FPenWidth div 2; - PenMod := FPenWidth mod 2; - HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Top); - HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Bottom - 1); - VertLine(Rect.Left, Rect.Top, Rect.Bottom); - VertLine(Rect.Right - 1, Rect.Top, Rect.Bottom); -end; - -procedure TImagingCanvas.FillRect(const Rect: TRect); -var - DstRect: TRect; -begin - if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then - begin - TranslateFPToNative(FFillColorFP); - Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, - DstRect.Bottom - DstRect.Top, @FNativeColor); - end; -end; - -procedure TImagingCanvas.FillRectBlend(const Rect: TRect; SrcFactor, - DestFactor: TBlendingFactor); -var - DstRect: TRect; - X, Y: Integer; - Line: PByte; -begin - if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then - begin - CheckBeforeBlending(SrcFactor, DestFactor, Self); - for Y := DstRect.Top to DstRect.Bottom - 1 do - begin - Line := @PByteArray(FPData.Bits)[(Y * FPData.Width + DstRect.Left) * FFormatInfo.BytesPerPixel]; - for X := DstRect.Left to DstRect.Right - 1 do - begin - PixelBlendProc(FFillColorFP, Line, @FFormatInfo, SrcFactor, DestFactor); - Inc(Line, FFormatInfo.BytesPerPixel); - end; - end; - end; -end; - -procedure TImagingCanvas.Rectangle(const Rect: TRect); -begin - FillRect(Rect); - FrameRect(Rect); -end; - -procedure TImagingCanvas.Ellipse(const Rect: TRect); -var - RadX, RadY, DeltaX, DeltaY, R, RX, RY: LongInt; - X1, X2, Y1, Y2, Bpp, OldY: LongInt; - Fill, Pen: TColorFPRec; -begin - // TODO: Use PenWidth - X1 := Rect.Left; - X2 := Rect.Right; - Y1 := Rect.Top; - Y2 := Rect.Bottom; - - TranslateFPToNative(FPenColorFP, @Pen); - TranslateFPToNative(FFillColorFP, @Fill); - Bpp := FFormatInfo.BytesPerPixel; - - SwapMin(X1, X2); - SwapMin(Y1, Y2); - - RadX := (X2 - X1) div 2; - RadY := (Y2 - Y1) div 2; - - Y1 := Y1 + RadY; - Y2 := Y1; - OldY := Y1; - - DeltaX := (RadX * RadX); - DeltaY := (RadY * RadY); - R := RadX * RadY * RadY; - RX := R; - RY := 0; - - if (FFillMode <> fmClear) then - HorzLineInternal(X1, X2, Y1, @Fill, Bpp); - CopyPixelInternal(X1, Y1, @Pen, Bpp); - CopyPixelInternal(X2, Y1, @Pen, Bpp); - - while RadX > 0 do - begin - if R > 0 then - begin - Inc(Y1); - Dec(Y2); - Inc(RY, DeltaX); - Dec(R, RY); - end; - if R <= 0 then - begin - Dec(RadX); - Inc(X1); - Dec(X2); - Dec(RX, DeltaY); - Inc(R, RX); - end; - - if (OldY <> Y1) and (FFillMode <> fmClear) then - begin - HorzLineInternal(X1, X2, Y1, @Fill, Bpp); - HorzLineInternal(X1, X2, Y2, @Fill, Bpp); - end; - OldY := Y1; - - CopyPixelInternal(X1, Y1, @Pen, Bpp); - CopyPixelInternal(X2, Y1, @Pen, Bpp); - CopyPixelInternal(X1, Y2, @Pen, Bpp); - CopyPixelInternal(X2, Y2, @Pen, Bpp); - end; -end; - -procedure TImagingCanvas.FloodFill(X, Y: Integer; BoundaryFillMode: Boolean); -var - Stack: array of TPoint; - StackPos, Y1: Integer; - OldColor: TColor32; - SpanLeft, SpanRight: Boolean; - - procedure Push(AX, AY: Integer); - begin - if StackPos < High(Stack) then - begin - Inc(StackPos); - Stack[StackPos].X := AX; - Stack[StackPos].Y := AY; - end - else - begin - SetLength(Stack, Length(Stack) + FPData.Width); - Push(AX, AY); - end; - end; - - function Pop(out AX, AY: Integer): Boolean; - begin - if StackPos > 0 then - begin - AX := Stack[StackPos].X; - AY := Stack[StackPos].Y; - Dec(StackPos); - Result := True; - end - else - Result := False; - end; - - function Compare(AX, AY: Integer): Boolean; - var - Color: TColor32; - begin - Color := GetPixel32(AX, AY); - if BoundaryFillMode then - Result := (Color <> FFillColor32) and (Color <> FPenColor32) - else - Result := Color = OldColor; - end; - -begin - // Scanline Floodfill Algorithm With Stack - // http://student.kuleuven.be/~m0216922/CG/floodfill.html - - if not PtInRect(FClipRect, Point(X, Y)) then Exit; - - SetLength(Stack, FPData.Width * 4); - StackPos := 0; - - OldColor := GetPixel32(X, Y); - - Push(X, Y); - - while Pop(X, Y) do - begin - Y1 := Y; - while (Y1 >= FClipRect.Top) and Compare(X, Y1) do - Dec(Y1); - - Inc(Y1); - SpanLeft := False; - SpanRight := False; - - while (Y1 < FClipRect.Bottom) and Compare(X, Y1) do - begin - SetPixel32(X, Y1, FFillColor32); - if not SpanLeft and (X > FClipRect.Left) and Compare(X - 1, Y1) then - begin - Push(X - 1, Y1); - SpanLeft := True; - end - else if SpanLeft and (X > FClipRect.Left) and not Compare(X - 1, Y1) then - SpanLeft := False - else if not SpanRight and (X < FClipRect.Right - 1) and Compare(X + 1, Y1)then - begin - Push(X + 1, Y1); - SpanRight := True; - end - else if SpanRight and (X < FClipRect.Right - 1) and not Compare(X + 1, Y1) then - SpanRight := False; - - Inc(Y1); - end; - end; -end; - -procedure TImagingCanvas.DrawInternal(const SrcRect: TRect; - DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor, - DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc); -var - X, Y, SrcX, SrcY, Width, Height, SrcBpp, DestBpp: Integer; - PSrc: TColorFPRec; - SrcPointer, DestPointer: PByte; -begin - CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas); - SrcX := SrcRect.Left; - SrcY := SrcRect.Top; - Width := SrcRect.Right - SrcRect.Left; - Height := SrcRect.Bottom - SrcRect.Top; - SrcBpp := FFormatInfo.BytesPerPixel; - DestBpp := DestCanvas.FFormatInfo.BytesPerPixel; - // Clip src and dst rects - ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY, - FPData.Width, FPData.Height, DestCanvas.ClipRect); - - for Y := 0 to Height - 1 do - begin - // Get src and dst scanlines - SrcPointer := @PByteArray(FPData.Bits)[((SrcY + Y) * FPData.Width + SrcX) * SrcBpp]; - DestPointer := @PByteArray(DestCanvas.FPData.Bits)[((DestY + Y) * DestCanvas.FPData.Width + DestX) * DestBpp]; - - for X := 0 to Width - 1 do - begin - PSrc := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, FPData.Palette); - // Call pixel writer procedure - combine source and dest pixels - PixelWriteProc(PSrc, DestPointer, @DestCanvas.FFormatInfo, SrcFactor, DestFactor); - // Increment pixel pointers - Inc(SrcPointer, SrcBpp); - Inc(DestPointer, DestBpp); - end; - end; -end; - -procedure TImagingCanvas.DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; - DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor); -begin - DrawInternal(SrcRect, DestCanvas, DestX, DestY, SrcFactor, DestFactor, PixelBlendProc); -end; - -procedure TImagingCanvas.DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; - DestX, DestY: Integer); -begin - DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAlphaProc); -end; - -procedure TImagingCanvas.DrawAdd(const SrcRect: TRect; - DestCanvas: TImagingCanvas; DestX, DestY: Integer); -begin - DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAddProc); -end; - -procedure TImagingCanvas.StretchDrawInternal(const SrcRect: TRect; - DestCanvas: TImagingCanvas; const DestRect: TRect; - SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter; - PixelWriteProc: TPixelWriteProc); -const - FilterMapping: array[TResizeFilter] of TSamplingFilter = - (sfNearest, sfLinear, DefaultCubicFilter); -var - X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: Integer; - DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: Integer; - SrcPix, PDest: TColorFPRec; - MapX, MapY: TMappingTable; - XMinimum, XMaximum: Integer; - LineBuffer: array of TColorFPRec; - ClusterX, ClusterY: TCluster; - Weight, AccumA, AccumR, AccumG, AccumB: Single; - DestLine: PByte; - FilterFunction: TFilterFunction; - Radius: Single; -begin - CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas); - SrcX := SrcRect.Left; - SrcY := SrcRect.Top; - SrcWidth := SrcRect.Right - SrcRect.Left; - SrcHeight := SrcRect.Bottom - SrcRect.Top; - DestX := DestRect.Left; - DestY := DestRect.Top; - DestWidth := DestRect.Right - DestRect.Left; - DestHeight := DestRect.Bottom - DestRect.Top; - SrcBpp := FFormatInfo.BytesPerPixel; - DestBpp := DestCanvas.FFormatInfo.BytesPerPixel; - // Get actual resampling filter and radius - FilterFunction := SamplingFilterFunctions[FilterMapping[Filter]]; - Radius := SamplingFilterRadii[FilterMapping[Filter]]; - // Clip src and dst rects - ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight, - FPData.Width, FPData.Height, DestCanvas.ClipRect); - // Generate mapping tables - MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth, - FPData.Width, FilterFunction, Radius, False); - MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight, - FPData.Height, FilterFunction, Radius, False); - FindExtremes(MapX, XMinimum, XMaximum); - SetLength(LineBuffer, XMaximum - XMinimum + 1); - - for J := 0 to DestHeight - 1 do - begin - ClusterY := MapY[J]; - for X := XMinimum to XMaximum do - begin - AccumA := 0.0; - AccumR := 0.0; - AccumG := 0.0; - AccumB := 0.0; - for Y := 0 to Length(ClusterY) - 1 do - begin - Weight := ClusterY[Y].Weight; - SrcPix := FFormatInfo.GetPixelFP(@PByteArray(FPData.Bits)[(ClusterY[Y].Pos * FPData.Width + X) * SrcBpp], - @FFormatInfo, FPData.Palette); - AccumB := AccumB + SrcPix.B * Weight; - AccumG := AccumG + SrcPix.G * Weight; - AccumR := AccumR + SrcPix.R * Weight; - AccumA := AccumA + SrcPix.A * Weight; - end; - with LineBuffer[X - XMinimum] do - begin - A := AccumA; - R := AccumR; - G := AccumG; - B := AccumB; - end; - end; - - DestLine := @PByteArray(DestCanvas.FPData.Bits)[((J + DestY) * DestCanvas.FPData.Width + DestX) * DestBpp]; - - for I := 0 to DestWidth - 1 do - begin - ClusterX := MapX[I]; - AccumA := 0.0; - AccumR := 0.0; - AccumG := 0.0; - AccumB := 0.0; - for X := 0 to Length(ClusterX) - 1 do - begin - Weight := ClusterX[X].Weight; - with LineBuffer[ClusterX[X].Pos - XMinimum] do - begin - AccumB := AccumB + B * Weight; - AccumG := AccumG + G * Weight; - AccumR := AccumR + R * Weight; - AccumA := AccumA + A * Weight; - end; - end; - - SrcPix.A := AccumA; - SrcPix.R := AccumR; - SrcPix.G := AccumG; - SrcPix.B := AccumB; - - // Write resulting blended pixel - PixelWriteProc(SrcPix, DestLine, @DestCanvas.FFormatInfo, SrcFactor, DestFactor); - Inc(DestLine, DestBpp); - end; - end; -end; - -procedure TImagingCanvas.StretchDrawBlend(const SrcRect: TRect; - DestCanvas: TImagingCanvas; const DestRect: TRect; - SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter); -begin - StretchDrawInternal(SrcRect, DestCanvas, DestRect, SrcFactor, DestFactor, Filter, PixelBlendProc); -end; - -procedure TImagingCanvas.StretchDrawAlpha(const SrcRect: TRect; - DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); -begin - StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAlphaProc); -end; - -procedure TImagingCanvas.StretchDrawAdd(const SrcRect: TRect; - DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); -begin - StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAddProc); -end; - -procedure TImagingCanvas.ApplyConvolution(Kernel: PLongInt; KernelSize, - Divisor: LongInt; Bias: Single; ClampChannels: Boolean); -var - X, Y, I, J, PosY, PosX, SizeDiv2, KernelValue, WidthBytes, Bpp: LongInt; - R, G, B, DivFloat: Single; - Pixel: TColorFPRec; - TempImage: TImageData; - DstPointer, SrcPointer: PByte; -begin - SizeDiv2 := KernelSize div 2; - DivFloat := IffFloat(Divisor > 1, 1.0 / Divisor, 1.0); - Bpp := FFormatInfo.BytesPerPixel; - WidthBytes := FPData.Width * Bpp; - - InitImage(TempImage); - CloneImage(FPData^, TempImage); - - try - // For every pixel in clip rect - for Y := FClipRect.Top to FClipRect.Bottom - 1 do - begin - DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; - - for X := FClipRect.Left to FClipRect.Right - 1 do - begin - // Reset accumulators - R := 0.0; - G := 0.0; - B := 0.0; - - for J := 0 to KernelSize - 1 do - begin - PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1); - - for I := 0 to KernelSize - 1 do - begin - PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1); - SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp]; - - // Get pixels from neighbourhood of current pixel and add their - // colors to accumulators weighted by filter kernel values - Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette); - KernelValue := PLongIntArray(Kernel)[J * KernelSize + I]; - - R := R + Pixel.R * KernelValue; - G := G + Pixel.G * KernelValue; - B := B + Pixel.B * KernelValue; - end; - end; - - Pixel := FFormatInfo.GetPixelFP(DstPointer, @FFormatInfo, FPData.Palette); - - Pixel.R := R * DivFloat + Bias; - Pixel.G := G * DivFloat + Bias; - Pixel.B := B * DivFloat + Bias; - - if ClampChannels then - ClampFloatPixel(Pixel); - - // Set resulting pixel color - FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel); - - Inc(DstPointer, Bpp); - end; - end; - - finally - FreeImage(TempImage); - end; -end; - -procedure TImagingCanvas.ApplyConvolution3x3(const Filter: TConvolutionFilter3x3); -begin - ApplyConvolution(@Filter.Kernel, 3, Filter.Divisor, Filter.Bias, True); -end; - -procedure TImagingCanvas.ApplyConvolution5x5(const Filter: TConvolutionFilter5x5); -begin - ApplyConvolution(@Filter.Kernel, 5, Filter.Divisor, Filter.Bias, True); -end; - -procedure TImagingCanvas.ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction); -var - X, Y, I, J, PosY, PosX, SizeDiv2, WidthBytes, Bpp: LongInt; - Pixel: TColorFPRec; - TempImage: TImageData; - DstPointer, SrcPointer: PByte; - NeighPixels: TDynFPPixelArray; -begin - SizeDiv2 := FilterSize div 2; - Bpp := FFormatInfo.BytesPerPixel; - WidthBytes := FPData.Width * Bpp; - SetLength(NeighPixels, FilterSize * FilterSize); - - InitImage(TempImage); - CloneImage(FPData^, TempImage); - - try - // For every pixel in clip rect - for Y := FClipRect.Top to FClipRect.Bottom - 1 do - begin - DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; - - for X := FClipRect.Left to FClipRect.Right - 1 do - begin - for J := 0 to FilterSize - 1 do - begin - PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1); - - for I := 0 to FilterSize - 1 do - begin - PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1); - SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp]; - - // Get pixels from neighbourhood of current pixel and store them - Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette); - NeighPixels[J * FilterSize + I] := Pixel; - end; - end; - - // Choose pixel using custom function - Pixel := SelectFunc(NeighPixels); - // Set resulting pixel color - FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel); - - Inc(DstPointer, Bpp); - end; - end; - - finally - FreeImage(TempImage); - end; -end; - -procedure TImagingCanvas.ApplyMedianFilter(FilterSize: Integer); -begin - ApplyNonLinearFilter(FilterSize, MedianSelect); -end; - -procedure TImagingCanvas.ApplyMinFilter(FilterSize: Integer); -begin - ApplyNonLinearFilter(FilterSize, MinSelect); -end; - -procedure TImagingCanvas.ApplyMaxFilter(FilterSize: Integer); -begin - ApplyNonLinearFilter(FilterSize, MaxSelect); -end; - -procedure TImagingCanvas.PointTransform(Transform: TPointTransformFunction; - Param1, Param2, Param3: Single); -var - X, Y, Bpp, WidthBytes: Integer; - PixPointer: PByte; - Pixel: TColorFPRec; -begin - Bpp := FFormatInfo.BytesPerPixel; - WidthBytes := FPData.Width * Bpp; - - // For every pixel in clip rect - for Y := FClipRect.Top to FClipRect.Bottom - 1 do - begin - PixPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; - for X := FClipRect.Left to FClipRect.Right - 1 do - begin - Pixel := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette); - - FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, - Transform(Pixel, Param1, Param2, Param3)); - - Inc(PixPointer, Bpp); - end; - end; -end; - -procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single); -begin - PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100, - Brightness / 100, 0); -end; - -procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single); -begin - PointTransform(TransformGamma, Red, Green, Blue); -end; - -procedure TImagingCanvas.InvertColors; -begin - PointTransform(TransformInvert, 0, 0, 0); -end; - -procedure TImagingCanvas.Threshold(Red, Green, Blue: Single); -begin - PointTransform(TransformThreshold, Red, Green, Blue); -end; - -procedure TImagingCanvas.AdjustColorLevels(BlackPoint, WhitePoint, MidPoint: Single); -begin - PointTransform(TransformLevels, BlackPoint, WhitePoint, 1.0 / MidPoint); -end; - -procedure TImagingCanvas.PremultiplyAlpha; -begin - PointTransform(TransformPremultiplyAlpha, 0, 0, 0); -end; - -procedure TImagingCanvas.UnPremultiplyAlpha; -begin - PointTransform(TransformUnPremultiplyAlpha, 0, 0, 0); -end; - -procedure TImagingCanvas.GetHistogram(out Red, Green, Blue, Alpha, - Gray: THistogramArray); -var - X, Y, Bpp: Integer; - PixPointer: PByte; - Color32: TColor32Rec; -begin - FillChar(Red, SizeOf(Red), 0); - FillChar(Green, SizeOf(Green), 0); - FillChar(Blue, SizeOf(Blue), 0); - FillChar(Alpha, SizeOf(Alpha), 0); - FillChar(Gray, SizeOf(Gray), 0); - - Bpp := FFormatInfo.BytesPerPixel; - - for Y := FClipRect.Top to FClipRect.Bottom - 1 do - begin - PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp]; - for X := FClipRect.Left to FClipRect.Right - 1 do - begin - Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette); - - Inc(Red[Color32.R]); - Inc(Green[Color32.G]); - Inc(Blue[Color32.B]); - Inc(Alpha[Color32.A]); - Inc(Gray[Round(GrayConv.R * Color32.R + GrayConv.G * Color32.G + GrayConv.B * Color32.B)]); - - Inc(PixPointer, Bpp); - end; - end; -end; - -procedure TImagingCanvas.FillChannel(ChannelId: Integer; NewChannelValue: Byte); -var - X, Y, Bpp: Integer; - PixPointer: PByte; - Color32: TColor32Rec; -begin - Bpp := FFormatInfo.BytesPerPixel; - - for Y := FClipRect.Top to FClipRect.Bottom - 1 do - begin - PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp]; - for X := FClipRect.Left to FClipRect.Right - 1 do - begin - Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette); - Color32.Channels[ChannelId] := NewChannelValue; - FFormatInfo.SetPixel32(PixPointer, @FFormatInfo, FPData.Palette, Color32); - - Inc(PixPointer, Bpp); - end; - end; -end; - -procedure TImagingCanvas.FillChannelFP(ChannelId: Integer; NewChannelValue: Single); -var - X, Y, Bpp: Integer; - PixPointer: PByte; - ColorFP: TColorFPRec; -begin - Bpp := FFormatInfo.BytesPerPixel; - - for Y := FClipRect.Top to FClipRect.Bottom - 1 do - begin - PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp]; - for X := FClipRect.Left to FClipRect.Right - 1 do - begin - ColorFP := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette); - ColorFP.Channels[ChannelId] := NewChannelValue; - FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, ColorFP); - - Inc(PixPointer, Bpp); - end; - end; -end; - -class function TImagingCanvas.GetSupportedFormats: TImageFormats; -begin - Result := [ifIndex8..Pred(ifDXT1)]; -end; - -{ TFastARGB32Canvas } - -destructor TFastARGB32Canvas.Destroy; -begin - FreeMem(FScanlines); - inherited Destroy; -end; - -procedure TFastARGB32Canvas.AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); -var - SrcAlpha, DestAlpha, FinalAlpha: Integer; -begin - FinalAlpha := SrcPix.A + 1 + (DestPix.A * (256 - SrcPix.A)) shr 8; - if FinalAlpha = 0 then - SrcAlpha := 0 - else - SrcAlpha := (SrcPix.A shl 8) div FinalAlpha; - DestAlpha := 256 - SrcAlpha; - - DestPix.A := ClampToByte(FinalAlpha); - DestPix.R := (SrcPix.R * SrcAlpha + DestPix.R * DestAlpha) shr 8; - DestPix.G := (SrcPix.G * SrcAlpha + DestPix.G * DestAlpha) shr 8; - DestPix.B := (SrcPix.B * SrcAlpha + DestPix.B * DestAlpha) shr 8; -end; - -procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect; - DestCanvas: TImagingCanvas; DestX, DestY: Integer); -var - X, Y, SrcX, SrcY, Width, Height: Integer; - SrcPix, DestPix: PColor32Rec; -begin - if DestCanvas.ClassType <> Self.ClassType then - begin - inherited; - Exit; - end; - - SrcX := SrcRect.Left; - SrcY := SrcRect.Top; - Width := SrcRect.Right - SrcRect.Left; - Height := SrcRect.Bottom - SrcRect.Top; - ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY, - FPData.Width, FPData.Height, DestCanvas.ClipRect); - - for Y := 0 to Height - 1 do - begin - SrcPix := @FScanlines[SrcY + Y, SrcX]; - DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + Y, DestX]; - for X := 0 to Width - 1 do - begin - AlphaBlendPixels(SrcPix, DestPix); - Inc(SrcPix); - Inc(DestPix); - end; - end; -end; - -function TFastARGB32Canvas.GetPixel32(X, Y: LongInt): TColor32; -begin - Result := FScanlines[Y, X].Color; -end; - -procedure TFastARGB32Canvas.SetPixel32(X, Y: LongInt; const Value: TColor32); -begin - if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and - (X < FClipRect.Right) and (Y < FClipRect.Bottom) then - begin - FScanlines[Y, X].Color := Value; - end; -end; - -procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect; - DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); -var - X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4, - FracX, FracY, InvFracY, T1, T2: Integer; - SrcX, SrcY, SrcWidth, SrcHeight: Integer; - DestX, DestY, DestWidth, DestHeight: Integer; - SrcLine, SrcLine2: PColor32RecArray; - DestPix: PColor32Rec; - Accum: TColor32Rec; -begin - if (Filter = rfBicubic) or (DestCanvas.ClassType <> Self.ClassType) then - begin - inherited; - Exit; - end; - - SrcX := SrcRect.Left; - SrcY := SrcRect.Top; - SrcWidth := SrcRect.Right - SrcRect.Left; - SrcHeight := SrcRect.Bottom - SrcRect.Top; - DestX := DestRect.Left; - DestY := DestRect.Top; - DestWidth := DestRect.Right - DestRect.Left; - DestHeight := DestRect.Bottom - DestRect.Top; - // Clip src and dst rects - ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight, - FPData.Width, FPData.Height, DestCanvas.ClipRect); - ScaleX := (SrcWidth shl 16) div DestWidth; - ScaleY := (SrcHeight shl 16) div DestHeight; - - // Nearest and linear filtering using fixed point math - - if Filter = rfNearest then - begin - Yp := 0; - for Y := DestY to DestY + DestHeight - 1 do - begin - Xp := 0; - SrcLine := @FScanlines[SrcY + Yp shr 16, SrcX]; - DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX]; - for X := 0 to DestWidth - 1 do - begin - AlphaBlendPixels(@SrcLine[Xp shr 16], DestPix); - Inc(DestPix); - Inc(Xp, ScaleX); - end; - Inc(Yp, ScaleY); - end; - end - else - begin - Yp := (ScaleY shr 1) - $8000; - for Y := DestY to DestY + DestHeight - 1 do - begin - DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX]; - if Yp < 0 then - begin - T1 := 0; - FracY := 0; - InvFracY := $10000; - end - else - begin - T1 := Yp shr 16; - FracY := Yp and $FFFF; - InvFracY := (not Yp and $FFFF) + 1; - end; - - T2 := Iff(T1 < SrcHeight - 1, T1 + 1, T1); - SrcLine := @Scanlines[T1 + SrcY, SrcX]; - SrcLine2 := @Scanlines[T2 + SrcY, SrcX]; - Xp := (ScaleX shr 1) - $8000; - - for X := 0 to DestWidth - 1 do - begin - if Xp < 0 then - begin - T1 := 0; - FracX := 0; - end - else - begin - T1 := Xp shr 16; - FracX := Xp and $FFFF; - end; - - T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1); - Weight2:= (Cardinal(InvFracY) * FracX) shr 16; // cast to Card, Int can overflow gere - Weight1:= InvFracY - Weight2; - Weight4:= (Cardinal(FracY) * FracX) shr 16; - Weight3:= FracY - Weight4; - - Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 + - SrcLine2[T1].B * Weight3 + SrcLine2[T2].B * Weight4 + $8000) shr 16; - Accum.G := (SrcLine[T1].G * Weight1 + SrcLine[T2].G * Weight2 + - SrcLine2[T1].G * Weight3 + SrcLine2[T2].G * Weight4 + $8000) shr 16; - Accum.R := (SrcLine[T1].R * Weight1 + SrcLine[T2].R * Weight2 + - SrcLine2[T1].R * Weight3 + SrcLine2[T2].R * Weight4 + $8000) shr 16; - Accum.A := (SrcLine[T1].A * Weight1 + SrcLine[T2].A * Weight2 + - SrcLine2[T1].A * Weight3 + SrcLine2[T2].A * Weight4 + $8000) shr 16; - - AlphaBlendPixels(@Accum, DestPix); - - Inc(Xp, ScaleX); - Inc(DestPix); - end; - Inc(Yp, ScaleY); - end; - end; - { - - // Generate mapping tables - MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth, - FPData.Width, FilterFunction, Radius, False); - MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight, - FPData.Height, FilterFunction, Radius, False); - FindExtremes(MapX, XMinimum, XMaximum); - SetLength(LineBuffer, XMaximum - XMinimum + 1); - - for J := 0 to DestHeight - 1 do - begin - ClusterY := MapY[J]; - for X := XMinimum to XMaximum do - begin - AccumA := 0; - AccumR := 0; - AccumG := 0; - AccumB := 0; - for Y := 0 to Length(ClusterY) - 1 do - begin - Weight := Round(ClusterY[Y].Weight * 256); - SrcColor := FScanlines[ClusterY[Y].Pos, X]; - - AccumB := AccumB + SrcColor.B * Weight; - AccumG := AccumG + SrcColor.G * Weight; - AccumR := AccumR + SrcColor.R * Weight; - AccumA := AccumA + SrcColor.A * Weight; - end; - with LineBuffer[X - XMinimum] do - begin - A := AccumA; - R := AccumR; - G := AccumG; - B := AccumB; - end; - end; - - DestPtr := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + J, DestX]; - - for I := 0 to DestWidth - 1 do - begin - ClusterX := MapX[I]; - AccumA := 0; - AccumR := 0; - AccumG := 0; - AccumB := 0; - for X := 0 to Length(ClusterX) - 1 do - begin - Weight := Round(ClusterX[X].Weight * 256); - with LineBuffer[ClusterX[X].Pos - XMinimum] do - begin - AccumB := AccumB + B * Weight; - AccumG := AccumG + G * Weight; - AccumR := AccumR + R * Weight; - AccumA := AccumA + A * Weight; - end; - end; - - AccumA := ClampInt(AccumA, 0, $00FF0000); - AccumR := ClampInt(AccumR, 0, $00FF0000); - AccumG := ClampInt(AccumG, 0, $00FF0000); - AccumB := ClampInt(AccumB, 0, $00FF0000); - SrcColor.Color := (Cardinal(AccumA and $00FF0000) shl 8) or - (AccumR and $00FF0000) or ((AccumG and $00FF0000) shr 8) or ((AccumB and $00FF0000) shr 16); - - AlphaBlendPixels(@SrcColor, DestPtr); - - Inc(DestPtr); - end; - end; } -end; - -procedure TFastARGB32Canvas.UpdateCanvasState; -var - I: LongInt; - ScanPos: PLongWord; -begin - inherited UpdateCanvasState; - - // Realloc and update scanline array - ReallocMem(FScanlines, FPData.Height * SizeOf(PColor32RecArray)); - ScanPos := FPData.Bits; - - for I := 0 to FPData.Height - 1 do - begin - FScanlines[I] := PColor32RecArray(ScanPos); - Inc(ScanPos, FPData.Width); - end; -end; - -class function TFastARGB32Canvas.GetSupportedFormats: TImageFormats; -begin - Result := [ifA8R8G8B8]; -end; - -procedure TFastARGB32Canvas.InvertColors; -var - X, Y: Integer; - PixPtr: PColor32Rec; -begin - for Y := FClipRect.Top to FClipRect.Bottom - 1 do - begin - PixPtr := @FScanlines[Y, FClipRect.Left]; - for X := FClipRect.Left to FClipRect.Right - 1 do - begin - PixPtr.R := not PixPtr.R; - PixPtr.G := not PixPtr.G; - PixPtr.B := not PixPtr.B; - Inc(PixPtr); - end; - end; -end; - -initialization - RegisterCanvas(TFastARGB32Canvas); - -finalization - FreeAndNil(CanvasClasses); - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - more more more ... - - implement pen width everywhere - - add blending (*image and object drawing) - - more objects (arc, polygon) - - -- 0.26.3 Changes/Bug Fixes --------------------------------- - - Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha) - - Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation. - - Added PremultiplyAlpha and UnPremultiplyAlpha methods. - - -- 0.26.1 Changes/Bug Fixes --------------------------------- - - Added FillChannel methods. - - Added FloodFill method. - - Added GetHistogram method. - - Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes - (thanks to Carlos González). - - Added TImagingCanvas.AdjustColorLevels method. - - -- 0.25.0 Changes/Bug Fixes --------------------------------- - - Fixed error that could cause AV in linear and nonlinear filters. - - Added blended rect filling function FillRectBlend. - - Added drawing function with blending (DrawAlpha, StretchDrawAlpha, - StretchDrawAdd, DrawBlend, StretchDrawBlend, ...) - - Added non-linear filters (min, max, median). - - Added point transforms (invert, contrast, gamma, brightness). - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Added some new filter kernels for convolution. - - Added FillMode and PenMode properties. - - Added FrameRect, Rectangle, Ellipse, and Line methods. - - Removed HorzLine and VertLine from TFastARGB32Canvas - new versions - in general canvas is now as fast as those in TFastARGB32Canvas - (only in case of A8R8G8B8 images of course). - - Added PenWidth property, updated HorzLine and VertLine to use it. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - added TFastARGB32Canvas - - added convolutions, hline, vline - - unit created, intial stuff added - -} - -end. - +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains canvas classes for drawing and applying effects.} +unit ImagingCanvases; + +{$I ImagingOptions.inc} + +interface + +uses + SysUtils, Types, Classes, ImagingTypes, Imaging, ImagingClasses, + ImagingFormats, ImagingUtility; + +const + { Color constants in ifA8R8G8B8 format.} + pcClear = $00000000; + pcBlack = $FF000000; + pcWhite = $FFFFFFFF; + pcMaroon = $FF800000; + pcGreen = $FF008000; + pcOlive = $FF808000; + pcNavy = $FF000080; + pcPurple = $FF800080; + pcTeal = $FF008080; + pcGray = $FF808080; + pcSilver = $FFC0C0C0; + pcRed = $FFFF0000; + pcLime = $FF00FF00; + pcYellow = $FFFFFF00; + pcBlue = $FF0000FF; + pcFuchsia = $FFFF00FF; + pcAqua = $FF00FFFF; + pcLtGray = $FFC0C0C0; + pcDkGray = $FF808080; + + MaxPenWidth = 256; + +type + EImagingCanvasError = class(EImagingError); + EImagingCanvasBlendingError = class(EImagingError); + + { Fill mode used when drawing filled objects on canvas.} + TFillMode = ( + fmSolid, // Solid fill using current fill color + fmClear // No filling done + ); + + { Pen mode used when drawing lines, object outlines, and similar on canvas.} + TPenMode = ( + pmSolid, // Draws solid lines using current pen color. + pmClear // No drawing done + ); + + { Source and destination blending factors for drawing functions with blending. + Blending formula: SrcColor * SrcFactor + DestColor * DestFactor } + TBlendingFactor = ( + bfIgnore, // Don't care + bfZero, // For Src and Dest, Factor = (0, 0, 0, 0) + bfOne, // For Src and Dest, Factor = (1, 1, 1, 1) + bfSrcAlpha, // For Src and Dest, Factor = (Src.A, Src.A, Src.A, Src.A) + bfOneMinusSrcAlpha, // For Src and Dest, Factor = (1 - Src.A, 1 - Src.A, 1 - Src.A, 1 - Src.A) + bfDstAlpha, // For Src and Dest, Factor = (Dest.A, Dest.A, Dest.A, Dest.A) + bfOneMinusDstAlpha, // For Src and Dest, Factor = (1 - Dest.A, 1 - Dest.A, 1 - Dest.A, 1 - Dest.A) + bfSrcColor, // For Dest, Factor = (Src.R, Src.R, Src.B, Src.A) + bfOneMinusSrcColor, // For Dest, Factor = (1 - Src.R, 1 - Src.G, 1 - Src.B, 1 - Src.A) + bfDstColor, // For Src, Factor = (Dest.R, Dest.G, Dest.B, Dest.A) + bfOneMinusDstColor // For Src, Factor = (1 - Dest.R, 1 - Dest.G, 1 - Dest.B, 1 - Dest.A) + ); + + { Procedure for custom pixel write modes with blending.} + TPixelWriteProc = procedure(const SrcPix: TColorFPRec; DestPtr: PByte; + DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); + + { Represents 3x3 convolution filter kernel.} + TConvolutionFilter3x3 = record + Kernel: array[0..2, 0..2] of LongInt; + Divisor: LongInt; + Bias: Single; + end; + + { Represents 5x5 convolution filter kernel.} + TConvolutionFilter5x5 = record + Kernel: array[0..4, 0..4] of LongInt; + Divisor: LongInt; + Bias: Single; + end; + + TPointTransformFunction = function(const Pixel: TColorFPRec; + Param1, Param2, Param3: Single): TColorFPRec; + + TDynFPPixelArray = array of TColorFPRec; + + THistogramArray = array[Byte] of Integer; + + TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec; + + { Base canvas class for drawing objects, applying effects, and other. + Constructor takes TBaseImage (or pointer to TImageData). Source image + bits are not copied but referenced so all canvas functions affect + source image and vice versa. When you change format or resolution of + source image you must call UpdateCanvasState method (so canvas could + recompute some data size related stuff). + + TImagingCanvas works for all image data formats except special ones + (compressed). Because of this its methods are quite slow (they usually work + with colors in ifA32R32G32B32F format). If you want fast drawing you + can use one of fast canvas classes. These descendants of TImagingCanvas + work only for few select formats (or only one) but they are optimized thus + much faster. + } + TImagingCanvas = class(TObject) + private + FDataSizeOnUpdate: LongInt; + FLineRecursion: Boolean; + function GetPixel32(X, Y: LongInt): TColor32; virtual; + function GetPixelFP(X, Y: LongInt): TColorFPRec; virtual; + function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetPixel32(X, Y: LongInt; const Value: TColor32); virtual; + procedure SetPixelFP(X, Y: LongInt; const Value: TColorFPRec); virtual; + procedure SetPenColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetPenColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetPenWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetFillColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetFillColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetClipRect(const Value: TRect); + procedure CheckBeforeBlending(SrcFactor, DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas); + protected + FPData: PImageData; + FClipRect: TRect; + FPenColorFP: TColorFPRec; + FPenColor32: TColor32; + FPenMode: TPenMode; + FPenWidth: LongInt; + FFillColorFP: TColorFPRec; + FFillColor32: TColor32; + FFillMode: TFillMode; + FNativeColor: TColorFPRec; + FFormatInfo: TImageFormatInfo; + + { Returns pointer to pixel at given position.} + function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} + { Translates given FP color to native format of canvas and stores it + in FNativeColor field (its bit copy) or user pointer (in overloaded method).} + procedure TranslateFPToNative(const Color: TColorFPRec); overload; {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure TranslateFPToNative(const Color: TColorFPRec; Native: Pointer); overload; {$IFDEF USE_INLINE}inline;{$ENDIF} + { Clipping function used by horizontal and vertical line drawing functions.} + function ClipAxisParallelLine(var A1, A2, B: LongInt; + AStart, AStop, BStart, BStop: LongInt): Boolean; + { Internal horizontal line drawer used mainly for filling inside of objects + like ellipses and circles.} + procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual; + procedure CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; + DestX, DestY: LongInt; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc); + procedure StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; + const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; + Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc); + public + constructor CreateForData(ImageDataPointer: PImageData); + constructor CreateForImage(Image: TBaseImage); + destructor Destroy; override; + + { Call this method when you change size or format of image this canvas + operates on (like calling ResizeImage, ConvertImage, or changing Format + property of TBaseImage descendants).} + procedure UpdateCanvasState; virtual; + { Resets clipping rectangle to Rect(0, 0, ImageWidth, ImageHeight).} + procedure ResetClipRect; + + { Clears entire canvas with current fill color (ignores clipping rectangle + and always uses fmSolid fill mode).} + procedure Clear; + + { Draws horizontal line with current pen settings.} + procedure HorzLine(X1, X2, Y: LongInt); virtual; + { Draws vertical line with current pen settings.} + procedure VertLine(X, Y1, Y2: LongInt); virtual; + { Draws line from [X1, Y1] to [X2, Y2] with current pen settings.} + procedure Line(X1, Y1, X2, Y2: LongInt); virtual; + { Draws a rectangle using current pen settings.} + procedure FrameRect(const Rect: TRect); + { Fills given rectangle with current fill settings.} + procedure FillRect(const Rect: TRect); virtual; + { Fills given rectangle with current fill settings and pixel blending.} + procedure FillRectBlend(const Rect: TRect; SrcFactor, DestFactor: TBlendingFactor); + { Draws rectangle which is outlined by using the current pen settings and + filled by using the current fill settings.} + procedure Rectangle(const Rect: TRect); + { Draws ellipse which is outlined by using the current pen settings and + filled by using the current fill settings. Rect specifies bounding rectangle + of ellipse to be drawn.} + procedure Ellipse(const Rect: TRect); + { Fills area of canvas with current fill color starting at point [X, Y] and + coloring its neighbors. Default flood fill mode changes color of all + neighbors with the same color as pixel [X, Y]. With BoundaryFillMode + set to True neighbors are recolored regardless of their old color, + but area which will be recolored has boundary (specified by current pen color).} + procedure FloodFill(X, Y: Integer; BoundaryFillMode: Boolean = False); + + { Draws contents of this canvas onto another canvas with pixel blending. + Blending factors are chosen using TBlendingFactor parameters. + Resulting destination pixel color is: + SrcColor * SrcFactor + DstColor * DstFactor} + procedure DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; + DestX, DestY: LongInt; SrcFactor, DestFactor: TBlendingFactor); + { Draws contents of this canvas onto another one with typical alpha + blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} + procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: LongInt); virtual; + { Draws contents of this canvas onto another one using additive blending + (source and dest factors are bfOne).} + procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: LongInt); + { Draws stretched and filtered contents of this canvas onto another canvas + with pixel blending. Blending factors are chosen using TBlendingFactor parameters. + Resulting destination pixel color is: + SrcColor * SrcFactor + DstColor * DstFactor} + procedure StretchDrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; + const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; + Filter: TResizeFilter = rfBilinear); + { Draws contents of this canvas onto another one with typical alpha + blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} + procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; + const DestRect: TRect; Filter: TResizeFilter = rfBilinear); virtual; + { Draws contents of this canvas onto another one using additive blending + (source and dest factors are bfOne).} + procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; + const DestRect: TRect; Filter: TResizeFilter = rfBilinear); + + { Convolves canvas' image with given 3x3 filter kernel. You can use + predefined filter kernels or define your own.} + procedure ApplyConvolution3x3(const Filter: TConvolutionFilter3x3); + { Convolves canvas' image with given 5x5 filter kernel. You can use + predefined filter kernels or define your own.} + procedure ApplyConvolution5x5(const Filter: TConvolutionFilter5x5); + { Computes 2D convolution of canvas' image and given filter kernel. + Kernel is in row format and KernelSize must be odd number >= 3. Divisor + is normalizing value based on Kernel (usually sum of all kernel's cells). + The Bias number shifts each color value by a fixed amount (color values + are usually in range [0, 1] during processing). If ClampChannels + is True all output color values are clamped to [0, 1]. You can use + predefined filter kernels or define your own.} + procedure ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt; + Bias: Single = 0.0; ClampChannels: Boolean = True); virtual; + + { Applies custom non-linear filter. Filter size is diameter of pixel + neighborhood. Typical values are 3, 5, or 7. } + procedure ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction); + { Applies median non-linear filter with user defined pixel neighborhood. + Selects median pixel from the neighborhood as new pixel + (current implementation is quite slow).} + procedure ApplyMedianFilter(FilterSize: Integer); + { Applies min non-linear filter with user defined pixel neighborhood. + Selects min pixel from the neighborhood as new pixel.} + procedure ApplyMinFilter(FilterSize: Integer); + { Applies max non-linear filter with user defined pixel neighborhood. + Selects max pixel from the neighborhood as new pixel.} + procedure ApplyMaxFilter(FilterSize: Integer); + + { Transforms pixels one by one by given function. Pixel neighbors are + not taken into account. Param 1-3 are optional parameters + for transform function.} + procedure PointTransform(Transform: TPointTransformFunction; + Param1, Param2, Param3: Single); + { Modifies image contrast and brightness. Parameters should be + in range <-100; 100>.} + procedure ModifyContrastBrightness(Contrast, Brightness: Single); + { Gamma correction of individual color channels. Range is (0, +inf), + 1.0 means no change.} + procedure GammaCorrection(Red, Green, Blue: Single); + { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.} + procedure InvertColors; virtual; + { Simple single level thresholding with threshold level (in range [0, 1]) + for each color channel.} + procedure Threshold(Red, Green, Blue: Single); + { Adjusts the color levels of the image by scaling the + colors falling between specified white and black points to full [0, 1] range. + The black point specifies the darkest color in the image, white point + specifies the lightest color, and mid point is gamma aplied to image. + Black and white point must be in range [0, 1].} + procedure AdjustColorLevels(BlackPoint, WhitePoint: Single; MidPoint: Single = 1.0); + { Premultiplies color channel values by alpha. Needed for some platforms/APIs + to display images with alpha properly.} + procedure PremultiplyAlpha; + { Reverses PremultiplyAlpha operation.} + procedure UnPremultiplyAlpha; + + { Calculates image histogram for each channel and also gray values. Each + channel has 256 values available. Channel values of data formats with higher + precision are scaled and rounded. Example: Red[126] specifies number of pixels + in image with red channel = 126.} + procedure GetHistogram(out Red, Green, Blue, Alpha, Gray: THistogramArray); + { Fills image channel with given value leaving other channels intact. + Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as + channel identifier.} + procedure FillChannel(ChannelId: Integer; NewChannelValue: Byte); overload; + { Fills image channel with given value leaving other channels intact. + Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as + channel identifier.} + procedure FillChannelFP(ChannelId: Integer; NewChannelValue: Single); overload; + + { Color used when drawing lines, frames, and outlines of objects.} + property PenColor32: TColor32 read FPenColor32 write SetPenColor32; + { Color used when drawing lines, frames, and outlines of objects.} + property PenColorFP: TColorFPRec read FPenColorFP write SetPenColorFP; + { Pen mode used when drawing lines, object outlines, and similar on canvas.} + property PenMode: TPenMode read FPenMode write FPenMode; + { Width with which objects like lines, frames, etc. (everything which uses + PenColor) are drawn.} + property PenWidth: LongInt read FPenWidth write SetPenWidth; + { Color used for filling when drawing various objects.} + property FillColor32: TColor32 read FFillColor32 write SetFillColor32; + { Color used for filling when drawing various objects.} + property FillColorFP: TColorFPRec read FFillColorFP write SetFillColorFP; + { Fill mode used when drawing filled objects on canvas.} + property FillMode: TFillMode read FFillMode write FFillMode; + { Specifies the current color of the pixels of canvas. Native pixel is + read from canvas and then translated to 32bit ARGB. Reverse operation + is made when setting pixel color.} + property Pixels32[X, Y: LongInt]: TColor32 read GetPixel32 write SetPixel32; + { Specifies the current color of the pixels of canvas. Native pixel is + read from canvas and then translated to FP ARGB. Reverse operation + is made when setting pixel color.} + property PixelsFP[X, Y: LongInt]: TColorFPRec read GetPixelFP write SetPixelFP; + { Clipping rectangle of this canvas. No pixels outside this rectangle are + altered by canvas methods if Clipping property is True. Clip rect gets + reset when UpdateCanvasState is called.} + property ClipRect: TRect read FClipRect write SetClipRect; + { Extended format information.} + property FormatInfo: TImageFormatInfo read FFormatInfo; + { Indicates that this canvas is in valid state. If False canvas operations + may crash.} + property Valid: Boolean read GetValid; + + { Returns all formats supported by this canvas class.} + class function GetSupportedFormats: TImageFormats; virtual; + end; + + TImagingCanvasClass = class of TImagingCanvas; + + TScanlineArray = array[0..MaxInt div SizeOf(Pointer) - 1] of PColor32RecArray; + PScanlineArray = ^TScanlineArray; + + { Fast canvas class for ifA8R8G8B8 format images.} + TFastARGB32Canvas = class(TImagingCanvas) + protected + FScanlines: PScanlineArray; + procedure AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetPixel32(X, Y: LongInt): TColor32; override; + procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override; + public + destructor Destroy; override; + + procedure UpdateCanvasState; override; + + procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: LongInt); override; + procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; + const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override; + procedure InvertColors; override; + + property Scanlines: PScanlineArray read FScanlines; + + class function GetSupportedFormats: TImageFormats; override; + end; + +const + { Kernel for 3x3 average smoothing filter.} + FilterAverage3x3: TConvolutionFilter3x3 = ( + Kernel: ((1, 1, 1), + (1, 1, 1), + (1, 1, 1)); + Divisor: 9; + Bias: 0); + + { Kernel for 5x5 average smoothing filter.} + FilterAverage5x5: TConvolutionFilter5x5 = ( + Kernel: ((1, 1, 1, 1, 1), + (1, 1, 1, 1, 1), + (1, 1, 1, 1, 1), + (1, 1, 1, 1, 1), + (1, 1, 1, 1, 1)); + Divisor: 25; + Bias: 0); + + { Kernel for 3x3 Gaussian smoothing filter.} + FilterGaussian3x3: TConvolutionFilter3x3 = ( + Kernel: ((1, 2, 1), + (2, 4, 2), + (1, 2, 1)); + Divisor: 16; + Bias: 0); + + { Kernel for 5x5 Gaussian smoothing filter.} + FilterGaussian5x5: TConvolutionFilter5x5 = ( + Kernel: ((1, 4, 6, 4, 1), + (4, 16, 24, 16, 4), + (6, 24, 36, 24, 6), + (4, 16, 24, 16, 4), + (1, 4, 6, 4, 1)); + Divisor: 256; + Bias: 0); + + { Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).} + FilterSobelHorz3x3: TConvolutionFilter3x3 = ( + Kernel: (( 1, 2, 1), + ( 0, 0, 0), + (-1, -2, -1)); + Divisor: 1; + Bias: 0); + + { Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).} + FilterSobelVert3x3: TConvolutionFilter3x3 = ( + Kernel: ((-1, 0, 1), + (-2, 0, 2), + (-1, 0, 1)); + Divisor: 1; + Bias: 0); + + { Kernel for 3x3 Prewitt horizontal edge detection filter.} + FilterPrewittHorz3x3: TConvolutionFilter3x3 = ( + Kernel: (( 1, 1, 1), + ( 0, 0, 0), + (-1, -1, -1)); + Divisor: 1; + Bias: 0); + + { Kernel for 3x3 Prewitt vertical edge detection filter.} + FilterPrewittVert3x3: TConvolutionFilter3x3 = ( + Kernel: ((-1, 0, 1), + (-1, 0, 1), + (-1, 0, 1)); + Divisor: 1; + Bias: 0); + + { Kernel for 3x3 Kirsh horizontal edge detection filter.} + FilterKirshHorz3x3: TConvolutionFilter3x3 = ( + Kernel: (( 5, 5, 5), + (-3, 0, -3), + (-3, -3, -3)); + Divisor: 1; + Bias: 0); + + { Kernel for 3x3 Kirsh vertical edge detection filter.} + FilterKirshVert3x3: TConvolutionFilter3x3 = ( + Kernel: ((5, -3, -3), + (5, 0, -3), + (5, -3, -3)); + Divisor: 1; + Bias: 0); + + { Kernel for 3x3 Laplace omni-directional edge detection filter + (2nd derivative approximation).} + FilterLaplace3x3: TConvolutionFilter3x3 = ( + Kernel: ((-1, -1, -1), + (-1, 8, -1), + (-1, -1, -1)); + Divisor: 1; + Bias: 0); + + { Kernel for 5x5 Laplace omni-directional edge detection filter + (2nd derivative approximation).} + FilterLaplace5x5: TConvolutionFilter5x5 = ( + Kernel: ((-1, -1, -1, -1, -1), + (-1, -1, -1, -1, -1), + (-1, -1, 24, -1, -1), + (-1, -1, -1, -1, -1), + (-1, -1, -1, -1, -1)); + Divisor: 1; + Bias: 0); + + { Kernel for 3x3 sharpening filter (Laplacian + original color).} + FilterSharpen3x3: TConvolutionFilter3x3 = ( + Kernel: ((-1, -1, -1), + (-1, 9, -1), + (-1, -1, -1)); + Divisor: 1; + Bias: 0); + + { Kernel for 5x5 sharpening filter (Laplacian + original color).} + FilterSharpen5x5: TConvolutionFilter5x5 = ( + Kernel: ((-1, -1, -1, -1, -1), + (-1, -1, -1, -1, -1), + (-1, -1, 25, -1, -1), + (-1, -1, -1, -1, -1), + (-1, -1, -1, -1, -1)); + Divisor: 1; + Bias: 0); + + { Kernel for 5x5 glow filter.} + FilterGlow5x5: TConvolutionFilter5x5 = ( + Kernel: (( 1, 2, 2, 2, 1), + ( 2, 0, 0, 0, 2), + ( 2, 0, -20, 0, 2), + ( 2, 0, 0, 0, 2), + ( 1, 2, 2, 2, 1)); + Divisor: 8; + Bias: 0); + + { Kernel for 3x3 edge enhancement filter.} + FilterEdgeEnhance3x3: TConvolutionFilter3x3 = ( + Kernel: ((-1, -2, -1), + (-2, 16, -2), + (-1, -2, -1)); + Divisor: 4; + Bias: 0); + + { Kernel for 3x3 contour enhancement filter.} + FilterTraceContour3x3: TConvolutionFilter3x3 = ( + Kernel: ((-6, -6, -2), + (-1, 32, -1), + (-6, -2, -6)); + Divisor: 4; + Bias: 240/255); + + { Kernel for filter that negates all images pixels.} + FilterNegative3x3: TConvolutionFilter3x3 = ( + Kernel: ((0, 0, 0), + (0, -1, 0), + (0, 0, 0)); + Divisor: 1; + Bias: 1); + + { Kernel for 3x3 horz/vert embossing filter.} + FilterEmboss3x3: TConvolutionFilter3x3 = ( + Kernel: ((2, 0, 0), + (0, -1, 0), + (0, 0, -1)); + Divisor: 1; + Bias: 0.5); + + +{ You can register your own canvas class. List of registered canvases is used + by FindBestCanvasForImage functions to find best canvas for given image. + If two different canvases which support the same image data format are + registered then the one that was registered later is returned (so you can + override builtin Imaging canvases).} +procedure RegisterCanvas(CanvasClass: TImagingCanvasClass); +{ Returns best canvas for given TImageFormat.} +function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload; +{ Returns best canvas for given TImageData.} +function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass; overload; +{ Returns best canvas for given TBaseImage.} +function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass; overload; + +implementation + +resourcestring + SConstructorInvalidPointer = 'Invalid pointer (%p) to TImageData passed to TImagingCanvas constructor.'; + SConstructorInvalidImage = 'Invalid image data passed to TImagingCanvas constructor (%s).'; + SConstructorUnsupportedFormat = 'Image passed to TImagingCanvas constructor is in unsupported format (%s)'; + +var + // list with all registered TImagingCanvas classes + CanvasClasses: TList = nil; + +procedure RegisterCanvas(CanvasClass: TImagingCanvasClass); +begin + Assert(CanvasClass <> nil); + if CanvasClasses = nil then + CanvasClasses := TList.Create; + if CanvasClasses.IndexOf(CanvasClass) < 0 then + CanvasClasses.Add(CanvasClass); +end; + +function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload; +var + I: LongInt; +begin + for I := CanvasClasses.Count - 1 downto 0 do + begin + if ImageFormat in TImagingCanvasClass(CanvasClasses[I]).GetSupportedFormats then + begin + Result := TImagingCanvasClass(CanvasClasses[I]); + Exit; + end; + end; + Result := TImagingCanvas; +end; + +function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass; +begin + Result := FindBestCanvasForImage(ImageData.Format); +end; + +function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass; +begin + Result := FindBestCanvasForImage(Image.Format); +end; + +{ Canvas helper functions } + +procedure PixelBlendProc(const SrcPix: TColorFPRec; DestPtr: PByte; + DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); +var + DestPix, FSrc, FDst: TColorFPRec; +begin + // Get set pixel color + DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); + // Determine current blending factors + case SrcFactor of + bfZero: FSrc := ColorFP(0, 0, 0, 0); + bfOne: FSrc := ColorFP(1, 1, 1, 1); + bfSrcAlpha: FSrc := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A); + bfOneMinusSrcAlpha: FSrc := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A); + bfDstAlpha: FSrc := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A); + bfOneMinusDstAlpha: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A); + bfDstColor: FSrc := ColorFP(DestPix.A, DestPix.R, DestPix.G, DestPix.B); + bfOneMinusDstColor: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.R, 1 - DestPix.G, 1 - DestPix.B); + else + Assert(False); + end; + case DestFactor of + bfZero: FDst := ColorFP(0, 0, 0, 0); + bfOne: FDst := ColorFP(1, 1, 1, 1); + bfSrcAlpha: FDst := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A); + bfOneMinusSrcAlpha: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A); + bfDstAlpha: FDst := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A); + bfOneMinusDstAlpha: FDst := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A); + bfSrcColor: FDst := ColorFP(SrcPix.A, SrcPix.R, SrcPix.G, SrcPix.B); + bfOneMinusSrcColor: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.R, 1 - SrcPix.G, 1 - SrcPix.B); + else + Assert(False); + end; + // Compute blending formula + DestPix.R := SrcPix.R * FSrc.R + DestPix.R * FDst.R; + DestPix.G := SrcPix.G * FSrc.G + DestPix.G * FDst.G; + DestPix.B := SrcPix.B * FSrc.B + DestPix.B * FDst.B; + DestPix.A := SrcPix.A * FSrc.A + DestPix.A * FDst.A; + // Write blended pixel + DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); +end; + +procedure PixelAlphaProc(const SrcPix: TColorFPRec; DestPtr: PByte; + DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); +var + DestPix: TColorFPRec; + SrcAlpha, DestAlpha: Single; +begin + DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); + // Blend the two pixels (Src 'over' Dest alpha composition operation) + DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A; + if DestPix.A = 0 then + SrcAlpha := 0 + else + SrcAlpha := SrcPix.A / DestPix.A; + DestAlpha := 1.0 - SrcAlpha; + DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha; + DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha; + DestPix.B := SrcPix.B * SrcAlpha + DestPix.B * DestAlpha; + // Write blended pixel + DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); +end; + +procedure PixelAddProc(const SrcPix: TColorFPRec; DestPtr: PByte; + DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); +var + DestPix: TColorFPRec; +begin + // Just add Src and Dest + DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); + DestPix.R := SrcPix.R + DestPix.R; + DestPix.G := SrcPix.G + DestPix.G; + DestPix.B := SrcPix.B + DestPix.B; + DestPix.A := SrcPix.A + DestPix.A; + DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); +end; + +function CompareColors(const C1, C2: TColorFPRec): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} +begin + Result := (C1.R * GrayConv.R + C1.G * GrayConv.G + C1.B * GrayConv.B) - + (C2.R * GrayConv.R + C2.G * GrayConv.G + C2.B * GrayConv.B); +end; + +function MedianSelect(var Pixels: TDynFPPixelArray): TColorFPRec; + + procedure QuickSort(L, R: Integer); + var + I, J: Integer; + P, Temp: TColorFPRec; + begin + repeat + I := L; + J := R; + P := Pixels[(L + R) shr 1]; + repeat + while CompareColors(Pixels[I], P) < 0 do Inc(I); + while CompareColors(Pixels[J], P) > 0 do Dec(J); + if I <= J then + begin + Temp := Pixels[I]; + Pixels[I] := Pixels[J]; + Pixels[J] := Temp; + Inc(I); + Dec(J); + end; + until I > J; + if L < J then + QuickSort(L, J); + L := I; + until I >= R; + end; + +begin + // First sort pixels + QuickSort(0, High(Pixels)); + // Select middle pixel + Result := Pixels[Length(Pixels) div 2]; +end; + +function MinSelect(var Pixels: TDynFPPixelArray): TColorFPRec; +var + I: Integer; +begin + Result := Pixels[0]; + for I := 1 to High(Pixels) do + begin + if CompareColors(Pixels[I], Result) < 0 then + Result := Pixels[I]; + end; +end; + +function MaxSelect(var Pixels: TDynFPPixelArray): TColorFPRec; +var + I: Integer; +begin + Result := Pixels[0]; + for I := 1 to High(Pixels) do + begin + if CompareColors(Pixels[I], Result) > 0 then + Result := Pixels[I]; + end; +end; + +function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, P3: Single): TColorFPRec; +begin + Result.A := Pixel.A; + Result.R := Pixel.R * C + B; + Result.G := Pixel.G * C + B; + Result.B := Pixel.B * C + B; +end; + +function TransformGamma(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec; +begin + Result.A := Pixel.A; + Result.R := Power(Pixel.R, 1.0 / R); + Result.G := Power(Pixel.G, 1.0 / G); + Result.B := Power(Pixel.B, 1.0 / B); +end; + +function TransformInvert(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; +begin + Result.A := Pixel.A; + Result.R := 1.0 - Pixel.R; + Result.G := 1.0 - Pixel.G; + Result.B := 1.0 - Pixel.B; +end; + +function TransformThreshold(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec; +begin + Result.A := Pixel.A; + Result.R := IffFloat(Pixel.R >= R, 1.0, 0.0); + Result.G := IffFloat(Pixel.G >= G, 1.0, 0.0); + Result.B := IffFloat(Pixel.B >= B, 1.0, 0.0); +end; + +function TransformLevels(const Pixel: TColorFPRec; BlackPoint, WhitePoint, Exp: Single): TColorFPRec; +begin + Result.A := Pixel.A; + if Pixel.R > BlackPoint then + Result.R := Power((Pixel.R - BlackPoint) / (WhitePoint - BlackPoint), Exp) + else + Result.R := 0.0; + if Pixel.G > BlackPoint then + Result.G := Power((Pixel.G - BlackPoint) / (WhitePoint - BlackPoint), Exp) + else + Result.G := 0.0; + if Pixel.B > BlackPoint then + Result.B := Power((Pixel.B - BlackPoint) / (WhitePoint - BlackPoint), Exp) + else + Result.B := 0.0; +end; + +function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; +begin + Result.A := Pixel.A; + Result.R := Pixel.R * Pixel.A; + Result.G := Pixel.G * Pixel.A; + Result.B := Pixel.B * Pixel.A; +end; + +function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; +begin + Result.A := Pixel.A; + if Pixel.A <> 0.0 then + begin + Result.R := Pixel.R / Pixel.A; + Result.G := Pixel.G / Pixel.A; + Result.B := Pixel.B / Pixel.A; + end + else + begin + Result.R := 0; + Result.G := 0; + Result.B := 0; + end; +end; + + +{ TImagingCanvas class implementation } + +constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData); +begin + if ImageDataPointer = nil then + raise EImagingCanvasError.CreateFmt(SConstructorInvalidPointer, [ImageDataPointer]); + + if not TestImage(ImageDataPointer^) then + raise EImagingCanvasError.CreateFmt(SConstructorInvalidImage, [Imaging.ImageToStr(ImageDataPointer^)]); + + if not (ImageDataPointer.Format in GetSupportedFormats) then + raise EImagingCanvasError.CreateFmt(SConstructorUnsupportedFormat, [Imaging.ImageToStr(ImageDataPointer^)]); + + FPData := ImageDataPointer; + FPenWidth := 1; + SetPenColor32(pcWhite); + SetFillColor32(pcBlack); + FFillMode := fmSolid; + + UpdateCanvasState; +end; + +constructor TImagingCanvas.CreateForImage(Image: TBaseImage); +begin + CreateForData(Image.ImageDataPointer); +end; + +destructor TImagingCanvas.Destroy; +begin + inherited Destroy; +end; + +function TImagingCanvas.GetPixel32(X, Y: LongInt): TColor32; +begin + Result := Imaging.GetPixel32(FPData^, X, Y).Color; +end; + +function TImagingCanvas.GetPixelFP(X, Y: LongInt): TColorFPRec; +begin + Result := Imaging.GetPixelFP(FPData^, X, Y); +end; + +function TImagingCanvas.GetValid: Boolean; +begin + Result := (FPData <> nil) and (FDataSizeOnUpdate = FPData.Size); +end; + +procedure TImagingCanvas.SetPixel32(X, Y: LongInt; const Value: TColor32); +begin + if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and + (X < FClipRect.Right) and (Y < FClipRect.Bottom) then + begin + Imaging.SetPixel32(FPData^, X, Y, TColor32Rec(Value)); + end; +end; + +procedure TImagingCanvas.SetPixelFP(X, Y: LongInt; const Value: TColorFPRec); +begin + if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and + (X < FClipRect.Right) and (Y < FClipRect.Bottom) then + begin + Imaging.SetPixelFP(FPData^, X, Y, TColorFPRec(Value)); + end; +end; + +procedure TImagingCanvas.SetPenColor32(const Value: TColor32); +begin + FPenColor32 := Value; + TranslatePixel(@FPenColor32, @FPenColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil); +end; + +procedure TImagingCanvas.SetPenColorFP(const Value: TColorFPRec); +begin + FPenColorFP := Value; + TranslatePixel(@FPenColorFP, @FPenColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil); +end; + +procedure TImagingCanvas.SetPenWidth(const Value: LongInt); +begin + FPenWidth := ClampInt(Value, 0, MaxPenWidth); +end; + +procedure TImagingCanvas.SetFillColor32(const Value: TColor32); +begin + FFillColor32 := Value; + TranslatePixel(@FFillColor32, @FFillColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil); +end; + +procedure TImagingCanvas.SetFillColorFP(const Value: TColorFPRec); +begin + FFillColorFP := Value; + TranslatePixel(@FFillColorFP, @FFillColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil); +end; + +procedure TImagingCanvas.SetClipRect(const Value: TRect); +begin + FClipRect := Value; + NormalizeRect(FClipRect); + IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height)); +end; + +procedure TImagingCanvas.CheckBeforeBlending(SrcFactor, + DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas); +begin + if SrcFactor in [bfSrcColor, bfOneMinusSrcColor] then + raise EImagingCanvasBlendingError.Create('Invalid source blending factor. Check the documentation for TBlendingFactor.'); + if DestFactor in [bfDstColor, bfOneMinusDstColor] then + raise EImagingCanvasBlendingError.Create('Invalid destination blending factor. Check the documentation for TBlendingFactor.'); + if DestCanvas.FormatInfo.IsIndexed then + raise EImagingCanvasBlendingError.Create('Blending destination canvas cannot be in indexed mode.'); +end; + +function TImagingCanvas.GetPixelPointer(X, Y: LongInt): Pointer; +begin + Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * FFormatInfo.BytesPerPixel] +end; + +procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec); +begin + TranslateFPToNative(Color, @FNativeColor); +end; + +procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec; + Native: Pointer); +begin + ImagingFormats.TranslatePixel(@Color, Native, ifA32R32G32B32F, + FPData.Format, nil, FPData.Palette); +end; + +procedure TImagingCanvas.UpdateCanvasState; +begin + FDataSizeOnUpdate := FPData.Size; + ResetClipRect; + Imaging.GetImageFormatInfo(FPData.Format, FFormatInfo) +end; + +procedure TImagingCanvas.ResetClipRect; +begin + FClipRect := Rect(0, 0, FPData.Width, FPData.Height) +end; + +procedure TImagingCanvas.Clear; +begin + TranslateFPToNative(FFillColorFP); + Imaging.FillRect(FPData^, 0, 0, FPData.Width, FPData.Height, @FNativeColor); +end; + +function TImagingCanvas.ClipAxisParallelLine(var A1, A2, B: LongInt; + AStart, AStop, BStart, BStop: LongInt): Boolean; +begin + if (B >= BStart) and (B < BStop) then + begin + SwapMin(A1, A2); + if A1 < AStart then A1 := AStart; + if A2 >= AStop then A2 := AStop - 1; + Result := True; + end + else + Result := False; +end; + +procedure TImagingCanvas.HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; + Bpp: LongInt); +var + I, WidthBytes: LongInt; + PixelPtr: PByte; +begin + if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then + begin + SwapMin(X1, X2); + X1 := Max(X1, FClipRect.Left); + X2 := Min(X2, FClipRect.Right); + PixelPtr := GetPixelPointer(X1, Y); + WidthBytes := (X2 - X1) * Bpp; + case Bpp of + 1: FillMemoryByte(PixelPtr, WidthBytes, PByte(Color)^); + 2: FillMemoryWord(PixelPtr, WidthBytes, PWord(Color)^); + 4: FillMemoryUInt32(PixelPtr, WidthBytes, PUInt32(Color)^); + else + for I := X1 to X2 do + begin + ImagingFormats.CopyPixel(Color, PixelPtr, Bpp); + Inc(PixelPtr, Bpp); + end; + end; + end; +end; + +procedure TImagingCanvas.CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; + Bpp: LongInt); +begin + if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and + (X < FClipRect.Right) and (Y < FClipRect.Bottom) then + begin + ImagingFormats.CopyPixel(Pixel, GetPixelPointer(X, Y), Bpp); + end; +end; + +procedure TImagingCanvas.HorzLine(X1, X2, Y: LongInt); +var + DstRect: TRect; +begin + if FPenMode = pmClear then Exit; + SwapMin(X1, X2); + if IntersectRect(DstRect, Rect(X1, Y - FPenWidth div 2, X2, + Y + FPenWidth div 2 + FPenWidth mod 2), FClipRect) then + begin + TranslateFPToNative(FPenColorFP); + Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, + DstRect.Bottom - DstRect.Top, @FNativeColor); + end; +end; + +procedure TImagingCanvas.VertLine(X, Y1, Y2: LongInt); +var + DstRect: TRect; +begin + if FPenMode = pmClear then Exit; + SwapMin(Y1, Y2); + if IntersectRect(DstRect, Rect(X - FPenWidth div 2, Y1, + X + FPenWidth div 2 + FPenWidth mod 2, Y2), FClipRect) then + begin + TranslateFPToNative(FPenColorFP); + Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, + DstRect.Bottom - DstRect.Top, @FNativeColor); + end; +end; + +procedure TImagingCanvas.Line(X1, Y1, X2, Y2: LongInt); +var + Steep: Boolean; + Error, YStep, DeltaX, DeltaY, X, Y, I, Bpp, W1, W2, Code1, Code2: LongInt; +begin + if FPenMode = pmClear then Exit; + + // If line is vertical or horizontal just call appropriate method + if X2 = X1 then + begin + VertLine(X1, Y1, Y2); + Exit; + end; + if Y2 = Y1 then + begin + HorzLine(X1, X2, Y1); + Exit; + end; + + // Determine if line is steep (angle with X-axis > 45 degrees) + Steep := Abs(Y2 - Y1) > Abs(X2 - X1); + + // If we need to draw thick line we just draw more 1 pixel lines around + // the one we already drawn. Setting FLineRecursion assures that we + // won't be doing recursions till the end of the world. + if (FPenWidth > 1) and not FLineRecursion then + begin + FLineRecursion := True; + W1 := FPenWidth div 2; + W2 := W1; + if FPenWidth mod 2 = 0 then + Dec(W1); + if Steep then + begin + // Add lines left/right + for I := 1 to W1 do + Line(X1, Y1 - I, X2, Y2 - I); + for I := 1 to W2 do + Line(X1, Y1 + I, X2, Y2 + I); + end + else + begin + // Add lines above/under + for I := 1 to W1 do + Line(X1 - I, Y1, X2 - I, Y2); + for I := 1 to W2 do + Line(X1 + I, Y1, X2 + I, Y2); + end; + FLineRecursion := False; + end; + + with FClipRect do + begin + // Use part of Cohen-Sutherland line clipping to determine if any part of line + // is in ClipRect + Code1 := Ord(X1 < Left) + Ord(X1 > Right) shl 1 + Ord(Y1 < Top) shl 2 + Ord(Y1 > Bottom) shl 3; + Code2 := Ord(X2 < Left) + Ord(X2 > Right) shl 1 + Ord(Y2 < Top) shl 2 + Ord(Y2 > Bottom) shl 3; + end; + + if (Code1 and Code2) = 0 then + begin + TranslateFPToNative(FPenColorFP); + Bpp := FFormatInfo.BytesPerPixel; + + // If line is steep swap X and Y coordinates so later we just have one loop + // of two (where only one is used according to steepness). + if Steep then + begin + SwapValues(X1, Y1); + SwapValues(X2, Y2); + end; + if X1 > X2 then + begin + SwapValues(X1, X2); + SwapValues(Y1, Y2); + end; + + DeltaX := X2 - X1; + DeltaY := Abs(Y2 - Y1); + YStep := Iff(Y2 > Y1, 1, -1); + Error := 0; + Y := Y1; + + // Draw line using Bresenham algorithm. No real line clipping here, + // just don't draw pixels outsize clip rect. + for X := X1 to X2 do + begin + if Steep then + CopyPixelInternal(Y, X, @FNativeColor, Bpp) + else + CopyPixelInternal(X, Y, @FNativeColor, Bpp); + Error := Error + DeltaY; + if Error * 2 >= DeltaX then + begin + Inc(Y, YStep); + Dec(Error, DeltaX); + end; + end; + end; +end; + +procedure TImagingCanvas.FrameRect(const Rect: TRect); +var + HalfPen, PenMod: LongInt; +begin + if FPenMode = pmClear then Exit; + HalfPen := FPenWidth div 2; + PenMod := FPenWidth mod 2; + HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Top); + HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Bottom - 1); + VertLine(Rect.Left, Rect.Top, Rect.Bottom); + VertLine(Rect.Right - 1, Rect.Top, Rect.Bottom); +end; + +procedure TImagingCanvas.FillRect(const Rect: TRect); +var + DstRect: TRect; +begin + if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then + begin + TranslateFPToNative(FFillColorFP); + Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, + DstRect.Bottom - DstRect.Top, @FNativeColor); + end; +end; + +procedure TImagingCanvas.FillRectBlend(const Rect: TRect; SrcFactor, + DestFactor: TBlendingFactor); +var + DstRect: TRect; + X, Y: Integer; + Line: PByte; +begin + if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then + begin + CheckBeforeBlending(SrcFactor, DestFactor, Self); + for Y := DstRect.Top to DstRect.Bottom - 1 do + begin + Line := @PByteArray(FPData.Bits)[(Y * FPData.Width + DstRect.Left) * FFormatInfo.BytesPerPixel]; + for X := DstRect.Left to DstRect.Right - 1 do + begin + PixelBlendProc(FFillColorFP, Line, @FFormatInfo, SrcFactor, DestFactor); + Inc(Line, FFormatInfo.BytesPerPixel); + end; + end; + end; +end; + +procedure TImagingCanvas.Rectangle(const Rect: TRect); +begin + FillRect(Rect); + FrameRect(Rect); +end; + +procedure TImagingCanvas.Ellipse(const Rect: TRect); +var + RadX, RadY, DeltaX, DeltaY, R, RX, RY: LongInt; + X1, X2, Y1, Y2, Bpp, OldY: LongInt; + Fill, Pen: TColorFPRec; +begin + // TODO: Use PenWidth + X1 := Rect.Left; + X2 := Rect.Right; + Y1 := Rect.Top; + Y2 := Rect.Bottom; + + TranslateFPToNative(FPenColorFP, @Pen); + TranslateFPToNative(FFillColorFP, @Fill); + Bpp := FFormatInfo.BytesPerPixel; + + SwapMin(X1, X2); + SwapMin(Y1, Y2); + + RadX := (X2 - X1) div 2; + RadY := (Y2 - Y1) div 2; + + Y1 := Y1 + RadY; + Y2 := Y1; + OldY := Y1; + + DeltaX := (RadX * RadX); + DeltaY := (RadY * RadY); + R := RadX * RadY * RadY; + RX := R; + RY := 0; + + if (FFillMode <> fmClear) then + HorzLineInternal(X1, X2, Y1, @Fill, Bpp); + CopyPixelInternal(X1, Y1, @Pen, Bpp); + CopyPixelInternal(X2, Y1, @Pen, Bpp); + + while RadX > 0 do + begin + if R > 0 then + begin + Inc(Y1); + Dec(Y2); + Inc(RY, DeltaX); + Dec(R, RY); + end; + if R <= 0 then + begin + Dec(RadX); + Inc(X1); + Dec(X2); + Dec(RX, DeltaY); + Inc(R, RX); + end; + + if (OldY <> Y1) and (FFillMode <> fmClear) then + begin + HorzLineInternal(X1, X2, Y1, @Fill, Bpp); + HorzLineInternal(X1, X2, Y2, @Fill, Bpp); + end; + OldY := Y1; + + CopyPixelInternal(X1, Y1, @Pen, Bpp); + CopyPixelInternal(X2, Y1, @Pen, Bpp); + CopyPixelInternal(X1, Y2, @Pen, Bpp); + CopyPixelInternal(X2, Y2, @Pen, Bpp); + end; +end; + +procedure TImagingCanvas.FloodFill(X, Y: Integer; BoundaryFillMode: Boolean); +var + Stack: array of TPoint; + StackPos, Y1: Integer; + OldColor: TColor32; + SpanLeft, SpanRight: Boolean; + + procedure Push(AX, AY: Integer); + begin + if StackPos < High(Stack) then + begin + Inc(StackPos); + Stack[StackPos].X := AX; + Stack[StackPos].Y := AY; + end + else + begin + SetLength(Stack, Length(Stack) + FPData.Width); + Push(AX, AY); + end; + end; + + function Pop(out AX, AY: Integer): Boolean; + begin + if StackPos > 0 then + begin + AX := Stack[StackPos].X; + AY := Stack[StackPos].Y; + Dec(StackPos); + Result := True; + end + else + Result := False; + end; + + function Compare(AX, AY: Integer): Boolean; + var + Color: TColor32; + begin + Color := GetPixel32(AX, AY); + if BoundaryFillMode then + Result := (Color <> FFillColor32) and (Color <> FPenColor32) + else + Result := Color = OldColor; + end; + +begin + // Scanline Floodfill Algorithm With Stack + // http://student.kuleuven.be/~m0216922/CG/floodfill.html + + if not PtInRect(FClipRect, Point(X, Y)) then Exit; + + SetLength(Stack, FPData.Width * 4); + StackPos := 0; + + OldColor := GetPixel32(X, Y); + + Push(X, Y); + + while Pop(X, Y) do + begin + Y1 := Y; + while (Y1 >= FClipRect.Top) and Compare(X, Y1) do + Dec(Y1); + + Inc(Y1); + SpanLeft := False; + SpanRight := False; + + while (Y1 < FClipRect.Bottom) and Compare(X, Y1) do + begin + SetPixel32(X, Y1, FFillColor32); + if not SpanLeft and (X > FClipRect.Left) and Compare(X - 1, Y1) then + begin + Push(X - 1, Y1); + SpanLeft := True; + end + else if SpanLeft and (X > FClipRect.Left) and not Compare(X - 1, Y1) then + SpanLeft := False + else if not SpanRight and (X < FClipRect.Right - 1) and Compare(X + 1, Y1)then + begin + Push(X + 1, Y1); + SpanRight := True; + end + else if SpanRight and (X < FClipRect.Right - 1) and not Compare(X + 1, Y1) then + SpanRight := False; + + Inc(Y1); + end; + end; +end; + +procedure TImagingCanvas.DrawInternal(const SrcRect: TRect; + DestCanvas: TImagingCanvas; DestX, DestY: LongInt; SrcFactor, + DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc); +var + X, Y, SrcX, SrcY, Width, Height, SrcBpp, DestBpp: LongInt; + PSrc: TColorFPRec; + SrcPointer, DestPointer: PByte; +begin + CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas); + SrcX := SrcRect.Left; + SrcY := SrcRect.Top; + Width := SrcRect.Right - SrcRect.Left; + Height := SrcRect.Bottom - SrcRect.Top; + SrcBpp := FFormatInfo.BytesPerPixel; + DestBpp := DestCanvas.FFormatInfo.BytesPerPixel; + // Clip src and dst rects + ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY, + FPData.Width, FPData.Height, DestCanvas.ClipRect); + + for Y := 0 to Height - 1 do + begin + // Get src and dst scanlines + SrcPointer := @PByteArray(FPData.Bits)[((SrcY + Y) * FPData.Width + SrcX) * SrcBpp]; + DestPointer := @PByteArray(DestCanvas.FPData.Bits)[((DestY + Y) * DestCanvas.FPData.Width + DestX) * DestBpp]; + + for X := 0 to Width - 1 do + begin + PSrc := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, FPData.Palette); + // Call pixel writer procedure - combine source and dest pixels + PixelWriteProc(PSrc, DestPointer, @DestCanvas.FFormatInfo, SrcFactor, DestFactor); + // Increment pixel pointers + Inc(SrcPointer, SrcBpp); + Inc(DestPointer, DestBpp); + end; + end; +end; + +procedure TImagingCanvas.DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; + DestX, DestY: LongInt; SrcFactor, DestFactor: TBlendingFactor); +begin + DrawInternal(SrcRect, DestCanvas, DestX, DestY, SrcFactor, DestFactor, PixelBlendProc); +end; + +procedure TImagingCanvas.DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; + DestX, DestY: LongInt); +begin + DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAlphaProc); +end; + +procedure TImagingCanvas.DrawAdd(const SrcRect: TRect; + DestCanvas: TImagingCanvas; DestX, DestY: LongInt); +begin + DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAddProc); +end; + +procedure TImagingCanvas.StretchDrawInternal(const SrcRect: TRect; + DestCanvas: TImagingCanvas; const DestRect: TRect; + SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter; + PixelWriteProc: TPixelWriteProc); +const + FilterMapping: array[TResizeFilter] of TSamplingFilter = + (sfNearest, sfLinear, DefaultCubicFilter, sfLanczos); +var + X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: LongInt; + DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: LongInt; + SrcPix: TColorFPRec; + MapX, MapY: TMappingTable; + XMinimum, XMaximum: LongInt; + LineBuffer: array of TColorFPRec; + ClusterX, ClusterY: TCluster; + Weight, AccumA, AccumR, AccumG, AccumB: Single; + DestLine: PByte; + FilterFunction: TFilterFunction; + Radius: Single; +begin + CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas); + SrcX := SrcRect.Left; + SrcY := SrcRect.Top; + SrcWidth := SrcRect.Right - SrcRect.Left; + SrcHeight := SrcRect.Bottom - SrcRect.Top; + DestX := DestRect.Left; + DestY := DestRect.Top; + DestWidth := DestRect.Right - DestRect.Left; + DestHeight := DestRect.Bottom - DestRect.Top; + SrcBpp := FFormatInfo.BytesPerPixel; + DestBpp := DestCanvas.FFormatInfo.BytesPerPixel; + // Get actual resampling filter and radius + FilterFunction := SamplingFilterFunctions[FilterMapping[Filter]]; + Radius := SamplingFilterRadii[FilterMapping[Filter]]; + // Clip src and dst rects + ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight, + FPData.Width, FPData.Height, DestCanvas.ClipRect); + // Generate mapping tables + MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth, + FPData.Width, FilterFunction, Radius, False); + MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight, + FPData.Height, FilterFunction, Radius, False); + FindExtremes(MapX, XMinimum, XMaximum); + SetLength(LineBuffer, XMaximum - XMinimum + 1); + + for J := 0 to DestHeight - 1 do + begin + ClusterY := MapY[J]; + for X := XMinimum to XMaximum do + begin + AccumA := 0.0; + AccumR := 0.0; + AccumG := 0.0; + AccumB := 0.0; + for Y := 0 to Length(ClusterY) - 1 do + begin + Weight := ClusterY[Y].Weight; + SrcPix := FFormatInfo.GetPixelFP(@PByteArray(FPData.Bits)[(ClusterY[Y].Pos * FPData.Width + X) * SrcBpp], + @FFormatInfo, FPData.Palette); + AccumB := AccumB + SrcPix.B * Weight; + AccumG := AccumG + SrcPix.G * Weight; + AccumR := AccumR + SrcPix.R * Weight; + AccumA := AccumA + SrcPix.A * Weight; + end; + with LineBuffer[X - XMinimum] do + begin + A := AccumA; + R := AccumR; + G := AccumG; + B := AccumB; + end; + end; + + DestLine := @PByteArray(DestCanvas.FPData.Bits)[((J + DestY) * DestCanvas.FPData.Width + DestX) * DestBpp]; + + for I := 0 to DestWidth - 1 do + begin + ClusterX := MapX[I]; + AccumA := 0.0; + AccumR := 0.0; + AccumG := 0.0; + AccumB := 0.0; + for X := 0 to Length(ClusterX) - 1 do + begin + Weight := ClusterX[X].Weight; + with LineBuffer[ClusterX[X].Pos - XMinimum] do + begin + AccumB := AccumB + B * Weight; + AccumG := AccumG + G * Weight; + AccumR := AccumR + R * Weight; + AccumA := AccumA + A * Weight; + end; + end; + + SrcPix.A := AccumA; + SrcPix.R := AccumR; + SrcPix.G := AccumG; + SrcPix.B := AccumB; + + // Write resulting blended pixel + PixelWriteProc(SrcPix, DestLine, @DestCanvas.FFormatInfo, SrcFactor, DestFactor); + Inc(DestLine, DestBpp); + end; + end; +end; + +procedure TImagingCanvas.StretchDrawBlend(const SrcRect: TRect; + DestCanvas: TImagingCanvas; const DestRect: TRect; + SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter); +begin + StretchDrawInternal(SrcRect, DestCanvas, DestRect, SrcFactor, DestFactor, Filter, PixelBlendProc); +end; + +procedure TImagingCanvas.StretchDrawAlpha(const SrcRect: TRect; + DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); +begin + StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAlphaProc); +end; + +procedure TImagingCanvas.StretchDrawAdd(const SrcRect: TRect; + DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); +begin + StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAddProc); +end; + +procedure TImagingCanvas.ApplyConvolution(Kernel: PLongInt; KernelSize, + Divisor: LongInt; Bias: Single; ClampChannels: Boolean); +var + X, Y, I, J, PosY, PosX, SizeDiv2, KernelValue, WidthBytes, Bpp: LongInt; + R, G, B, DivFloat: Single; + Pixel: TColorFPRec; + TempImage: TImageData; + DstPointer, SrcPointer: PByte; +begin + SizeDiv2 := KernelSize div 2; + DivFloat := IffFloat(Divisor > 1, 1.0 / Divisor, 1.0); + Bpp := FFormatInfo.BytesPerPixel; + WidthBytes := FPData.Width * Bpp; + + InitImage(TempImage); + CloneImage(FPData^, TempImage); + + try + // For every pixel in clip rect + for Y := FClipRect.Top to FClipRect.Bottom - 1 do + begin + DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; + + for X := FClipRect.Left to FClipRect.Right - 1 do + begin + // Reset accumulators + R := 0.0; + G := 0.0; + B := 0.0; + + for J := 0 to KernelSize - 1 do + begin + PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1); + + for I := 0 to KernelSize - 1 do + begin + PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1); + SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp]; + + // Get pixels from neighborhood of current pixel and add their + // colors to accumulators weighted by filter kernel values + Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette); + KernelValue := PUInt32Array(Kernel)[J * KernelSize + I]; + + R := R + Pixel.R * KernelValue; + G := G + Pixel.G * KernelValue; + B := B + Pixel.B * KernelValue; + end; + end; + + Pixel := FFormatInfo.GetPixelFP(DstPointer, @FFormatInfo, FPData.Palette); + + Pixel.R := R * DivFloat + Bias; + Pixel.G := G * DivFloat + Bias; + Pixel.B := B * DivFloat + Bias; + + if ClampChannels then + ClampFloatPixel(Pixel); + + // Set resulting pixel color + FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel); + + Inc(DstPointer, Bpp); + end; + end; + + finally + FreeImage(TempImage); + end; +end; + +procedure TImagingCanvas.ApplyConvolution3x3(const Filter: TConvolutionFilter3x3); +begin + ApplyConvolution(@Filter.Kernel, 3, Filter.Divisor, Filter.Bias, True); +end; + +procedure TImagingCanvas.ApplyConvolution5x5(const Filter: TConvolutionFilter5x5); +begin + ApplyConvolution(@Filter.Kernel, 5, Filter.Divisor, Filter.Bias, True); +end; + +procedure TImagingCanvas.ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction); +var + X, Y, I, J, PosY, PosX, SizeDiv2, WidthBytes, Bpp: LongInt; + Pixel: TColorFPRec; + TempImage: TImageData; + DstPointer, SrcPointer: PByte; + NeighPixels: TDynFPPixelArray; +begin + SizeDiv2 := FilterSize div 2; + Bpp := FFormatInfo.BytesPerPixel; + WidthBytes := FPData.Width * Bpp; + SetLength(NeighPixels, FilterSize * FilterSize); + + InitImage(TempImage); + CloneImage(FPData^, TempImage); + + try + // For every pixel in clip rect + for Y := FClipRect.Top to FClipRect.Bottom - 1 do + begin + DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; + + for X := FClipRect.Left to FClipRect.Right - 1 do + begin + for J := 0 to FilterSize - 1 do + begin + PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1); + + for I := 0 to FilterSize - 1 do + begin + PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1); + SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp]; + + // Get pixels from neighbourhood of current pixel and store them + Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette); + NeighPixels[J * FilterSize + I] := Pixel; + end; + end; + + // Choose pixel using custom function + Pixel := SelectFunc(NeighPixels); + // Set resulting pixel color + FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel); + + Inc(DstPointer, Bpp); + end; + end; + + finally + FreeImage(TempImage); + end; +end; + +procedure TImagingCanvas.ApplyMedianFilter(FilterSize: Integer); +begin + ApplyNonLinearFilter(FilterSize, MedianSelect); +end; + +procedure TImagingCanvas.ApplyMinFilter(FilterSize: Integer); +begin + ApplyNonLinearFilter(FilterSize, MinSelect); +end; + +procedure TImagingCanvas.ApplyMaxFilter(FilterSize: Integer); +begin + ApplyNonLinearFilter(FilterSize, MaxSelect); +end; + +procedure TImagingCanvas.PointTransform(Transform: TPointTransformFunction; + Param1, Param2, Param3: Single); +var + X, Y, Bpp, WidthBytes: Integer; + PixPointer: PByte; + Pixel: TColorFPRec; +begin + Bpp := FFormatInfo.BytesPerPixel; + WidthBytes := FPData.Width * Bpp; + + // For every pixel in clip rect + for Y := FClipRect.Top to FClipRect.Bottom - 1 do + begin + PixPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; + for X := FClipRect.Left to FClipRect.Right - 1 do + begin + Pixel := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette); + + FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, + Transform(Pixel, Param1, Param2, Param3)); + + Inc(PixPointer, Bpp); + end; + end; +end; + +procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single); +begin + PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100, + Brightness / 100, 0); +end; + +procedure TImagingCanvas.GammaCorrection(Red, Green, Blue: Single); +begin + PointTransform(TransformGamma, Red, Green, Blue); +end; + +procedure TImagingCanvas.InvertColors; +begin + PointTransform(TransformInvert, 0, 0, 0); +end; + +procedure TImagingCanvas.Threshold(Red, Green, Blue: Single); +begin + PointTransform(TransformThreshold, Red, Green, Blue); +end; + +procedure TImagingCanvas.AdjustColorLevels(BlackPoint, WhitePoint, MidPoint: Single); +begin + PointTransform(TransformLevels, BlackPoint, WhitePoint, 1.0 / MidPoint); +end; + +procedure TImagingCanvas.PremultiplyAlpha; +begin + PointTransform(TransformPremultiplyAlpha, 0, 0, 0); +end; + +procedure TImagingCanvas.UnPremultiplyAlpha; +begin + PointTransform(TransformUnPremultiplyAlpha, 0, 0, 0); +end; + +procedure TImagingCanvas.GetHistogram(out Red, Green, Blue, Alpha, + Gray: THistogramArray); +var + X, Y, Bpp: Integer; + PixPointer: PByte; + Color32: TColor32Rec; +begin + FillChar(Red, SizeOf(Red), 0); + FillChar(Green, SizeOf(Green), 0); + FillChar(Blue, SizeOf(Blue), 0); + FillChar(Alpha, SizeOf(Alpha), 0); + FillChar(Gray, SizeOf(Gray), 0); + + Bpp := FFormatInfo.BytesPerPixel; + + for Y := FClipRect.Top to FClipRect.Bottom - 1 do + begin + PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp]; + for X := FClipRect.Left to FClipRect.Right - 1 do + begin + Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette); + + Inc(Red[Color32.R]); + Inc(Green[Color32.G]); + Inc(Blue[Color32.B]); + Inc(Alpha[Color32.A]); + Inc(Gray[Round(GrayConv.R * Color32.R + GrayConv.G * Color32.G + GrayConv.B * Color32.B)]); + + Inc(PixPointer, Bpp); + end; + end; +end; + +procedure TImagingCanvas.FillChannel(ChannelId: Integer; NewChannelValue: Byte); +var + X, Y, Bpp: Integer; + PixPointer: PByte; + Color32: TColor32Rec; +begin + Bpp := FFormatInfo.BytesPerPixel; + + for Y := FClipRect.Top to FClipRect.Bottom - 1 do + begin + PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp]; + for X := FClipRect.Left to FClipRect.Right - 1 do + begin + Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette); + Color32.Channels[ChannelId] := NewChannelValue; + FFormatInfo.SetPixel32(PixPointer, @FFormatInfo, FPData.Palette, Color32); + + Inc(PixPointer, Bpp); + end; + end; +end; + +procedure TImagingCanvas.FillChannelFP(ChannelId: Integer; NewChannelValue: Single); +var + X, Y, Bpp: Integer; + PixPointer: PByte; + ColorFP: TColorFPRec; +begin + Bpp := FFormatInfo.BytesPerPixel; + + for Y := FClipRect.Top to FClipRect.Bottom - 1 do + begin + PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp]; + for X := FClipRect.Left to FClipRect.Right - 1 do + begin + ColorFP := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette); + ColorFP.Channels[ChannelId] := NewChannelValue; + FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, ColorFP); + + Inc(PixPointer, Bpp); + end; + end; +end; + +class function TImagingCanvas.GetSupportedFormats: TImageFormats; +begin + Result := [ifIndex8..Pred(ifDXT1)]; +end; + +{ TFastARGB32Canvas } + +destructor TFastARGB32Canvas.Destroy; +begin + FreeMem(FScanlines); + inherited Destroy; +end; + +procedure TFastARGB32Canvas.AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); +var + SrcAlpha, DestAlpha, FinalAlpha: Integer; +begin + FinalAlpha := SrcPix.A + 1 + (DestPix.A * (256 - SrcPix.A)) shr 8; + if FinalAlpha = 0 then + SrcAlpha := 0 + else + SrcAlpha := (SrcPix.A shl 8) div FinalAlpha; + DestAlpha := 256 - SrcAlpha; + + DestPix.A := ClampToByte(FinalAlpha); + DestPix.R := (SrcPix.R * SrcAlpha + DestPix.R * DestAlpha) shr 8; + DestPix.G := (SrcPix.G * SrcAlpha + DestPix.G * DestAlpha) shr 8; + DestPix.B := (SrcPix.B * SrcAlpha + DestPix.B * DestAlpha) shr 8; +end; + +procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect; + DestCanvas: TImagingCanvas; DestX, DestY: LongInt); +var + X, Y, SrcX, SrcY, Width, Height: LongInt; + SrcPix, DestPix: PColor32Rec; +begin + if DestCanvas.ClassType <> Self.ClassType then + begin + inherited; + Exit; + end; + + SrcX := SrcRect.Left; + SrcY := SrcRect.Top; + Width := SrcRect.Right - SrcRect.Left; + Height := SrcRect.Bottom - SrcRect.Top; + ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY, + FPData.Width, FPData.Height, DestCanvas.ClipRect); + + for Y := 0 to Height - 1 do + begin + SrcPix := @FScanlines[SrcY + Y, SrcX]; + DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + Y, DestX]; + for X := 0 to Width - 1 do + begin + AlphaBlendPixels(SrcPix, DestPix); + Inc(SrcPix); + Inc(DestPix); + end; + end; +end; + +function TFastARGB32Canvas.GetPixel32(X, Y: LongInt): TColor32; +begin + Result := FScanlines[Y, X].Color; +end; + +procedure TFastARGB32Canvas.SetPixel32(X, Y: LongInt; const Value: TColor32); +begin + if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and + (X < FClipRect.Right) and (Y < FClipRect.Bottom) then + begin + FScanlines[Y, X].Color := Value; + end; +end; + +procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect; + DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); +var + X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4, InvFracY, T1, T2: Integer; + FracX, FracY: Cardinal; + SrcX, SrcY, SrcWidth, SrcHeight: LongInt; + DestX, DestY, DestWidth, DestHeight: LongInt; + SrcLine, SrcLine2: PColor32RecArray; + DestPix: PColor32Rec; + Accum: TColor32Rec; +begin + if (Filter = rfBicubic) or (DestCanvas.ClassType <> Self.ClassType) then + begin + inherited; + Exit; + end; + + SrcX := SrcRect.Left; + SrcY := SrcRect.Top; + SrcWidth := SrcRect.Right - SrcRect.Left; + SrcHeight := SrcRect.Bottom - SrcRect.Top; + DestX := DestRect.Left; + DestY := DestRect.Top; + DestWidth := DestRect.Right - DestRect.Left; + DestHeight := DestRect.Bottom - DestRect.Top; + // Clip src and dst rects + ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight, + FPData.Width, FPData.Height, DestCanvas.ClipRect); + ScaleX := (SrcWidth shl 16) div DestWidth; + ScaleY := (SrcHeight shl 16) div DestHeight; + + // Nearest and linear filtering using fixed point math + + if Filter = rfNearest then + begin + Yp := 0; + for Y := DestY to DestY + DestHeight - 1 do + begin + Xp := 0; + SrcLine := @FScanlines[SrcY + Yp shr 16, SrcX]; + DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX]; + for X := 0 to DestWidth - 1 do + begin + AlphaBlendPixels(@SrcLine[Xp shr 16], DestPix); + Inc(DestPix); + Inc(Xp, ScaleX); + end; + Inc(Yp, ScaleY); + end; + end + else + begin + Yp := (ScaleY shr 1) - $8000; + for Y := DestY to DestY + DestHeight - 1 do + begin + DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX]; + if Yp < 0 then + begin + T1 := 0; + FracY := 0; + InvFracY := $10000; + end + else + begin + T1 := Yp shr 16; + FracY := Yp and $FFFF; + InvFracY := (not Yp and $FFFF) + 1; + end; + + T2 := Iff(T1 < SrcHeight - 1, T1 + 1, T1); + SrcLine := @Scanlines[T1 + SrcY, SrcX]; + SrcLine2 := @Scanlines[T2 + SrcY, SrcX]; + Xp := (ScaleX shr 1) - $8000; + + for X := 0 to DestWidth - 1 do + begin + if Xp < 0 then + begin + T1 := 0; + FracX := 0; + end + else + begin + T1 := Xp shr 16; + FracX := Xp and $FFFF; + end; + + T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1); + Weight2:= Integer((Cardinal(InvFracY) * FracX) shr 16); // cast to Card, Int can overflow here + Weight1:= InvFracY - Weight2; + Weight4:= Integer((Cardinal(FracY) * FracX) shr 16); + Weight3:= FracY - Weight4; + + Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 + + SrcLine2[T1].B * Weight3 + SrcLine2[T2].B * Weight4 + $8000) shr 16; + Accum.G := (SrcLine[T1].G * Weight1 + SrcLine[T2].G * Weight2 + + SrcLine2[T1].G * Weight3 + SrcLine2[T2].G * Weight4 + $8000) shr 16; + Accum.R := (SrcLine[T1].R * Weight1 + SrcLine[T2].R * Weight2 + + SrcLine2[T1].R * Weight3 + SrcLine2[T2].R * Weight4 + $8000) shr 16; + Accum.A := (SrcLine[T1].A * Weight1 + SrcLine[T2].A * Weight2 + + SrcLine2[T1].A * Weight3 + SrcLine2[T2].A * Weight4 + $8000) shr 16; + + AlphaBlendPixels(@Accum, DestPix); + + Inc(Xp, ScaleX); + Inc(DestPix); + end; + Inc(Yp, ScaleY); + end; + end; +end; + +procedure TFastARGB32Canvas.UpdateCanvasState; +var + I: LongInt; + ScanPos: PUInt32; +begin + inherited UpdateCanvasState; + + // Realloc and update scanline array + ReallocMem(FScanlines, FPData.Height * SizeOf(PColor32RecArray)); + ScanPos := FPData.Bits; + + for I := 0 to FPData.Height - 1 do + begin + FScanlines[I] := PColor32RecArray(ScanPos); + Inc(ScanPos, FPData.Width); + end; +end; + +class function TFastARGB32Canvas.GetSupportedFormats: TImageFormats; +begin + Result := [ifA8R8G8B8]; +end; + +procedure TFastARGB32Canvas.InvertColors; +var + X, Y: Integer; + PixPtr: PColor32Rec; +begin + for Y := FClipRect.Top to FClipRect.Bottom - 1 do + begin + PixPtr := @FScanlines[Y, FClipRect.Left]; + for X := FClipRect.Left to FClipRect.Right - 1 do + begin + PixPtr.R := not PixPtr.R; + PixPtr.G := not PixPtr.G; + PixPtr.B := not PixPtr.B; + Inc(PixPtr); + end; + end; +end; + +initialization + RegisterCanvas(TFastARGB32Canvas); + +finalization + FreeAndNil(CanvasClasses); + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - more more more ... + - implement pen width everywhere + - more objects (arc, polygon) + + -- 0.26.5 Changes/Bug Fixes --------------------------------- + - Fixed bug that could raise floating point error in DrawAlpha + and StretchDrawAlpha. + - Fixed bug in TImagingCanvas.Line that caused not drawing + of horz or vert lines. + + -- 0.26.3 Changes/Bug Fixes --------------------------------- + - Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha) + - Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation. + - Added PremultiplyAlpha and UnPremultiplyAlpha methods. + + -- 0.26.1 Changes/Bug Fixes --------------------------------- + - Added FillChannel methods. + - Added FloodFill method. + - Added GetHistogram method. + - Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes + (thanks to Carlos Gonzalez). + - Added TImagingCanvas.AdjustColorLevels method. + + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - Fixed error that could cause AV in linear and nonlinear filters. + - Added blended rect filling function FillRectBlend. + - Added drawing function with blending (DrawAlpha, StretchDrawAlpha, + StretchDrawAdd, DrawBlend, StretchDrawBlend, ...) + - Added non-linear filters (min, max, median). + - Added point transforms (invert, contrast, gamma, brightness). + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Added some new filter kernels for convolution. + - Added FillMode and PenMode properties. + - Added FrameRect, Rectangle, Ellipse, and Line methods. + - Removed HorzLine and VertLine from TFastARGB32Canvas - new versions + in general canvas is now as fast as those in TFastARGB32Canvas + (only in case of A8R8G8B8 images of course). + - Added PenWidth property, updated HorzLine and VertLine to use it. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - added TFastARGB32Canvas + - added convolutions, hline, vline + - unit created, initial stuff added + +} + +end. + diff --git a/Imaging/ImagingClasses.pas b/Imaging/ImagingClasses.pas index 87f1d2a..cc62622 100644 --- a/Imaging/ImagingClasses.pas +++ b/Imaging/ImagingClasses.pas @@ -1,997 +1,1095 @@ -{ - $Id: ImagingClasses.pas 173 2009-09-04 17:05:52Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains class based wrapper to Imaging library.} -unit ImagingClasses; - -{$I ImagingOptions.inc} - -interface - -uses - Types, Classes, ImagingTypes, Imaging, ImagingFormats, ImagingUtility; - -type - { Base abstract high level class wrapper to low level Imaging structures and - functions.} - TBaseImage = class(TPersistent) - protected - FPData: PImageData; - FOnDataSizeChanged: TNotifyEvent; - FOnPixelsChanged: TNotifyEvent; - function GetFormat: TImageFormat; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetHeight: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetSize: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetWidth: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetBits: Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetPalette: PPalette32; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetPaletteEntries: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetScanLine(Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetFormatInfo: TImageFormatInfo; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetBoundsRect: TRect; - procedure SetFormat(const Value: TImageFormat); {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetHeight(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetPointer; virtual; abstract; - procedure DoDataSizeChanged; virtual; - procedure DoPixelsChanged; virtual; - published - public - constructor Create; virtual; - constructor CreateFromImage(AImage: TBaseImage); - destructor Destroy; override; - { Returns info about current image.} - function ToString: string; - - { Creates a new image data with the given size and format. Old image - data is lost. Works only for the current image of TMultiImage.} - procedure RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat); - { Resizes current image with optional resampling.} - procedure Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter); - { Flips current image. Reverses the image along its horizontal axis the top - becomes the bottom and vice versa.} - procedure Flip; - { Mirrors current image. Reverses the image along its vertical axis the left - side becomes the right and vice versa.} - procedure Mirror; - { Rotates image by Angle degrees counterclockwise.} - procedure Rotate(Angle: Single); - { Copies rectangular part of SrcImage to DstImage. No blending is performed - - alpha is simply copied to destination image. Operates also with - negative X and Y coordinates. - Note that copying is fastest for images in the same data format - (and slowest for images in special formats).} - procedure CopyTo(SrcX, SrcY, Width, Height: LongInt; DstImage: TBaseImage; DstX, DstY: LongInt); - { Stretches the contents of the source rectangle to the destination rectangle - with optional resampling. No blending is performed - alpha is - simply copied/resampled to destination image. Note that stretching is - fastest for images in the same data format (and slowest for - images in special formats).} - procedure StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt; DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter); - { Replaces pixels with OldPixel in the given rectangle by NewPixel. - OldPixel and NewPixel should point to the pixels in the same format - as the given image is in.} - procedure ReplaceColor(X, Y, Width, Height: LongInt; OldColor, NewColor: Pointer); - { Swaps SrcChannel and DstChannel color or alpha channels of image. - Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to - identify channels.} - procedure SwapChannels(SrcChannel, DstChannel: LongInt); - - { Loads current image data from file.} - procedure LoadFromFile(const FileName: string); virtual; - { Loads current image data from stream.} - procedure LoadFromStream(Stream: TStream); virtual; - - { Saves current image data to file.} - procedure SaveToFile(const FileName: string); - { Saves current image data to stream. Ext identifies desired image file - format (jpg, png, dds, ...)} - procedure SaveToStream(const Ext: string; Stream: TStream); - - { Width of current image in pixels.} - property Width: LongInt read GetWidth write SetWidth; - { Height of current image in pixels.} - property Height: LongInt read GetHeight write SetHeight; - { Image data format of current image.} - property Format: TImageFormat read GetFormat write SetFormat; - { Size in bytes of current image's data.} - property Size: LongInt read GetSize; - { Pointer to memory containing image bits.} - property Bits: Pointer read GetBits; - { Pointer to palette for indexed format images. It is nil for others. - Max palette entry is at index [PaletteEntries - 1].} - property Palette: PPalette32 read GetPalette; - { Number of entries in image's palette} - property PaletteEntries: LongInt read GetPaletteEntries; - { Provides indexed access to each line of pixels. Does not work with special - format images (like DXT).} - property ScanLine[Index: LongInt]: Pointer read GetScanLine; - { Returns pointer to image pixel at [X, Y] coordinates.} - property PixelPointers[X, Y: LongInt]: Pointer read GetPixelPointer; - { Extended image format information.} - property FormatInfo: TImageFormatInfo read GetFormatInfo; - { This gives complete access to underlying TImageData record. - It can be used in functions that take TImageData as parameter - (for example: ReduceColors(SingleImageInstance.ImageData^, 64)).} - property ImageDataPointer: PImageData read FPData; - { Indicates whether the current image is valid (proper format, - allowed dimensions, right size, ...).} - property Valid: Boolean read GetValid; - {{ Specifies the bounding rectangle of the image.} - property BoundsRect: TRect read GetBoundsRect; - { This event occurs when the image data size has just changed. That means - image width, height, or format has been changed.} - property OnDataSizeChanged: TNotifyEvent read FOnDataSizeChanged write FOnDataSizeChanged; - { This event occurs when some pixels of the image have just changed.} - property OnPixelsChanged: TNotifyEvent read FOnPixelsChanged write FOnPixelsChanged; - end; - - { Extension of TBaseImage which uses single TImageData record to - store image. All methods inherited from TBaseImage work with this record.} - TSingleImage = class(TBaseImage) - protected - FImageData: TImageData; - procedure SetPointer; override; - public - constructor Create; override; - constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); - constructor CreateFromData(const AData: TImageData); - constructor CreateFromFile(const FileName: string); - constructor CreateFromStream(Stream: TStream); - destructor Destroy; override; - { Assigns single image from another single image or multi image.} - procedure Assign(Source: TPersistent); override; - end; - - { Extension of TBaseImage which uses array of TImageData records to - store multiple images. Images are independent on each other and they don't - share any common characteristic. Each can have different size, format, and - palette. All methods inherited from TBaseImage work only with - active image (it could represent mipmap level, animation frame, or whatever). - Methods whose names contain word 'Multi' work with all images in array - (as well as other methods with obvious names).} - TMultiImage = class(TBaseImage) - protected - FDataArray: TDynImageDataArray; - FActiveImage: LongInt; - procedure SetActiveImage(Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetImageCount: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetImageCount(Value: LongInt); - function GetAllImagesValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} - function GetImage(Index: LongInt): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetImage(Index: LongInt; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF} - procedure SetPointer; override; - function PrepareInsert(Index, Count: LongInt): Boolean; - procedure DoInsertImages(Index: LongInt; const Images: TDynImageDataArray); - procedure DoInsertNew(Index: LongInt; AWidth, AHeight: LongInt; AFormat: TImageFormat); - public - constructor Create; override; - constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat; Images: LongInt); - constructor CreateFromArray(ADataArray: TDynImageDataArray); - constructor CreateFromFile(const FileName: string); - constructor CreateFromStream(Stream: TStream); - destructor Destroy; override; - { Assigns multi image from another multi image or single image.} - procedure Assign(Source: TPersistent); override; - - { Adds new image at the end of the image array. } - procedure AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload; - { Adds existing image at the end of the image array. } - procedure AddImage(const Image: TImageData); overload; - { Adds existing image (Active image of a TmultiImage) - at the end of the image array. } - procedure AddImage(Image: TBaseImage); overload; - { Adds existing image array ((all images of a multi image)) - at the end of the image array. } - procedure AddImages(const Images: TDynImageDataArray); overload; - { Adds existing MultiImage images at the end of the image array. } - procedure AddImages(Images: TMultiImage); overload; - - { Inserts new image image at the given position in the image array. } - procedure InsertImage(Index, AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload; - { Inserts existing image at the given position in the image array. } - procedure InsertImage(Index: LongInt; const Image: TImageData); overload; - { Inserts existing image (Active image of a TmultiImage) - at the given position in the image array. } - procedure InsertImage(Index: LongInt; Image: TBaseImage); overload; - { Inserts existing image at the given position in the image array. } - procedure InsertImages(Index: LongInt; const Images: TDynImageDataArray); overload; - { Inserts existing images (all images of a TmultiImage) at - the given position in the image array. } - procedure InsertImages(Index: LongInt; Images: TMultiImage); overload; - - { Exchanges two images at the given positions in the image array. } - procedure ExchangeImages(Index1, Index2: LongInt); - { Deletes image at the given position in the image array.} - procedure DeleteImage(Index: LongInt); - { Rearranges images so that the first image will become last and vice versa.} - procedure ReverseImages; - - { Converts all images to another image data format.} - procedure ConvertImages(Format: TImageFormat); - { Resizes all images.} - procedure ResizeImages(NewWidth, NewHeight: LongInt; Filter: TResizeFilter); - - { Overloaded loading method that will add new image to multiimage if - image array is empty bero loading. } - procedure LoadFromFile(const FileName: string); override; - { Overloaded loading method that will add new image to multiimage if - image array is empty bero loading. } - procedure LoadFromStream(Stream: TStream); override; - - { Loads whole multi image from file.} - procedure LoadMultiFromFile(const FileName: string); - { Loads whole multi image from stream.} - procedure LoadMultiFromStream(Stream: TStream); - { Saves whole multi image to file.} - procedure SaveMultiToFile(const FileName: string); - { Saves whole multi image to stream. Ext identifies desired - image file format (jpg, png, dds, ...).} - procedure SaveMultiToStream(const Ext: string; Stream: TStream); - - { Indicates active image of this multi image. All methods inherited - from TBaseImage operate on this image only.} - property ActiveImage: LongInt read FActiveImage write SetActiveImage; - { Number of images of this multi image.} - property ImageCount: LongInt read GetImageCount write SetImageCount; - { This value is True if all images of this TMultiImage are valid.} - property AllImagesValid: Boolean read GetAllImagesValid; - { This gives complete access to underlying TDynImageDataArray. - It can be used in functions that take TDynImageDataArray - as parameter.} - property DataArray: TDynImageDataArray read FDataArray; - { Array property for accessing individual images of TMultiImage. When you - set image at given index the old image is freed and the source is cloned.} - property Images[Index: LongInt]: TImageData read GetImage write SetImage; default; - end; - -implementation - -const - DefaultWidth = 16; - DefaultHeight = 16; - DefaultImages = 1; - -function GetArrayFromImageData(const ImageData: TImageData): TDynImageDataArray; -begin - SetLength(Result, 1); - Result[0] := ImageData; -end; - -{ TBaseImage class implementation } - -constructor TBaseImage.Create; -begin - SetPointer; -end; - -constructor TBaseImage.CreateFromImage(AImage: TBaseImage); -begin - Create; - Assign(AImage); -end; - -destructor TBaseImage.Destroy; -begin - inherited Destroy; -end; - -function TBaseImage.GetWidth: LongInt; -begin - if Valid then - Result := FPData.Width - else - Result := 0; -end; - -function TBaseImage.GetHeight: LongInt; -begin - if Valid then - Result := FPData.Height - else - Result := 0; -end; - -function TBaseImage.GetFormat: TImageFormat; -begin - if Valid then - Result := FPData.Format - else - Result := ifUnknown; -end; - -function TBaseImage.GetScanLine(Index: LongInt): Pointer; -var - Info: TImageFormatInfo; -begin - if Valid then - begin - Info := GetFormatInfo; - if not Info.IsSpecial then - Result := ImagingFormats.GetScanLine(FPData.Bits, Info, FPData.Width, Index) - else - Result := FPData.Bits; - end - else - Result := nil; -end; - -function TBaseImage.GetPixelPointer(X, Y: LongInt): Pointer; -begin - if Valid then - Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * GetFormatInfo.BytesPerPixel] - else - Result := nil; -end; - -function TBaseImage.GetSize: LongInt; -begin - if Valid then - Result := FPData.Size - else - Result := 0; -end; - -function TBaseImage.GetBits: Pointer; -begin - if Valid then - Result := FPData.Bits - else - Result := nil; -end; - -function TBaseImage.GetPalette: PPalette32; -begin - if Valid then - Result := FPData.Palette - else - Result := nil; -end; - -function TBaseImage.GetPaletteEntries: LongInt; -begin - Result := GetFormatInfo.PaletteEntries; -end; - -function TBaseImage.GetFormatInfo: TImageFormatInfo; -begin - if Valid then - Imaging.GetImageFormatInfo(FPData.Format, Result) - else - FillChar(Result, SizeOf(Result), 0); -end; - -function TBaseImage.GetValid: Boolean; -begin - Result := Assigned(FPData) and Imaging.TestImage(FPData^); -end; - -function TBaseImage.GetBoundsRect: TRect; -begin - Result := Rect(0, 0, GetWidth, GetHeight); -end; - -procedure TBaseImage.SetWidth(const Value: LongInt); -begin - Resize(Value, GetHeight, rfNearest); -end; - -procedure TBaseImage.SetHeight(const Value: LongInt); -begin - Resize(GetWidth, Value, rfNearest); -end; - -procedure TBaseImage.SetFormat(const Value: TImageFormat); -begin - if Valid and Imaging.ConvertImage(FPData^, Value) then - DoDataSizeChanged; -end; - -procedure TBaseImage.DoDataSizeChanged; -begin - if Assigned(FOnDataSizeChanged) then - FOnDataSizeChanged(Self); - DoPixelsChanged; -end; - -procedure TBaseImage.DoPixelsChanged; -begin - if Assigned(FOnPixelsChanged) then - FOnPixelsChanged(Self); -end; - -procedure TBaseImage.RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat); -begin - if Assigned(FPData) and Imaging.NewImage(AWidth, AHeight, AFormat, FPData^) then - DoDataSizeChanged; -end; - -procedure TBaseImage.Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter); -begin - if Valid and Imaging.ResizeImage(FPData^, NewWidth, NewHeight, Filter) then - DoDataSizeChanged; -end; - -procedure TBaseImage.Flip; -begin - if Valid and Imaging.FlipImage(FPData^) then - DoPixelsChanged; -end; - -procedure TBaseImage.Mirror; -begin - if Valid and Imaging.MirrorImage(FPData^) then - DoPixelsChanged; -end; - -procedure TBaseImage.Rotate(Angle: Single); -begin - if Valid and Imaging.RotateImage(FPData^, Angle) then - DoPixelsChanged; -end; - -procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: LongInt; - DstImage: TBaseImage; DstX, DstY: LongInt); -begin - if Valid and Assigned(DstImage) and DstImage.Valid then - begin - Imaging.CopyRect(FPData^, SrcX, SrcY, Width, Height, DstImage.FPData^, DstX, DstY); - DstImage.DoPixelsChanged; - end; -end; - -procedure TBaseImage.StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt; - DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter); -begin - if Valid and Assigned(DstImage) and DstImage.Valid then - begin - Imaging.StretchRect(FPData^, SrcX, SrcY, SrcWidth, SrcHeight, - DstImage.FPData^, DstX, DstY, DstWidth, DstHeight, Filter); - DstImage.DoPixelsChanged; - end; -end; - -procedure TBaseImage.ReplaceColor(X, Y, Width, Height: Integer; OldColor, - NewColor: Pointer); -begin - if Valid then - begin - Imaging.ReplaceColor(FPData^, X, Y, Width, Height, OldColor, NewColor); - DoPixelsChanged; - end; -end; - -procedure TBaseImage.SwapChannels(SrcChannel, DstChannel: Integer); -begin - if Valid then - begin - Imaging.SwapChannels(FPData^, SrcChannel, DstChannel); - DoPixelsChanged; - end; -end; - -function TBaseImage.ToString: string; -begin - Result := Iff(Valid, Imaging.ImageToStr(FPData^), 'empty image'); -end; - -procedure TBaseImage.LoadFromFile(const FileName: string); -begin - if Assigned(FPData) and Imaging.LoadImageFromFile(FileName, FPData^) then - DoDataSizeChanged; -end; - -procedure TBaseImage.LoadFromStream(Stream: TStream); -begin - if Assigned(FPData) and Imaging.LoadImageFromStream(Stream, FPData^) then - DoDataSizeChanged; -end; - -procedure TBaseImage.SaveToFile(const FileName: string); -begin - if Valid then - Imaging.SaveImageToFile(FileName, FPData^); -end; - -procedure TBaseImage.SaveToStream(const Ext: string; Stream: TStream); -begin - if Valid then - Imaging.SaveImageToStream(Ext, Stream, FPData^); -end; - - -{ TSingleImage class implementation } - -constructor TSingleImage.Create; -begin - inherited Create; - RecreateImageData(DefaultWidth, DefaultHeight, ifDefault); -end; - -constructor TSingleImage.CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat); -begin - inherited Create; - RecreateImageData(AWidth, AHeight, AFormat); -end; - -constructor TSingleImage.CreateFromData(const AData: TImageData); -begin - inherited Create; - if Imaging.TestImage(AData) then - begin - Imaging.CloneImage(AData, FImageData); - DoDataSizeChanged; - end - else - Create; -end; - -constructor TSingleImage.CreateFromFile(const FileName: string); -begin - inherited Create; - LoadFromFile(FileName); -end; - -constructor TSingleImage.CreateFromStream(Stream: TStream); -begin - inherited Create; - LoadFromStream(Stream); -end; - -destructor TSingleImage.Destroy; -begin - Imaging.FreeImage(FImageData); - inherited Destroy; -end; - -procedure TSingleImage.SetPointer; -begin - FPData := @FImageData; -end; - -procedure TSingleImage.Assign(Source: TPersistent); -begin - if Source = nil then - begin - Create; - end - else if Source is TSingleImage then - begin - CreateFromData(TSingleImage(Source).FImageData); - end - else if Source is TMultiImage then - begin - if TMultiImage(Source).Valid then - CreateFromData(TMultiImage(Source).FPData^) - else - Assign(nil); - end - else - inherited Assign(Source); -end; - - -{ TMultiImage class implementation } - -constructor TMultiImage.Create; -begin - SetImageCount(DefaultImages); - SetActiveImage(0); -end; - -constructor TMultiImage.CreateFromParams(AWidth, AHeight: LongInt; - AFormat: TImageFormat; Images: LongInt); -var - I: LongInt; -begin - Imaging.FreeImagesInArray(FDataArray); - SetLength(FDataArray, Images); - for I := 0 to GetImageCount - 1 do - Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[I]); - SetActiveImage(0); -end; - -constructor TMultiImage.CreateFromArray(ADataArray: TDynImageDataArray); -var - I: LongInt; -begin - Imaging.FreeImagesInArray(FDataArray); - SetLength(FDataArray, Length(ADataArray)); - for I := 0 to GetImageCount - 1 do - begin - // Clone only valid images - if Imaging.TestImage(ADataArray[I]) then - Imaging.CloneImage(ADataArray[I], FDataArray[I]) - else - Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]); - end; - SetActiveImage(0); -end; - -constructor TMultiImage.CreateFromFile(const FileName: string); -begin - LoadMultiFromFile(FileName); -end; - -constructor TMultiImage.CreateFromStream(Stream: TStream); -begin - LoadMultiFromStream(Stream); -end; - -destructor TMultiImage.Destroy; -begin - Imaging.FreeImagesInArray(FDataArray); - inherited Destroy; -end; - -procedure TMultiImage.SetActiveImage(Value: LongInt); -begin - FActiveImage := Value; - SetPointer; -end; - -function TMultiImage.GetImageCount: LongInt; -begin - Result := Length(FDataArray); -end; - -procedure TMultiImage.SetImageCount(Value: LongInt); -var - I, OldCount: LongInt; -begin - if Value > GetImageCount then - begin - // Create new empty images if array will be enlarged - OldCount := GetImageCount; - SetLength(FDataArray, Value); - for I := OldCount to Value - 1 do - Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]); - end - else - begin - // Free images that exceed desired count and shrink array - for I := Value to GetImageCount - 1 do - Imaging.FreeImage(FDataArray[I]); - SetLength(FDataArray, Value); - end; - SetPointer; -end; - -function TMultiImage.GetAllImagesValid: Boolean; -begin - Result := (GetImageCount > 0) and TestImagesInArray(FDataArray); -end; - -function TMultiImage.GetImage(Index: LongInt): TImageData; -begin - if (Index >= 0) and (Index < GetImageCount) then - Result := FDataArray[Index]; -end; - -procedure TMultiImage.SetImage(Index: LongInt; Value: TImageData); -begin - if (Index >= 0) and (Index < GetImageCount) then - Imaging.CloneImage(Value, FDataArray[Index]); -end; - -procedure TMultiImage.SetPointer; -begin - if GetImageCount > 0 then - begin - FActiveImage := ClampInt(FActiveImage, 0, GetImageCount - 1); - FPData := @FDataArray[FActiveImage]; - end - else - begin - FActiveImage := -1; - FPData := nil - end; -end; - -function TMultiImage.PrepareInsert(Index, Count: LongInt): Boolean; -var - I: LongInt; -begin - // Inserting to empty image will add image at index 0 - if GetImageCount = 0 then - Index := 0; - - if (Index >= 0) and (Index <= GetImageCount) and (Count > 0) then - begin - SetLength(FDataArray, GetImageCount + Count); - if Index < GetImageCount - 1 then - begin - // Move imges to new position - System.Move(FDataArray[Index], FDataArray[Index + Count], - (GetImageCount - Count - Index) * SizeOf(TImageData)); - // Null old images, not free them! - for I := Index to Index + Count - 1 do - InitImage(FDataArray[I]); - end; - Result := True; - end - else - Result := False; -end; - -procedure TMultiImage.DoInsertImages(Index: LongInt; const Images: TDynImageDataArray); -var - I, Len: LongInt; -begin - Len := Length(Images); - if PrepareInsert(Index, Len) then - begin - for I := 0 to Len - 1 do - Imaging.CloneImage(Images[I], FDataArray[Index + I]); - end; -end; - -procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: LongInt; - AFormat: TImageFormat); -begin - if PrepareInsert(Index, 1) then - Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[Index]); -end; - -procedure TMultiImage.Assign(Source: TPersistent); -var - Arr: TDynImageDataArray; -begin - if Source = nil then - begin - Create; - end - else if Source is TMultiImage then - begin - CreateFromArray(TMultiImage(Source).FDataArray); - SetActiveImage(TMultiImage(Source).ActiveImage); - end - else if Source is TSingleImage then - begin - SetLength(Arr, 1); - Arr[0] := TSingleImage(Source).FImageData; - CreateFromArray(Arr); - Arr := nil; - end - else - inherited Assign(Source); -end; - -procedure TMultiImage.AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat); -begin - DoInsertNew(GetImageCount, AWidth, AHeight, AFormat); -end; - -procedure TMultiImage.AddImage(const Image: TImageData); -begin - DoInsertImages(GetImageCount, GetArrayFromImageData(Image)); -end; - -procedure TMultiImage.AddImage(Image: TBaseImage); -begin - if Assigned(Image) and Image.Valid then - DoInsertImages(GetImageCount, GetArrayFromImageData(Image.FPData^)); -end; - -procedure TMultiImage.AddImages(const Images: TDynImageDataArray); -begin - DoInsertImages(GetImageCount, Images); -end; - -procedure TMultiImage.AddImages(Images: TMultiImage); -begin - DoInsertImages(GetImageCount, Images.FDataArray); -end; - -procedure TMultiImage.InsertImage(Index, AWidth, AHeight: LongInt; - AFormat: TImageFormat); -begin - DoInsertNew(Index, AWidth, AHeight, AFormat); -end; - -procedure TMultiImage.InsertImage(Index: LongInt; const Image: TImageData); -begin - DoInsertImages(Index, GetArrayFromImageData(Image)); -end; - -procedure TMultiImage.InsertImage(Index: LongInt; Image: TBaseImage); -begin - if Assigned(Image) and Image.Valid then - DoInsertImages(Index, GetArrayFromImageData(Image.FPData^)); -end; - -procedure TMultiImage.InsertImages(Index: LongInt; - const Images: TDynImageDataArray); -begin - DoInsertImages(Index, FDataArray); -end; - -procedure TMultiImage.InsertImages(Index: LongInt; Images: TMultiImage); -begin - DoInsertImages(Index, Images.FDataArray); -end; - -procedure TMultiImage.ExchangeImages(Index1, Index2: LongInt); -var - TempData: TImageData; -begin - if (Index1 >= 0) and (Index1 < GetImageCount) and - (Index2 >= 0) and (Index2 < GetImageCount) then - begin - TempData := FDataArray[Index1]; - FDataArray[Index1] := FDataArray[Index2]; - FDataArray[Index2] := TempData; - end; -end; - -procedure TMultiImage.DeleteImage(Index: LongInt); -var - I: LongInt; -begin - if (Index >= 0) and (Index < GetImageCount) then - begin - // Free image at index to be deleted - Imaging.FreeImage(FDataArray[Index]); - if Index < GetImageCount - 1 then - begin - // Move images to new indices if necessary - for I := Index to GetImageCount - 2 do - FDataArray[I] := FDataArray[I + 1]; - end; - // Set new array length and update pointer to active image - SetLength(FDataArray, GetImageCount - 1); - SetPointer; - end; -end; - -procedure TMultiImage.ConvertImages(Format: TImageFormat); -var - I: LongInt; -begin - for I := 0 to GetImageCount - 1 do - Imaging.ConvertImage(FDataArray[I], Format); -end; - -procedure TMultiImage.ResizeImages(NewWidth, NewHeight: LongInt; - Filter: TResizeFilter); -var - I: LongInt; -begin - for I := 0 to GetImageCount do - Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter); -end; - -procedure TMultiImage.ReverseImages; -var - I: Integer; -begin - for I := 0 to GetImageCount div 2 do - ExchangeImages(I, GetImageCount - 1 - I); -end; - -procedure TMultiImage.LoadFromFile(const FileName: string); -begin - if GetImageCount = 0 then - ImageCount := 1; - inherited LoadFromFile(FileName); -end; - -procedure TMultiImage.LoadFromStream(Stream: TStream); -begin - if GetImageCount = 0 then - ImageCount := 1; - inherited LoadFromStream(Stream); -end; - -procedure TMultiImage.LoadMultiFromFile(const FileName: string); -begin - Imaging.LoadMultiImageFromFile(FileName, FDataArray); - SetActiveImage(0); -end; - -procedure TMultiImage.LoadMultiFromStream(Stream: TStream); -begin - Imaging.LoadMultiImageFromStream(Stream, FDataArray); - SetActiveImage(0); -end; - -procedure TMultiImage.SaveMultiToFile(const FileName: string); -begin - Imaging.SaveMultiImageToFile(FileName, FDataArray); -end; - -procedure TMultiImage.SaveMultiToStream(const Ext: string; Stream: TStream); -begin - Imaging.SaveMultiImageToStream(Ext, Stream, FDataArray); -end; - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - add SetPalette, create some pal wrapper first - - put all low level stuff here like ReplaceColor etc, change - CopyTo to Copy, and add overload Copy(SrcRect, DstX, DstY) ... - - -- 0.24.3 Changes/Bug Fixes --------------------------------- - - Added TMultiImage.ReverseImages method. - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Added SwapChannels method to TBaseImage. - - Added ReplaceColor method to TBaseImage. - - Added ToString method to TBaseImage. - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Inserting images to empty MultiImage will act as Add method. - - MultiImages with empty arrays will now create one image when - LoadFromFile or LoadFromStream is called. - - Fixed bug that caused AVs when getting props like Width, Height, asn Size - and when inlining was off. There was call to Iff but with inlining disabled - params like FPData.Size were evaluated and when FPData was nil => AV. - - Added many FPData validity checks to many methods. There were AVs - when calling most methods on empty TMultiImage. - - Added AllImagesValid property to TMultiImage. - - Fixed memory leak in TMultiImage.CreateFromParams. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - added ResizeImages method to TMultiImage - - removed Ext parameter from various LoadFromStream methods, no - longer needed - - fixed various issues concerning ActiveImage of TMultiImage - (it pointed to invalid location after some operations) - - most of property set/get methods are now inline - - added PixelPointers property to TBaseImage - - added Images default array property to TMultiImage - - renamed methods in TMultiImage to contain 'Image' instead of 'Level' - - added canvas support - - added OnDataSizeChanged and OnPixelsChanged event to TBaseImage - - renamed TSingleImage.NewImage to RecreateImageData, made public, and - moved to TBaseImage - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - added props PaletteEntries and ScanLine to TBaseImage - - aded new constructor to TBaseImage that take TBaseImage source - - TMultiImage levels adding and inserting rewritten internally - - added some new functions to TMultiImage: AddLevels, InsertLevels - - added some new functions to TBaseImage: Flip, Mirror, Rotate, - CopyRect, StretchRect - - TBasicImage.Resize has now filter parameter - - new stuff added to TMultiImage (DataArray prop, ConvertLevels) - - -- 0.13 Changes/Bug Fixes ----------------------------------- - - added AddLevel, InsertLevel, ExchangeLevels and DeleteLevel - methods to TMultiImage - - added TBaseImage, TSingleImage and TMultiImage with initial - members -} - -end. - +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains class based wrapper to Imaging library.} +unit ImagingClasses; + +{$I ImagingOptions.inc} + +interface + +uses + Types, Classes, ImagingTypes, Imaging, ImagingFormats, ImagingUtility; + +type + { Base abstract high level class wrapper to low level Imaging structures and + functions.} + TBaseImage = class(TPersistent) + private + function GetEmpty: Boolean; + protected + FPData: PImageData; + FOnDataSizeChanged: TNotifyEvent; + FOnPixelsChanged: TNotifyEvent; + function GetFormat: TImageFormat; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetHeight: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetSize: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetWidth: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetBits: Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetPalette: PPalette32; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetPaletteEntries: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetScanline(Index: Integer): Pointer; + function GetPixelPointer(X, Y: Integer): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetScanlineSize: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetFormatInfo: TImageFormatInfo; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetBoundsRect: TRect; + procedure SetFormat(const Value: TImageFormat); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetHeight(const Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetWidth(const Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetPointer; virtual; abstract; + procedure DoDataSizeChanged; virtual; + procedure DoPixelsChanged; virtual; + public + constructor Create; virtual; + constructor CreateFromImage(AImage: TBaseImage); + destructor Destroy; override; + { Returns info about current image.} + function ToString: string; {$IF (Defined(DCC) and (CompilerVersion >= 20.0)) or Defined(FPC)}override;{$IFEND} + + { Creates a new image data with the given size and format. Old image + data is lost. Works only for the current image of TMultiImage.} + procedure RecreateImageData(AWidth, AHeight: Integer; AFormat: TImageFormat); + { Maps underlying image data to given TImageData record. Both TBaseImage and + TImageData now share some image memory (bits). So don't call FreeImage + on TImageData afterwards since this TBaseImage would get really broken.} + procedure MapImageData(const ImageData: TImageData); + { Deletes current image.} + procedure Clear; + + { Resizes current image with optional resampling.} + procedure Resize(NewWidth, NewHeight: Integer; Filter: TResizeFilter); + { Resizes current image proportionally to fit the given width and height. } + procedure ResizeToFit(FitWidth, FitHeight: Integer; Filter: TResizeFilter; DstImage: TBaseImage); + { Flips current image. Reverses the image along its horizontal axis the top + becomes the bottom and vice versa.} + procedure Flip; + { Mirrors current image. Reverses the image along its vertical axis the left + side becomes the right and vice versa.} + procedure Mirror; + { Rotates image by Angle degrees counterclockwise.} + procedure Rotate(Angle: Single); + { Copies rectangular part of SrcImage to DstImage. No blending is performed - + alpha is simply copied to destination image. Operates also with + negative X and Y coordinates. + Note that copying is fastest for images in the same data format + (and slowest for images in special formats).} + procedure CopyTo(SrcX, SrcY, Width, Height: Integer; DstImage: TBaseImage; DstX, DstY: Integer); overload; + { Copies whole image to DstImage. No blending is performed - + alpha is simply copied to destination image. Operates also with + negative X and Y coordinates. + Note that copying is fastest for images in the same data format + (and slowest for images in special formats).} + procedure CopyTo(DstImage: TBaseImage; DstX, DstY: Integer); overload; + { Stretches the contents of the source rectangle to the destination rectangle + with optional resampling. No blending is performed - alpha is + simply copied/resampled to destination image. Note that stretching is + fastest for images in the same data format (and slowest for + images in special formats).} + procedure StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: Integer; DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: Integer; Filter: TResizeFilter); + { Replaces pixels with OldPixel in the given rectangle by NewPixel. + OldPixel and NewPixel should point to the pixels in the same format + as the given image is in.} + procedure ReplaceColor(X, Y, Width, Height: Integer; OldColor, NewColor: Pointer); + { Swaps SrcChannel and DstChannel color or alpha channels of image. + Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to + identify channels.} + procedure SwapChannels(SrcChannel, DstChannel: Integer); + + { Loads current image data from file.} + procedure LoadFromFile(const FileName: string); virtual; + { Loads current image data from stream.} + procedure LoadFromStream(Stream: TStream); virtual; + + { Saves current image data to file.} + function SaveToFile(const FileName: string): Boolean; + { Saves current image data to stream. Ext identifies desired image file + format (jpg, png, dds, ...).} + function SaveToStream(const Ext: string; Stream: TStream): Boolean; + + { Width of current image in pixels.} + property Width: Integer read GetWidth write SetWidth; + { Height of current image in pixels.} + property Height: Integer read GetHeight write SetHeight; + { Image data format of current image.} + property Format: TImageFormat read GetFormat write SetFormat; + { Size in bytes of current image's data.} + property Size: Integer read GetSize; + { Pointer to memory containing image bits.} + property Bits: Pointer read GetBits; + { Pointer to palette for indexed format images. It is nil for others. + Max palette entry is at index [PaletteEntries - 1].} + property Palette: PPalette32 read GetPalette; + { Number of entries in image's palette} + property PaletteEntries: Integer read GetPaletteEntries; + { Provides indexed access to each line of pixels. Does not work with special + format images (like DXT).} + property Scanline[Index: Integer]: Pointer read GetScanline; + { Returns pointer to image pixel at [X, Y] coordinates.} + property PixelPointer[X, Y: Integer]: Pointer read GetPixelPointer; + { Size/length of one image scanline in bytes.} + property ScanlineSize: Integer read GetScanlineSize; + { Extended image format information.} + property FormatInfo: TImageFormatInfo read GetFormatInfo; + { This gives complete access to underlying TImageData record. + It can be used in functions that take TImageData as parameter + (for example: ReduceColors(SingleImageInstance.ImageData^, 64)).} + property ImageDataPointer: PImageData read FPData; + { Indicates whether the current image is valid (proper format, + allowed dimensions, right size, ...).} + property Valid: Boolean read GetValid; + { Indicates whether image contains any data (size in bytes > 0).} + property Empty: Boolean read GetEmpty; + { Specifies the bounding rectangle of the image.} + property BoundsRect: TRect read GetBoundsRect; + { This event occurs when the image data size has just changed. That means + image width, height, or format has been changed.} + property OnDataSizeChanged: TNotifyEvent read FOnDataSizeChanged write FOnDataSizeChanged; + { This event occurs when some pixels of the image have just changed.} + property OnPixelsChanged: TNotifyEvent read FOnPixelsChanged write FOnPixelsChanged; + end; + + { Extension of TBaseImage which uses single TImageData record to + store image. All methods inherited from TBaseImage work with this record.} + TSingleImage = class(TBaseImage) + protected + FImageData: TImageData; + procedure SetPointer; override; + public + constructor Create; override; + constructor CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat = ifDefault); + constructor CreateFromData(const AData: TImageData); + constructor CreateFromFile(const FileName: string); + constructor CreateFromStream(Stream: TStream); + destructor Destroy; override; + { Assigns single image from another single image or multi image.} + procedure Assign(Source: TPersistent); override; + { Assigns single image from image data record.} + procedure AssignFromImageData(const AImageData: TImageData); + end; + + { Extension of TBaseImage which uses array of TImageData records to + store multiple images. Images are independent on each other and they don't + share any common characteristic. Each can have different size, format, and + palette. All methods inherited from TBaseImage work only with + active image (it could represent mipmap level, animation frame, or whatever). + Methods whose names contain word 'Multi' work with all images in array + (as well as other methods with obvious names).} + TMultiImage = class(TBaseImage) + protected + FDataArray: TDynImageDataArray; + FActiveImage: Integer; + procedure SetActiveImage(Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetImageCount: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetImageCount(Value: Integer); + function GetAllImagesValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} + function GetImage(Index: Integer): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetImage(Index: Integer; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF} + procedure SetPointer; override; + function PrepareInsert(Index, InsertCount: Integer): Boolean; + procedure DoInsertImages(Index: Integer; const Images: TDynImageDataArray); + procedure DoInsertNew(Index: Integer; AWidth, AHeight: Integer; AFormat: TImageFormat); + public + constructor Create; override; + constructor CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat; ImageCount: Integer); + constructor CreateFromArray(const ADataArray: TDynImageDataArray); + constructor CreateFromFile(const FileName: string); + constructor CreateFromStream(Stream: TStream); + destructor Destroy; override; + { Assigns multi image from another multi image or single image.} + procedure Assign(Source: TPersistent); override; + { Assigns multi image from array of image data records.} + procedure AssignFromArray(const ADataArray: TDynImageDataArray); + + { Adds new image at the end of the image array. Returns index of the added image.} + function AddImage(AWidth, AHeight: Integer; AFormat: TImageFormat = ifDefault): Integer; overload; + { Adds existing image at the end of the image array. Returns index of the added image.} + function AddImage(const Image: TImageData): Integer; overload; + { Adds existing image (or active image of a TMultiImage) + at the end of the image array. Returns index of the added image.} + function AddImage(Image: TBaseImage): Integer; overload; + { Adds existing image array (all images of a multi image) + at the end of the image array.} + procedure AddImages(const Images: TDynImageDataArray); overload; + { Adds existing MultiImage images at the end of the image array.} + procedure AddImages(Images: TMultiImage); overload; + + { Inserts new image image at the given position in the image array. } + procedure InsertImage(Index, AWidth, AHeight: Integer; AFormat: TImageFormat = ifDefault); overload; + { Inserts existing image at the given position in the image array. } + procedure InsertImage(Index: Integer; const Image: TImageData); overload; + { Inserts existing image (Active image of a TMultiImage) + at the given position in the image array. } + procedure InsertImage(Index: Integer; Image: TBaseImage); overload; + { Inserts existing image at the given position in the image array. } + procedure InsertImages(Index: Integer; const Images: TDynImageDataArray); overload; + { Inserts existing images (all images of a TMultiImage) at + the given position in the image array. } + procedure InsertImages(Index: Integer; Images: TMultiImage); overload; + + { Exchanges two images at the given positions in the image array. } + procedure ExchangeImages(Index1, Index2: Integer); + { Deletes image at the given position in the image array.} + procedure DeleteImage(Index: Integer); + { Rearranges images so that the first image will become last and vice versa.} + procedure ReverseImages; + { Deletes all images.} + procedure ClearAll; + + { Converts all images to another image data format.} + procedure ConvertImages(Format: TImageFormat); + { Resizes all images.} + procedure ResizeImages(NewWidth, NewHeight: Integer; Filter: TResizeFilter); + + { Overloaded loading method that will add new image to multi-image if + image array is empty before loading. If it's not empty the active image is replaced.} + procedure LoadFromFile(const FileName: string); override; + { Overloaded loading method that will add new image to multi-image if + image array is empty before loading. If it's not empty the active image is replaced.} + procedure LoadFromStream(Stream: TStream); override; + + { Loads whole multi image from file.} + procedure LoadMultiFromFile(const FileName: string); + { Loads whole multi image from stream.} + procedure LoadMultiFromStream(Stream: TStream); + { Saves whole multi image to file.} + function SaveMultiToFile(const FileName: string): Boolean; + { Saves whole multi image to stream. Ext identifies desired + image file format (jpg, png, dds, ...).} + function SaveMultiToStream(const Ext: string; Stream: TStream): Boolean; + + { Indicates active image of this multi image. All methods inherited + from TBaseImage operate on this image only.} + property ActiveImage: Integer read FActiveImage write SetActiveImage; + { Number of images of this multi image.} + property ImageCount: Integer read GetImageCount write SetImageCount; + { This value is True if all images of this TMultiImage are valid.} + property AllImagesValid: Boolean read GetAllImagesValid; + { This gives complete access to underlying TDynImageDataArray. + It can be used in functions that take TDynImageDataArray + as parameter.} + property DataArray: TDynImageDataArray read FDataArray; + { Array property for accessing individual images of TMultiImage. When you + set image at given index the old image is freed and the source is cloned.} + property Images[Index: Integer]: TImageData read GetImage write SetImage; default; + end; + +implementation + +const + DefaultWidth = 16; + DefaultHeight = 16; + +function GetArrayFromImageData(const ImageData: TImageData): TDynImageDataArray; +begin + SetLength(Result, 1); + Result[0] := ImageData; +end; + +{ TBaseImage class implementation } + +constructor TBaseImage.Create; +begin + SetPointer; +end; + +constructor TBaseImage.CreateFromImage(AImage: TBaseImage); +begin + Create; + Assign(AImage); +end; + +destructor TBaseImage.Destroy; +begin + inherited Destroy; +end; + +function TBaseImage.GetWidth: Integer; +begin + if Valid then + Result := FPData.Width + else + Result := 0; +end; + +function TBaseImage.GetHeight: Integer; +begin + if Valid then + Result := FPData.Height + else + Result := 0; +end; + +function TBaseImage.GetFormat: TImageFormat; +begin + if Valid then + Result := FPData.Format + else + Result := ifUnknown; +end; + +function TBaseImage.GetScanline(Index: Integer): Pointer; +var + Info: TImageFormatInfo; +begin + if Valid then + begin + Info := GetFormatInfo; + if not Info.IsSpecial then + Result := ImagingFormats.GetScanLine(FPData.Bits, Info, FPData.Width, Index) + else + Result := FPData.Bits; + end + else + Result := nil; +end; + +function TBaseImage.GetScanlineSize: Integer; +begin + if Valid then + Result := FormatInfo.GetPixelsSize(Format, Width, 1) + else + Result := 0; +end; + +function TBaseImage.GetPixelPointer(X, Y: Integer): Pointer; +begin + if Valid then + Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * GetFormatInfo.BytesPerPixel] + else + Result := nil; +end; + +function TBaseImage.GetSize: Integer; +begin + if Valid then + Result := FPData.Size + else + Result := 0; +end; + +function TBaseImage.GetBits: Pointer; +begin + if Valid then + Result := FPData.Bits + else + Result := nil; +end; + +function TBaseImage.GetPalette: PPalette32; +begin + if Valid then + Result := FPData.Palette + else + Result := nil; +end; + +function TBaseImage.GetPaletteEntries: Integer; +begin + Result := GetFormatInfo.PaletteEntries; +end; + +function TBaseImage.GetFormatInfo: TImageFormatInfo; +begin + if Valid then + Imaging.GetImageFormatInfo(FPData.Format, Result) + else + FillChar(Result, SizeOf(Result), 0); +end; + +function TBaseImage.GetValid: Boolean; +begin + Result := Assigned(FPData) and Imaging.TestImage(FPData^); +end; + +function TBaseImage.GetBoundsRect: TRect; +begin + Result := Rect(0, 0, GetWidth, GetHeight); +end; + +function TBaseImage.GetEmpty: Boolean; +begin + Result := FPData.Size = 0; +end; + +procedure TBaseImage.SetWidth(const Value: Integer); +begin + Resize(Value, GetHeight, rfNearest); +end; + +procedure TBaseImage.SetHeight(const Value: Integer); +begin + Resize(GetWidth, Value, rfNearest); +end; + +procedure TBaseImage.SetFormat(const Value: TImageFormat); +begin + if Valid and Imaging.ConvertImage(FPData^, Value) then + DoDataSizeChanged; +end; + +procedure TBaseImage.DoDataSizeChanged; +begin + if Assigned(FOnDataSizeChanged) then + FOnDataSizeChanged(Self); + DoPixelsChanged; +end; + +procedure TBaseImage.DoPixelsChanged; +begin + if Assigned(FOnPixelsChanged) then + FOnPixelsChanged(Self); +end; + +procedure TBaseImage.RecreateImageData(AWidth, AHeight: Integer; AFormat: TImageFormat); +begin + if Assigned(FPData) and Imaging.NewImage(AWidth, AHeight, AFormat, FPData^) then + DoDataSizeChanged; +end; + +procedure TBaseImage.MapImageData(const ImageData: TImageData); +begin + Clear; + FPData.Width := ImageData.Width; + FPData.Height := ImageData.Height; + FPData.Format := ImageData.Format; + FPData.Size := ImageData.Size; + FPData.Bits := ImageData.Bits; + FPData.Palette := ImageData.Palette; +end; + +procedure TBaseImage.Clear; +begin + FreeImage(FPData^); +end; + +procedure TBaseImage.Resize(NewWidth, NewHeight: Integer; Filter: TResizeFilter); +begin + if Valid and Imaging.ResizeImage(FPData^, NewWidth, NewHeight, Filter) then + DoDataSizeChanged; +end; + +procedure TBaseImage.ResizeToFit(FitWidth, FitHeight: Integer; + Filter: TResizeFilter; DstImage: TBaseImage); +begin + if Valid and Assigned(DstImage) then + begin + Imaging.ResizeImageToFit(FPData^, FitWidth, FitHeight, Filter, + DstImage.FPData^); + DstImage.DoDataSizeChanged; + end; +end; + +procedure TBaseImage.Flip; +begin + if Valid and Imaging.FlipImage(FPData^) then + DoPixelsChanged; +end; + +procedure TBaseImage.Mirror; +begin + if Valid and Imaging.MirrorImage(FPData^) then + DoPixelsChanged; +end; + +procedure TBaseImage.Rotate(Angle: Single); +begin + if Valid then + begin + Imaging.RotateImage(FPData^, Angle); + DoPixelsChanged; + end; +end; + +procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: Integer; + DstImage: TBaseImage; DstX, DstY: Integer); +begin + if Valid and Assigned(DstImage) and DstImage.Valid then + begin + Imaging.CopyRect(FPData^, SrcX, SrcY, Width, Height, DstImage.FPData^, DstX, DstY); + DstImage.DoPixelsChanged; + end; +end; + +procedure TBaseImage.CopyTo(DstImage: TBaseImage; DstX, DstY: Integer); +begin + if Valid and Assigned(DstImage) and DstImage.Valid then + begin + Imaging.CopyRect(FPData^, 0, 0, Width, Height, DstImage.FPData^, DstX, DstY); + DstImage.DoPixelsChanged; + end; +end; + +procedure TBaseImage.StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: Integer; + DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: Integer; Filter: TResizeFilter); +begin + if Valid and Assigned(DstImage) and DstImage.Valid then + begin + Imaging.StretchRect(FPData^, SrcX, SrcY, SrcWidth, SrcHeight, + DstImage.FPData^, DstX, DstY, DstWidth, DstHeight, Filter); + DstImage.DoPixelsChanged; + end; +end; + +procedure TBaseImage.ReplaceColor(X, Y, Width, Height: Integer; OldColor, + NewColor: Pointer); +begin + if Valid then + begin + Imaging.ReplaceColor(FPData^, X, Y, Width, Height, OldColor, NewColor); + DoPixelsChanged; + end; +end; + +procedure TBaseImage.SwapChannels(SrcChannel, DstChannel: Integer); +begin + if Valid then + begin + Imaging.SwapChannels(FPData^, SrcChannel, DstChannel); + DoPixelsChanged; + end; +end; + +function TBaseImage.ToString: string; +begin + Result := Iff(Valid, Imaging.ImageToStr(FPData^), 'empty image'); +end; + +procedure TBaseImage.LoadFromFile(const FileName: string); +begin + if Assigned(FPData) and Imaging.LoadImageFromFile(FileName, FPData^) then + DoDataSizeChanged; +end; + +procedure TBaseImage.LoadFromStream(Stream: TStream); +begin + if Assigned(FPData) and Imaging.LoadImageFromStream(Stream, FPData^) then + DoDataSizeChanged; +end; + +function TBaseImage.SaveToFile(const FileName: string): Boolean; +begin + if Valid then + Result := Imaging.SaveImageToFile(FileName, FPData^) + else + Result := False; +end; + +function TBaseImage.SaveToStream(const Ext: string; Stream: TStream): Boolean; +begin + if Valid then + Result := Imaging.SaveImageToStream(Ext, Stream, FPData^) + else + Result := False; +end; + + +{ TSingleImage class implementation } + +constructor TSingleImage.Create; +begin + inherited Create; + Clear; +end; + +constructor TSingleImage.CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat); +begin + inherited Create; + RecreateImageData(AWidth, AHeight, AFormat); +end; + +constructor TSingleImage.CreateFromData(const AData: TImageData); +begin + inherited Create; + AssignFromImageData(AData); +end; + +constructor TSingleImage.CreateFromFile(const FileName: string); +begin + inherited Create; + LoadFromFile(FileName); +end; + +constructor TSingleImage.CreateFromStream(Stream: TStream); +begin + inherited Create; + LoadFromStream(Stream); +end; + +destructor TSingleImage.Destroy; +begin + Imaging.FreeImage(FImageData); + inherited Destroy; +end; + +procedure TSingleImage.SetPointer; +begin + FPData := @FImageData; +end; + +procedure TSingleImage.Assign(Source: TPersistent); +begin + if Source = nil then + begin + Clear; + end + else if Source is TSingleImage then + begin + AssignFromImageData(TSingleImage(Source).FImageData); + end + else if Source is TMultiImage then + begin + if TMultiImage(Source).Valid then + AssignFromImageData(TMultiImage(Source).FPData^) + else + Clear; + end + else + inherited Assign(Source); +end; + +procedure TSingleImage.AssignFromImageData(const AImageData: TImageData); +begin + if Imaging.TestImage(AImageData) then + begin + Imaging.CloneImage(AImageData, FImageData); + DoDataSizeChanged; + end + else + Clear; +end; + +{ TMultiImage class implementation } + +constructor TMultiImage.Create; +begin + inherited Create; +end; + +constructor TMultiImage.CreateFromParams(AWidth, AHeight: Integer; + AFormat: TImageFormat; ImageCount: Integer); +var + I: Integer; +begin + Imaging.FreeImagesInArray(FDataArray); + SetLength(FDataArray, ImageCount); + for I := 0 to GetImageCount - 1 do + Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[I]); + if GetImageCount > 0 then + SetActiveImage(0); +end; + +constructor TMultiImage.CreateFromArray(const ADataArray: TDynImageDataArray); +begin + AssignFromArray(ADataArray); +end; + +constructor TMultiImage.CreateFromFile(const FileName: string); +begin + LoadMultiFromFile(FileName); +end; + +constructor TMultiImage.CreateFromStream(Stream: TStream); +begin + LoadMultiFromStream(Stream); +end; + +destructor TMultiImage.Destroy; +begin + Imaging.FreeImagesInArray(FDataArray); + inherited Destroy; +end; + +procedure TMultiImage.SetActiveImage(Value: Integer); +begin + FActiveImage := Value; + SetPointer; +end; + +function TMultiImage.GetImageCount: Integer; +begin + Result := Length(FDataArray); +end; + +procedure TMultiImage.SetImageCount(Value: Integer); +var + I, OldCount: Integer; +begin + if Value > GetImageCount then + begin + // Create new empty images if array will be enlarged + OldCount := GetImageCount; + SetLength(FDataArray, Value); + for I := OldCount to Value - 1 do + Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]); + end + else + begin + // Free images that exceed desired count and shrink array + for I := Value to GetImageCount - 1 do + Imaging.FreeImage(FDataArray[I]); + SetLength(FDataArray, Value); + end; + SetPointer; +end; + +function TMultiImage.GetAllImagesValid: Boolean; +begin + Result := (GetImageCount > 0) and TestImagesInArray(FDataArray); +end; + +function TMultiImage.GetImage(Index: Integer): TImageData; +begin + if (Index >= 0) and (Index < GetImageCount) then + Result := FDataArray[Index]; +end; + +procedure TMultiImage.SetImage(Index: Integer; Value: TImageData); +begin + if (Index >= 0) and (Index < GetImageCount) then + Imaging.CloneImage(Value, FDataArray[Index]); +end; + +procedure TMultiImage.SetPointer; +begin + if GetImageCount > 0 then + begin + FActiveImage := ClampInt(FActiveImage, 0, GetImageCount - 1); + FPData := @FDataArray[FActiveImage]; + end + else + begin + FActiveImage := -1; + FPData := nil + end; +end; + +function TMultiImage.PrepareInsert(Index, InsertCount: Integer): Boolean; +var + I: Integer; + OldImageCount, MoveCount: Integer; +begin + OldImageCount := GetImageCount; + + // Inserting to empty image will add image at index 0 + if OldImageCount = 0 then + Index := 0; + + if (Index >= 0) and (Index <= OldImageCount) and (InsertCount > 0) then + begin + SetLength(FDataArray, OldImageCount + InsertCount); + if Index < OldImageCount then + begin + // Move images to new position + MoveCount := OldImageCount - Index; + System.Move(FDataArray[Index], FDataArray[Index + InsertCount], MoveCount * SizeOf(TImageData)); + // Null old images, not free them! + for I := Index to Index + InsertCount - 1 do + InitImage(FDataArray[I]); + end; + Result := True; + end + else + Result := False; +end; + +procedure TMultiImage.DoInsertImages(Index: Integer; const Images: TDynImageDataArray); +var + I, Len: Integer; +begin + Len := Length(Images); + if PrepareInsert(Index, Len) then + begin + for I := 0 to Len - 1 do + Imaging.CloneImage(Images[I], FDataArray[Index + I]); + end; +end; + +procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: Integer; + AFormat: TImageFormat); +begin + if PrepareInsert(Index, 1) then + Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[Index]); +end; + +procedure TMultiImage.Assign(Source: TPersistent); +var + Arr: TDynImageDataArray; +begin + if Source = nil then + begin + ClearAll; + end + else if Source is TMultiImage then + begin + AssignFromArray(TMultiImage(Source).FDataArray); + SetActiveImage(TMultiImage(Source).ActiveImage); + end + else if Source is TSingleImage then + begin + SetLength(Arr, 1); + Arr[0] := TSingleImage(Source).FImageData; + AssignFromArray(Arr); + end + else + inherited Assign(Source); +end; + +procedure TMultiImage.AssignFromArray(const ADataArray: TDynImageDataArray); +var + I: Integer; +begin + Imaging.FreeImagesInArray(FDataArray); + SetLength(FDataArray, Length(ADataArray)); + for I := 0 to GetImageCount - 1 do + begin + // Clone only valid images + if Imaging.TestImage(ADataArray[I]) then + Imaging.CloneImage(ADataArray[I], FDataArray[I]) + else + Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]); + end; + if GetImageCount > 0 then + SetActiveImage(0); +end; + +function TMultiImage.AddImage(AWidth, AHeight: Integer; AFormat: TImageFormat): Integer; +begin + Result := GetImageCount; + DoInsertNew(Result, AWidth, AHeight, AFormat); +end; + +function TMultiImage.AddImage(const Image: TImageData): Integer; +begin + Result := GetImageCount; + DoInsertImages(Result, GetArrayFromImageData(Image)); +end; + +function TMultiImage.AddImage(Image: TBaseImage): Integer; +begin + if Assigned(Image) and Image.Valid then + begin + Result := GetImageCount; + DoInsertImages(Result, GetArrayFromImageData(Image.FPData^)); + end + else + Result := -1; +end; + +procedure TMultiImage.AddImages(const Images: TDynImageDataArray); +begin + DoInsertImages(GetImageCount, Images); +end; + +procedure TMultiImage.AddImages(Images: TMultiImage); +begin + DoInsertImages(GetImageCount, Images.FDataArray); +end; + +procedure TMultiImage.InsertImage(Index, AWidth, AHeight: Integer; + AFormat: TImageFormat); +begin + DoInsertNew(Index, AWidth, AHeight, AFormat); +end; + +procedure TMultiImage.InsertImage(Index: Integer; const Image: TImageData); +begin + DoInsertImages(Index, GetArrayFromImageData(Image)); +end; + +procedure TMultiImage.InsertImage(Index: Integer; Image: TBaseImage); +begin + if Assigned(Image) and Image.Valid then + DoInsertImages(Index, GetArrayFromImageData(Image.FPData^)); +end; + +procedure TMultiImage.InsertImages(Index: Integer; + const Images: TDynImageDataArray); +begin + DoInsertImages(Index, Images); +end; + +procedure TMultiImage.InsertImages(Index: Integer; Images: TMultiImage); +begin + DoInsertImages(Index, Images.FDataArray); +end; + +procedure TMultiImage.ExchangeImages(Index1, Index2: Integer); +var + TempData: TImageData; +begin + if (Index1 >= 0) and (Index1 < GetImageCount) and + (Index2 >= 0) and (Index2 < GetImageCount) then + begin + TempData := FDataArray[Index1]; + FDataArray[Index1] := FDataArray[Index2]; + FDataArray[Index2] := TempData; + end; +end; + +procedure TMultiImage.DeleteImage(Index: Integer); +var + I: Integer; +begin + if (Index >= 0) and (Index < GetImageCount) then + begin + // Free image at index to be deleted + Imaging.FreeImage(FDataArray[Index]); + if Index < GetImageCount - 1 then + begin + // Move images to new indices if necessary + for I := Index to GetImageCount - 2 do + FDataArray[I] := FDataArray[I + 1]; + end; + // Set new array length and update pointer to active image + SetLength(FDataArray, GetImageCount - 1); + SetPointer; + end; +end; + +procedure TMultiImage.ClearAll; +begin + ImageCount := 0; +end; + +procedure TMultiImage.ConvertImages(Format: TImageFormat); +var + I: Integer; +begin + for I := 0 to GetImageCount - 1 do + Imaging.ConvertImage(FDataArray[I], Format); +end; + +procedure TMultiImage.ResizeImages(NewWidth, NewHeight: Integer; + Filter: TResizeFilter); +var + I: Integer; +begin + for I := 0 to GetImageCount - 1 do + Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter); +end; + +procedure TMultiImage.ReverseImages; +var + I: Integer; +begin + for I := 0 to GetImageCount div 2 do + ExchangeImages(I, GetImageCount - 1 - I); +end; + +procedure TMultiImage.LoadFromFile(const FileName: string); +begin + if GetImageCount = 0 then + ImageCount := 1; + inherited LoadFromFile(FileName); +end; + +procedure TMultiImage.LoadFromStream(Stream: TStream); +begin + if GetImageCount = 0 then + ImageCount := 1; + inherited LoadFromStream(Stream); +end; + +procedure TMultiImage.LoadMultiFromFile(const FileName: string); +begin + Imaging.LoadMultiImageFromFile(FileName, FDataArray); + SetActiveImage(0); +end; + +procedure TMultiImage.LoadMultiFromStream(Stream: TStream); +begin + Imaging.LoadMultiImageFromStream(Stream, FDataArray); + SetActiveImage(0); +end; + +function TMultiImage.SaveMultiToFile(const FileName: string): Boolean; +begin + Result := Imaging.SaveMultiImageToFile(FileName, FDataArray); +end; + +function TMultiImage.SaveMultiToStream(const Ext: string; Stream: TStream): Boolean; +begin + Result := Imaging.SaveMultiImageToStream(Ext, Stream, FDataArray); +end; + +{ + File Notes (obsolete): + + -- 0.77.1 --------------------------------------------------- + - Added TSingleImage.AssignFromData and TMultiImage.AssignFromArray + as a replacement for constructors used as methods (that is + compiler error in Delphi XE3). + - Added TBaseImage.ResizeToFit method. + - Changed TMultiImage to have default state with no images. + - TMultiImage.AddImage now returns index of newly added image. + - Fixed img index bug in TMultiImage.ResizeImages + + -- 0.26.5 Changes/Bug Fixes --------------------------------- + - Added MapImageData method to TBaseImage + - Added Empty property to TBaseImage. + - Added Clear method to TBaseImage. + - Added ScanlineSize property to TBaseImage. + + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - Added TMultiImage.ReverseImages method. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Added SwapChannels method to TBaseImage. + - Added ReplaceColor method to TBaseImage. + - Added ToString method to TBaseImage. + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Inserting images to empty MultiImage will act as Add method. + - MultiImages with empty arrays will now create one image when + LoadFromFile or LoadFromStream is called. + - Fixed bug that caused AVs when getting props like Width, Height, asn Size + and when inlining was off. There was call to Iff but with inlining disabled + params like FPData.Size were evaluated and when FPData was nil => AV. + - Added many FPData validity checks to many methods. There were AVs + when calling most methods on empty TMultiImage. + - Added AllImagesValid property to TMultiImage. + - Fixed memory leak in TMultiImage.CreateFromParams. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - added ResizeImages method to TMultiImage + - removed Ext parameter from various LoadFromStream methods, no + longer needed + - fixed various issues concerning ActiveImage of TMultiImage + (it pointed to invalid location after some operations) + - most of property set/get methods are now inline + - added PixelPointers property to TBaseImage + - added Images default array property to TMultiImage + - renamed methods in TMultiImage to contain 'Image' instead of 'Level' + - added canvas support + - added OnDataSizeChanged and OnPixelsChanged event to TBaseImage + - renamed TSingleImage.NewImage to RecreateImageData, made public, and + moved to TBaseImage + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - added props PaletteEntries and ScanLine to TBaseImage + - added new constructor to TBaseImage that take TBaseImage source + - TMultiImage levels adding and inserting rewritten internally + - added some new functions to TMultiImage: AddLevels, InsertLevels + - added some new functions to TBaseImage: Flip, Mirror, Rotate, + CopyRect, StretchRect + - TBasicImage.Resize has now filter parameter + - new stuff added to TMultiImage (DataArray prop, ConvertLevels) + + -- 0.13 Changes/Bug Fixes ----------------------------------- + - added AddLevel, InsertLevel, ExchangeLevels and DeleteLevel + methods to TMultiImage + - added TBaseImage, TSingleImage and TMultiImage with initial + members +} + +end. + diff --git a/Imaging/ImagingColors.pas b/Imaging/ImagingColors.pas index 941808b..596f280 100644 --- a/Imaging/ImagingColors.pas +++ b/Imaging/ImagingColors.pas @@ -1,245 +1,230 @@ -{ - $Id: ImagingColors.pas 173 2009-09-04 17:05:52Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains functions for manipulating and converting color values.} -unit ImagingColors; - -interface - -{$I ImagingOptions.inc} - -uses - SysUtils, ImagingTypes, ImagingUtility; - -{ Converts RGB color to YUV.} -procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte); -{ Converts YIV to RGB color.} -procedure YUVToRGB(Y, U, V: Byte; var R, G, B: Byte); - -{ Converts RGB color to YCbCr as used in JPEG.} -procedure RGBToYCbCr(R, G, B: Byte; var Y, Cb, Cr: Byte); -{ Converts YCbCr as used in JPEG to RGB color.} -procedure YCbCrToRGB(Y, Cb, Cr: Byte; var R, G, B: Byte); -{ Converts RGB color to YCbCr as used in JPEG.} -procedure RGBToYCbCr16(R, G, B: Word; var Y, Cb, Cr: Word); -{ Converts YCbCr as used in JPEG to RGB color.} -procedure YCbCrToRGB16(Y, Cb, Cr: Word; var R, G, B: Word); - -{ Converts RGB color to CMY.} -procedure RGBToCMY(R, G, B: Byte; var C, M, Y: Byte); -{ Converts CMY to RGB color.} -procedure CMYToRGB(C, M, Y: Byte; var R, G, B: Byte); -{ Converts RGB color to CMY.} -procedure RGBToCMY16(R, G, B: Word; var C, M, Y: Word); -{ Converts CMY to RGB color.} -procedure CMYToRGB16(C, M, Y: Word; var R, G, B: Word); - -{ Converts RGB color to CMYK.} -procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte); -{ Converts CMYK to RGB color.} -procedure CMYKToRGB(C, M, Y, K: Byte; var R, G, B: Byte); -{ Converts RGB color to CMYK.} -procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word); -{ Converts CMYK to RGB color.} -procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word); - -{ Converts RGB color to YCoCg.} -procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte); -{ Converts YCoCg to RGB color.} -procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte); - - -implementation - -procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte); -begin - Y := ClampToByte(Round( 0.257 * R + 0.504 * G + 0.098 * B) + 16); - V := ClampToByte(Round( 0.439 * R - 0.368 * G - 0.071 * B) + 128); - U := ClampToByte(Round(-0.148 * R - 0.291 * G + 0.439 * B) + 128); -end; - -procedure YUVToRGB(Y, U, V: Byte; var R, G, B: Byte); -var - CY, CU, CV: LongInt; -begin - CY := Y - 16; - CU := U - 128; - CV := V - 128; - R := ClampToByte(Round(1.164 * CY - 0.002 * CU + 1.596 * CV)); - G := ClampToByte(Round(1.164 * CY - 0.391 * CU - 0.813 * CV)); - B := ClampToByte(Round(1.164 * CY + 2.018 * CU - 0.001 * CV)); -end; - -procedure RGBToYCbCr(R, G, B: Byte; var Y, Cb, Cr: Byte); -begin - Y := ClampToByte(Round( 0.29900 * R + 0.58700 * G + 0.11400 * B)); - Cb := ClampToByte(Round(-0.16874 * R - 0.33126 * G + 0.50000 * B + 128)); - Cr := ClampToByte(Round( 0.50000 * R - 0.41869 * G - 0.08131 * B + 128)); -end; - -procedure YCbCrToRGB(Y, Cb, Cr: Byte; var R, G, B: Byte); -begin - R := ClampToByte(Round(Y + 1.40200 * (Cr - 128))); - G := ClampToByte(Round(Y - 0.34414 * (Cb - 128) - 0.71414 * (Cr - 128))); - B := ClampToByte(Round(Y + 1.77200 * (Cb - 128))); -end; - -procedure RGBToYCbCr16(R, G, B: Word; var Y, Cb, Cr: Word); -begin - Y := ClampToWord(Round( 0.29900 * R + 0.58700 * G + 0.11400 * B)); - Cb := ClampToWord(Round(-0.16874 * R - 0.33126 * G + 0.50000 * B + 32768)); - Cr := ClampToWord(Round( 0.50000 * R - 0.41869 * G - 0.08131 * B + 32768)); -end; - -procedure YCbCrToRGB16(Y, Cb, Cr: Word; var R, G, B: Word); -begin - R := ClampToWord(Round(Y + 1.40200 * (Cr - 32768))); - G := ClampToWord(Round(Y - 0.34414 * (Cb - 32768) - 0.71414 * (Cr - 32768))); - B := ClampToWord(Round(Y + 1.77200 * (Cb - 32768))); -end; - -procedure RGBToCMY(R, G, B: Byte; var C, M, Y: Byte); -begin - C := 255 - R; - M := 255 - G; - Y := 255 - B; -end; - -procedure CMYToRGB(C, M, Y: Byte; var R, G, B: Byte); -begin - R := 255 - C; - G := 255 - M; - B := 255 - Y; -end; - -procedure RGBToCMY16(R, G, B: Word; var C, M, Y: Word); -begin - C := 65535 - R; - M := 65535 - G; - Y := 65535 - B; -end; - -procedure CMYToRGB16(C, M, Y: Word; var R, G, B: Word); -begin - R := 65535 - C; - G := 65535 - M; - B := 65535 - Y; -end; - -procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte); -begin - RGBToCMY(R, G, B, C, M, Y); - K := Min(C, Min(M, Y)); - if K = 255 then - begin - C := 0; - M := 0; - Y := 0; - end - else - begin - C := ClampToByte(Round((C - K) / (255 - K) * 255)); - M := ClampToByte(Round((M - K) / (255 - K) * 255)); - Y := ClampToByte(Round((Y - K) / (255 - K) * 255)); - end; -end; - -procedure CMYKToRGB(C, M, Y, K: Byte; var R, G, B: Byte); -begin - R := (255 - (C - MulDiv(C, K, 255) + K)); - G := (255 - (M - MulDiv(M, K, 255) + K)); - B := (255 - (Y - MulDiv(Y, K, 255) + K)); -end; - -procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word); -begin - RGBToCMY16(R, G, B, C, M, Y); - K := Min(C, Min(M, Y)); - if K = 65535 then - begin - C := 0; - M := 0; - Y := 0; - end - else - begin - C := ClampToWord(Round((C - K) / (65535 - K) * 65535)); - M := ClampToWord(Round((M - K) / (65535 - K) * 65535)); - Y := ClampToWord(Round((Y - K) / (65535 - K) * 65535)); - end; -end; - -procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word); -begin - R := 65535 - (C - MulDiv(C, K, 65535) + K); - G := 65535 - (M - MulDiv(M, K, 65535) + K); - B := 65535 - (Y - MulDiv(Y, K, 65535) + K); -end; - -procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte); -begin - // C and Delphi's SHR behaviour differs for negative numbers, use div instead. - Y := ClampToByte(( R + G shl 1 + B + 2) div 4); - Co := ClampToByte(( R shl 1 - B shl 1 + 2) div 4 + 128); - Cg := ClampToByte((-R + G shl 1 - B + 2) div 4 + 128); -end; - -procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte); -var - CoInt, CgInt: Integer; -begin - CoInt := Co - 128; - CgInt := Cg - 128; - R := ClampToByte(Y + CoInt - CgInt); - G := ClampToByte(Y + CgInt); - B := ClampToByte(Y - CoInt - CgInt); -end; - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.26.3 Changes/Bug Fixes --------------------------------- - - Added RGB<>YCoCg conversion functions. - - Fixed RGB>>CMYK conversions. - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Added RGB<>CMY(K) converion functions for 16 bit channels - (needed by PSD loading code). - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Added some color space conversion functions and LUTs - (RGB/YUV/YCrCb/CMY/CMYK). - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - unit created (empty!) -} - -end. +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains functions for manipulating and converting color values.} +unit ImagingColors; + +interface + +{$I ImagingOptions.inc} + +uses + SysUtils, ImagingTypes, ImagingUtility; + +{ Converts RGB color to YUV.} +procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte); +{ Converts YIV to RGB color.} +procedure YUVToRGB(Y, U, V: Byte; var R, G, B: Byte); + +{ Converts RGB color to YCbCr as used in JPEG.} +procedure RGBToYCbCr(R, G, B: Byte; var Y, Cb, Cr: Byte); +{ Converts YCbCr as used in JPEG to RGB color.} +procedure YCbCrToRGB(Y, Cb, Cr: Byte; var R, G, B: Byte); +{ Converts RGB color to YCbCr as used in JPEG.} +procedure RGBToYCbCr16(R, G, B: Word; var Y, Cb, Cr: Word); +{ Converts YCbCr as used in JPEG to RGB color.} +procedure YCbCrToRGB16(Y, Cb, Cr: Word; var R, G, B: Word); + +{ Converts RGB color to CMY.} +procedure RGBToCMY(R, G, B: Byte; var C, M, Y: Byte); +{ Converts CMY to RGB color.} +procedure CMYToRGB(C, M, Y: Byte; var R, G, B: Byte); +{ Converts RGB color to CMY.} +procedure RGBToCMY16(R, G, B: Word; var C, M, Y: Word); +{ Converts CMY to RGB color.} +procedure CMYToRGB16(C, M, Y: Word; var R, G, B: Word); + +{ Converts RGB color to CMYK.} +procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte); +{ Converts CMYK to RGB color.} +procedure CMYKToRGB(C, M, Y, K: Byte; var R, G, B: Byte); +{ Converts RGB color to CMYK.} +procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word); +{ Converts CMYK to RGB color.} +procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word); + +{ Converts RGB color to YCoCg.} +procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte); +{ Converts YCoCg to RGB color.} +procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte); + +//procedure RGBToHSL(R, G, B: Byte; var H, S, L: Byte); +//procedure HSLToRGB(H, S, L: Byte; var R, G, B: Byte); + +implementation + +procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte); +begin + Y := ClampToByte(Round( 0.257 * R + 0.504 * G + 0.098 * B) + 16); + V := ClampToByte(Round( 0.439 * R - 0.368 * G - 0.071 * B) + 128); + U := ClampToByte(Round(-0.148 * R - 0.291 * G + 0.439 * B) + 128); +end; + +procedure YUVToRGB(Y, U, V: Byte; var R, G, B: Byte); +var + CY, CU, CV: LongInt; +begin + CY := Y - 16; + CU := U - 128; + CV := V - 128; + R := ClampToByte(Round(1.164 * CY - 0.002 * CU + 1.596 * CV)); + G := ClampToByte(Round(1.164 * CY - 0.391 * CU - 0.813 * CV)); + B := ClampToByte(Round(1.164 * CY + 2.018 * CU - 0.001 * CV)); +end; + +procedure RGBToYCbCr(R, G, B: Byte; var Y, Cb, Cr: Byte); +begin + Y := ClampToByte(Round( 0.29900 * R + 0.58700 * G + 0.11400 * B)); + Cb := ClampToByte(Round(-0.16874 * R - 0.33126 * G + 0.50000 * B + 128)); + Cr := ClampToByte(Round( 0.50000 * R - 0.41869 * G - 0.08131 * B + 128)); +end; + +procedure YCbCrToRGB(Y, Cb, Cr: Byte; var R, G, B: Byte); +begin + R := ClampToByte(Round(Y + 1.40200 * (Cr - 128))); + G := ClampToByte(Round(Y - 0.34414 * (Cb - 128) - 0.71414 * (Cr - 128))); + B := ClampToByte(Round(Y + 1.77200 * (Cb - 128))); +end; + +procedure RGBToYCbCr16(R, G, B: Word; var Y, Cb, Cr: Word); +begin + Y := ClampToWord(Round( 0.29900 * R + 0.58700 * G + 0.11400 * B)); + Cb := ClampToWord(Round(-0.16874 * R - 0.33126 * G + 0.50000 * B + 32768)); + Cr := ClampToWord(Round( 0.50000 * R - 0.41869 * G - 0.08131 * B + 32768)); +end; + +procedure YCbCrToRGB16(Y, Cb, Cr: Word; var R, G, B: Word); +begin + R := ClampToWord(Round(Y + 1.40200 * (Cr - 32768))); + G := ClampToWord(Round(Y - 0.34414 * (Cb - 32768) - 0.71414 * (Cr - 32768))); + B := ClampToWord(Round(Y + 1.77200 * (Cb - 32768))); +end; + +procedure RGBToCMY(R, G, B: Byte; var C, M, Y: Byte); +begin + C := 255 - R; + M := 255 - G; + Y := 255 - B; +end; + +procedure CMYToRGB(C, M, Y: Byte; var R, G, B: Byte); +begin + R := 255 - C; + G := 255 - M; + B := 255 - Y; +end; + +procedure RGBToCMY16(R, G, B: Word; var C, M, Y: Word); +begin + C := 65535 - R; + M := 65535 - G; + Y := 65535 - B; +end; + +procedure CMYToRGB16(C, M, Y: Word; var R, G, B: Word); +begin + R := 65535 - C; + G := 65535 - M; + B := 65535 - Y; +end; + +procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte); +begin + RGBToCMY(R, G, B, C, M, Y); + K := Min(C, Min(M, Y)); + if K = 255 then + begin + C := 0; + M := 0; + Y := 0; + end + else + begin + C := ClampToByte(Round((C - K) / (255 - K) * 255)); + M := ClampToByte(Round((M - K) / (255 - K) * 255)); + Y := ClampToByte(Round((Y - K) / (255 - K) * 255)); + end; +end; + +procedure CMYKToRGB(C, M, Y, K: Byte; var R, G, B: Byte); +begin + R := (255 - (C - MulDiv(C, K, 255) + K)); + G := (255 - (M - MulDiv(M, K, 255) + K)); + B := (255 - (Y - MulDiv(Y, K, 255) + K)); +end; + +procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word); +begin + RGBToCMY16(R, G, B, C, M, Y); + K := Min(C, Min(M, Y)); + if K = 65535 then + begin + C := 0; + M := 0; + Y := 0; + end + else + begin + C := ClampToWord(Round((C - K) / (65535 - K) * 65535)); + M := ClampToWord(Round((M - K) / (65535 - K) * 65535)); + Y := ClampToWord(Round((Y - K) / (65535 - K) * 65535)); + end; +end; + +procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word); +begin + R := 65535 - (C - MulDiv(C, K, 65535) + K); + G := 65535 - (M - MulDiv(M, K, 65535) + K); + B := 65535 - (Y - MulDiv(Y, K, 65535) + K); +end; + +procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte); +begin + // C and Delphi's SHR behaviour differs for negative numbers, use div instead. + Y := ClampToByte(( R + G shl 1 + B + 2) div 4); + Co := ClampToByte(( R shl 1 - B shl 1 + 2) div 4 + 128); + Cg := ClampToByte((-R + G shl 1 - B + 2) div 4 + 128); +end; + +procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte); +var + CoInt, CgInt: Integer; +begin + CoInt := Co - 128; + CgInt := Cg - 128; + R := ClampToByte(Y + CoInt - CgInt); + G := ClampToByte(Y + CgInt); + B := ClampToByte(Y - CoInt - CgInt); +end; + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - nothing now + + -- 0.26.3 Changes/Bug Fixes --------------------------------- + - Added RGB<>YCoCg conversion functions. + - Fixed RGB>>CMYK conversions. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Added RGB<>CMY(K) conversion functions for 16 bit channels + (needed by PSD loading code). + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Added some color space conversion functions and LUTs + (RGB/YUV/YCrCb/CMY/CMYK). + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - unit created (empty!) +} + +end. diff --git a/Imaging/ImagingComponents.pas b/Imaging/ImagingComponents.pas index 4c560c0..f4d3109 100644 --- a/Imaging/ImagingComponents.pas +++ b/Imaging/ImagingComponents.pas @@ -1,1272 +1,1400 @@ -{ - $Id: ImagingComponents.pas 171 2009-09-02 01:34:19Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains VCL/LCL TGraphic descendant which uses Imaging library - for saving and loading.} -unit ImagingComponents; - -{$I ImagingOptions.inc} - -interface - -{$IFDEF LCL} - {$DEFINE COMPONENT_SET_LCL} -{$ENDIF} - -{$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)} -// If no component sets should be used just include empty unit. -//DOC-IGNORE-BEGIN -implementation -//DOC-IGNORE-END -{$ELSE} - -uses - SysUtils, Types, Classes, -{$IFDEF MSWINDOWS} - Windows, -{$ENDIF} -{$IFDEF COMPONENT_SET_VCL} - Graphics, -{$ENDIF} -{$IFDEF COMPONENT_SET_LCL} - InterfaceBase, - GraphType, - Graphics, - LCLType, - LCLIntf, -{$ENDIF} - ImagingTypes, Imaging, ImagingClasses; - -type - { Graphic class which uses Imaging to load images. - It has standard TBitmap class as ancestor and it can - Assign also to/from TImageData structres and TBaseImage - classes. For saving is uses inherited TBitmap methods. - This class is automatically registered to TPicture for all - file extensions supported by Imaging (useful only for loading). - If you just want to load images in various formats you can use this - class or simply use TPicture.LoadFromXXX which will create this class - automatically. For TGraphic class that saves with Imaging look - at TImagingGraphicForSave class.} - TImagingGraphic = class(TBitmap) - protected - procedure ReadDataFromStream(Stream: TStream); virtual; - procedure AssignTo(Dest: TPersistent); override; - public - constructor Create; override; - - { Loads new image from the stream. It can load all image - file formats supported by Imaging (and enabled of course) - even though it is called by descendant class capable of - saving only one file format.} - procedure LoadFromStream(Stream: TStream); override; - { Copies the image contained in Source to this graphic object. - Supports also TBaseImage descendants from ImagingClasses unit. } - procedure Assign(Source: TPersistent); override; - { Copies the image contained in TBaseImage to this graphic object.} - procedure AssignFromImage(Image: TBaseImage); - { Copies the current image to TBaseImage object.} - procedure AssignToImage(Image: TBaseImage); - { Copies the image contained in TImageData structure to this graphic object.} - procedure AssignFromImageData(const ImageData: TImageData); - { Copies the current image to TImageData structure.} - procedure AssignToImageData(var ImageData: TImageData); - end; - - TImagingGraphicClass = class of TImagingGraphic; - - { Base class for file format specific TGraphic classes that use - Imaging for saving. Each descendant class can load all file formats - supported by Imaging but save only one format (TImagingBitmap - for *.bmp, TImagingJpeg for *.jpg). Format specific classes also - allow easy access to Imaging options that affect saving of files - (they are properties here).} - TImagingGraphicForSave = class(TImagingGraphic) - protected - FDefaultFileExt: string; - FSavingFormat: TImageFormat; - procedure WriteDataToStream(Stream: TStream); virtual; - public - constructor Create; override; - { Saves the current image to the stream. It is saved in the - file format according to the DefaultFileExt property. - So each descendant class can save some other file format.} - procedure SaveToStream(Stream: TStream); override; - { Returns TImageFileFormat descendant for this graphic class.} - class function GetFileFormat: TImageFileFormat; virtual; abstract; - {$IFDEF COMPONENT_SET_LCL} - { Returns file extensions of this graphic class.} - class function GetFileExtensions: string; override; - { Returns default MIME type of this graphic class.} - function GetMimeType: string; override; - {$ENDIF} - { Default (the most common) file extension of this graphic class.} - property DefaultFileExt: string read FDefaultFileExt; - end; - - TImagingGraphicForSaveClass = class of TImagingGraphicForSave; - -{$IFNDEF DONT_LINK_BITMAP} - { TImagingGraphic descendant for loading/saving Windows bitmaps. - VCL/CLX/LCL all have native support for bitmaps so you might - want to disable this class (although you can save bitmaps with - RLE compression with this class).} - TImagingBitmap = class(TImagingGraphicForSave) - protected - FUseRLE: Boolean; - public - constructor Create; override; - procedure SaveToStream(Stream: TStream); override; - class function GetFileFormat: TImageFileFormat; override; - { See ImagingBitmapRLE option for details.} - property UseRLE: Boolean read FUseRLE write FUseRLE; - end; -{$ENDIF} - -{$IFNDEF DONT_LINK_JPEG} - { TImagingGraphic descendant for loading/saving JPEG images.} - TImagingJpeg = class(TImagingGraphicForSave) - protected - FQuality: LongInt; - FProgressive: Boolean; - public - constructor Create; override; - procedure SaveToStream(Stream: TStream); override; - class function GetFileFormat: TImageFileFormat; override; - {$IFDEF COMPONENT_SET_LCL} - function GetMimeType: string; override; - {$ENDIF} - { See ImagingJpegQuality option for details.} - property Quality: LongInt read FQuality write FQuality; - { See ImagingJpegProgressive option for details.} - property Progressive: Boolean read FProgressive write FProgressive; - end; -{$ENDIF} - -{$IFNDEF DONT_LINK_PNG} - { TImagingGraphic descendant for loading/saving PNG images.} - TImagingPNG = class(TImagingGraphicForSave) - protected - FPreFilter: LongInt; - FCompressLevel: LongInt; - public - constructor Create; override; - procedure SaveToStream(Stream: TStream); override; - class function GetFileFormat: TImageFileFormat; override; - { See ImagingPNGPreFilter option for details.} - property PreFilter: LongInt read FPreFilter write FPreFilter; - { See ImagingPNGCompressLevel option for details.} - property CompressLevel: LongInt read FCompressLevel write FCompressLevel; - end; -{$ENDIF} - -{$IFNDEF DONT_LINK_GIF} - { TImagingGraphic descendant for loading/saving GIF images.} - TImagingGIF = class(TImagingGraphicForSave) - public - class function GetFileFormat: TImageFileFormat; override; - end; -{$ENDIF} - -{$IFNDEF DONT_LINK_TARGA} - { TImagingGraphic descendant for loading/saving Targa images.} - TImagingTarga = class(TImagingGraphicForSave) - protected - FUseRLE: Boolean; - public - constructor Create; override; - procedure SaveToStream(Stream: TStream); override; - class function GetFileFormat: TImageFileFormat; override; - { See ImagingTargaRLE option for details.} - property UseRLE: Boolean read FUseRLE write FUseRLE; - end; -{$ENDIF} - -{$IFNDEF DONT_LINK_DDS} - { Compresssion type used when saving DDS files by TImagingDds.} - TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5); - - { TImagingGraphic descendant for loading/saving DDS images.} - TImagingDDS = class(TImagingGraphicForSave) - protected - FCompression: TDDSCompresion; - public - constructor Create; override; - procedure SaveToStream(Stream: TStream); override; - class function GetFileFormat: TImageFileFormat; override; - { You can choose compression type used when saving DDS file. - dcNone means that file will be saved in the current bitmaps pixel format.} - property Compression: TDDSCompresion read FCompression write FCompression; - end; -{$ENDIF} - -{$IFNDEF DONT_LINK_MNG} - { TImagingGraphic descendant for loading/saving MNG images.} - TImagingMNG = class(TImagingGraphicForSave) - protected - FLossyCompression: Boolean; - FLossyAlpha: Boolean; - FPreFilter: LongInt; - FCompressLevel: LongInt; - FQuality: LongInt; - FProgressive: Boolean; - public - constructor Create; override; - procedure SaveToStream(Stream: TStream); override; - class function GetFileFormat: TImageFileFormat; override; - {$IFDEF COMPONENT_SET_LCL} - function GetMimeType: string; override; - {$ENDIF} - { See ImagingMNGLossyCompression option for details.} - property LossyCompression: Boolean read FLossyCompression write FLossyCompression; - { See ImagingMNGLossyAlpha option for details.} - property LossyAlpha: Boolean read FLossyAlpha write FLossyAlpha; - { See ImagingMNGPreFilter option for details.} - property PreFilter: LongInt read FPreFilter write FPreFilter; - { See ImagingMNGCompressLevel option for details.} - property CompressLevel: LongInt read FCompressLevel write FCompressLevel; - { See ImagingMNGQuality option for details.} - property Quality: LongInt read FQuality write FQuality; - { See ImagingMNGProgressive option for details.} - property Progressive: Boolean read FProgressive write FProgressive; - end; -{$ENDIF} - -{$IFNDEF DONT_LINK_JNG} - { TImagingGraphic descendant for loading/saving JNG images.} - TImagingJNG = class(TImagingGraphicForSave) - protected - FLossyAlpha: Boolean; - FAlphaPreFilter: LongInt; - FAlphaCompressLevel: LongInt; - FQuality: LongInt; - FProgressive: Boolean; - public - constructor Create; override; - procedure SaveToStream(Stream: TStream); override; - class function GetFileFormat: TImageFileFormat; override; - { See ImagingJNGLossyAlpha option for details.} - property LossyAlpha: Boolean read FLossyAlpha write FLossyAlpha; - { See ImagingJNGPreFilter option for details.} - property AlphaPreFilter: LongInt read FAlphaPreFilter write FAlphaPreFilter; - { See ImagingJNGCompressLevel option for details.} - property AlphaCompressLevel: LongInt read FAlphaCompressLevel write FAlphaCompressLevel; - { See ImagingJNGQuality option for details.} - property Quality: LongInt read FQuality write FQuality; - { See ImagingJNGProgressive option for details.} - property Progressive: Boolean read FProgressive write FProgressive; - end; -{$ENDIF} - -{ Returns bitmap pixel format with the closest match with given data format.} -function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat; -{ Returns data format with closest match with given bitmap pixel format.} -function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat; - -{ Converts TImageData structure to VCL/CLX/LCL bitmap.} -procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap); -{ Converts VCL/CLX/LCL bitmap to TImageData structure.} -procedure ConvertBitmapToData(Bitmap: TBitmap; var Data: TImageData); -{ Converts TBaseImage instance to VCL/CLX/LCL bitmap.} -procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap); -{ Converts VCL/CLX/LCL bitmap to TBaseImage. Image must exist before - procedure is called. It overwrites its current image data. - When Image is TMultiImage only the current image level is overwritten.} -procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage); - -{ Displays image stored in TImageData structure onto TCanvas. This procedure - draws image without converting from Imaging format to TBitmap. - Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this - when you want displaying images that change frequently (because converting to - TBitmap by ConvertImageDataToBitmap is generally slow). Dest and Src - rectangles represent coordinates in the form (X1, Y1, X2, Y2).} -procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); -{ Displays image onto TCanvas at position [DstX, DstY]. This procedure - draws image without converting from Imaging format to TBitmap. - Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this - when you want displaying images that change frequently (because converting to - TBitmap by ConvertImageDataToBitmap is generally slow).} -procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage); overload; -{ Displays image onto TCanvas to rectangle DstRect. This procedure - draws image without converting from Imaging format to TBitmap. - Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this - when you want displaying images that change frequently (because converting to - TBitmap by ConvertImageDataToBitmap is generally slow).} -procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage); overload; -{ Displays part of the image specified by SrcRect onto TCanvas to rectangle DstRect. - This procedure draws image without converting from Imaging format to TBitmap. - Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this - when you want displaying images that change frequently (because converting to - TBitmap by ConvertImageDataToBitmap is generally slow).} -procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage; const SrcRect: TRect); overload; - -{$IFDEF MSWINDOWS} -{ Displays image stored in TImageData structure onto Windows device context. - Behaviour is the same as of DisplayImageData.} -procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); -{$ENDIF} - -implementation - -uses -{$IF Defined(LCL)} - {$IF Defined(LCLGTK2)} - GLib2, GDK2, GTK2, Gtk2Def, Gtk2Proc, - {$ELSEIF Defined(LCLGTK)} - GDK, GTK, GTKDef, GTKProc, - {$IFEND} -{$IFEND} -{$IFNDEF DONT_LINK_BITMAP} - ImagingBitmap, -{$ENDIF} -{$IFNDEF DONT_LINK_JPEG} - ImagingJpeg, -{$ENDIF} -{$IFNDEF DONT_LINK_GIF} - ImagingGif, -{$ENDIF} -{$IFNDEF DONT_LINK_TARGA} - ImagingTarga, -{$ENDIF} -{$IFNDEF DONT_LINK_DDS} - ImagingDds, -{$ENDIF} -{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)} - ImagingNetworkGraphics, -{$IFEND} - ImagingUtility; - -resourcestring - SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s'; - SBadFormatBitmapToData = 'Cannot find compatible data format for bitmap %p'; - SBadFormatDisplay = 'Unsupported image format passed'; - SUnsupportedLCLWidgetSet = 'This function is not implemented for current LCL widget set'; - SImagingGraphicName = 'Imaging Graphic AllInOne'; - -{ Registers types to VCL/LCL.} -procedure RegisterTypes; -var - I: LongInt; - - procedure RegisterFileFormatAllInOne(Format: TImageFileFormat); - var - I: LongInt; - begin - for I := 0 to Format.Extensions.Count - 1 do - TPicture.RegisterFileFormat(Format.Extensions[I], SImagingGraphicName, - TImagingGraphic); - end; - - procedure RegisterFileFormat(AClass: TImagingGraphicForSaveClass); - var - I: LongInt; - begin - for I := 0 to AClass.GetFileFormat.Extensions.Count - 1 do - TPicture.RegisterFileFormat(AClass.GetFileFormat.Extensions[I], - AClass.GetFileFormat.Name, AClass); - end; - -begin - for I := Imaging.GetFileFormatCount - 1 downto 0 do - RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I)); - Classes.RegisterClass(TImagingGraphic); - -{$IFNDEF DONT_LINK_TARGA} - RegisterFileFormat(TImagingTarga); - Classes.RegisterClass(TImagingTarga); -{$ENDIF} -{$IFNDEF DONT_LINK_DDS} - RegisterFileFormat(TImagingDDS); - Classes.RegisterClass(TImagingDDS); -{$ENDIF} -{$IFNDEF DONT_LINK_JNG} - RegisterFileFormat(TImagingJNG); - Classes.RegisterClass(TImagingJNG); -{$ENDIF} -{$IFNDEF DONT_LINK_MNG} - RegisterFileFormat(TImagingMNG); - Classes.RegisterClass(TImagingMNG); -{$ENDIF} -{$IFNDEF DONT_LINK_GIF} - RegisterFileFormat(TImagingGIF); - Classes.RegisterClass(TImagingGIF); -{$ENDIF} -{$IFNDEF DONT_LINK_PNG} - {$IFDEF COMPONENT_SET_LCL} - // Unregister Lazarus´ default PNG loader which crashes on some PNG files - TPicture.UnregisterGraphicClass(TPortableNetworkGraphic); - {$ENDIF} - RegisterFileFormat(TImagingPNG); - Classes.RegisterClass(TImagingPNG); -{$ENDIF} -{$IFNDEF DONT_LINK_JPEG} - RegisterFileFormat(TImagingJpeg); - Classes.RegisterClass(TImagingJpeg); -{$ENDIF} -{$IFNDEF DONT_LINK_BITMAP} - RegisterFileFormat(TImagingBitmap); - Classes.RegisterClass(TImagingBitmap); -{$ENDIF} -end; - -{ Unregisters types from VCL/LCL.} -procedure UnRegisterTypes; -begin -{$IFNDEF DONT_LINK_BITMAP} - TPicture.UnregisterGraphicClass(TImagingBitmap); - Classes.UnRegisterClass(TImagingBitmap); -{$ENDIF} -{$IFNDEF DONT_LINK_JPEG} - TPicture.UnregisterGraphicClass(TImagingJpeg); - Classes.UnRegisterClass(TImagingJpeg); -{$ENDIF} -{$IFNDEF DONT_LINK_PNG} - TPicture.UnregisterGraphicClass(TImagingPNG); - Classes.UnRegisterClass(TImagingPNG); -{$ENDIF} -{$IFNDEF DONT_LINK_GIF} - TPicture.UnregisterGraphicClass(TImagingGIF); - Classes.UnRegisterClass(TImagingGIF); -{$ENDIF} -{$IFNDEF DONT_LINK_TARGA} - TPicture.UnregisterGraphicClass(TImagingTarga); - Classes.UnRegisterClass(TImagingTarga); -{$ENDIF} -{$IFNDEF DONT_LINK_DDS} - TPicture.UnregisterGraphicClass(TImagingDDS); - Classes.UnRegisterClass(TImagingDDS); -{$ENDIF} - TPicture.UnregisterGraphicClass(TImagingGraphic); - Classes.UnRegisterClass(TImagingGraphic); -end; - -function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat; -begin - case Format of -{$IFDEF COMPONENT_SET_VCL} - ifIndex8: Result := pf8bit; - ifR5G6B5: Result := pf16bit; - ifR8G8B8: Result := pf24bit; -{$ENDIF} - ifA8R8G8B8, - ifX8R8G8B8: Result := pf32bit; - else - Result := pfCustom; - end; -end; - -function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat; -begin - case Format of - pf8bit: Result := ifIndex8; - pf15bit: Result := ifA1R5G5B5; - pf16bit: Result := ifR5G6B5; - pf24bit: Result := ifR8G8B8; - pf32bit: Result := ifA8R8G8B8; - else - Result := ifUnknown; - end; -end; - -procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap); -var - I, LineBytes: LongInt; - PF: TPixelFormat; - Info: TImageFormatInfo; - WorkData: TImageData; -{$IFDEF COMPONENT_SET_VCL} - LogPalette: TMaxLogPalette; -{$ENDIF} -{$IFDEF COMPONENT_SET_LCL} - RawImage: TRawImage; - ImgHandle, ImgMaskHandle: HBitmap; -{$ENDIF} -begin - PF := DataFormatToPixelFormat(Data.Format); - GetImageFormatInfo(Data.Format, Info); - if PF = pfCustom then - begin - // Convert from formats not supported by Graphics unit - Imaging.InitImage(WorkData); - Imaging.CloneImage(Data, WorkData); - if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then - Imaging.ConvertImage(WorkData, ifA8R8G8B8) - else -{$IFDEF COMPONENT_SET_VCL} - if Info.IsIndexed or Info.HasGrayChannel then - Imaging.ConvertImage(WorkData, ifIndex8) - else if Info.UsePixelFormat then - Imaging.ConvertImage(WorkData, ifR5G6B5) - else - Imaging.ConvertImage(WorkData, ifR8G8B8); -{$ELSE} - Imaging.ConvertImage(WorkData, ifA8R8G8B8); -{$ENDIF} - - PF := DataFormatToPixelFormat(WorkData.Format); - GetImageFormatInfo(WorkData.Format, Info); - end - else - WorkData := Data; - - if PF = pfCustom then - RaiseImaging(SBadFormatDataToBitmap, [ImageToStr(WorkData)]); - - LineBytes := WorkData.Width * Info.BytesPerPixel; - -{$IFDEF COMPONENT_SET_VCL} - Bitmap.Width := WorkData.Width; - Bitmap.Height := WorkData.Height; - Bitmap.PixelFormat := PF; - - if (PF = pf8bit) and (WorkData.Palette <> nil) then - begin - // Copy palette, this must be done before copying bits - FillChar(LogPalette, SizeOf(LogPalette), 0); - LogPalette.palVersion := $300; - LogPalette.palNumEntries := Info.PaletteEntries; - for I := 0 to Info.PaletteEntries - 1 do - with LogPalette do - begin - palPalEntry[I].peRed := WorkData.Palette[I].R; - palPalEntry[I].peGreen := WorkData.Palette[I].G; - palPalEntry[I].peBlue := WorkData.Palette[I].B; - end; - Bitmap.Palette := CreatePalette(PLogPalette(@LogPalette)^); - end; - // Copy scanlines - for I := 0 to WorkData.Height - 1 do - Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes); - - // Delphi 2009 and newer support alpha transparency fro TBitmap -{$IF Defined(DELPHI) and (CompilerVersion >= 20.0)} - if Bitmap.PixelFormat = pf32bit then - Bitmap.AlphaFormat := afDefined; -{$IFEND} - -{$ENDIF} -{$IFDEF COMPONENT_SET_LCL} - // Create 32bit raw image from image data - FillChar(RawImage, SizeOf(RawImage), 0); - with RawImage.Description do - begin - Width := WorkData.Width; - Height := WorkData.Height; - BitsPerPixel := 32; - Format := ricfRGBA; - LineEnd := rileDWordBoundary; - BitOrder := riboBitsInOrder; - ByteOrder := riboLSBFirst; - LineOrder := riloTopToBottom; - AlphaPrec := 8; - RedPrec := 8; - GreenPrec := 8; - BluePrec := 8; - AlphaShift := 24; - RedShift := 16; - GreenShift := 8; - BlueShift := 0; - Depth := 32; // Must be 32 for alpha blending (and for working in MacOSX Carbon) - end; - RawImage.Data := WorkData.Bits; - RawImage.DataSize := WorkData.Size; - - // Create bitmap from raw image - if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle) then - begin - Bitmap.Handle := ImgHandle; - Bitmap.MaskHandle := ImgMaskHandle; - end; -{$ENDIF} - if WorkData.Bits <> Data.Bits then - Imaging.FreeImage(WorkData); -end; - -procedure ConvertBitmapToData(Bitmap: TBitmap; var Data: TImageData); -var - I, LineBytes: LongInt; - Format: TImageFormat; - Info: TImageFormatInfo; -{$IFDEF COMPONENT_SET_VCL} - Colors: Word; - LogPalette: TMaxLogPalette; -{$ENDIF} -{$IFDEF COMPONENT_SET_LCL} - RawImage: TRawImage; - LineLazBytes: LongInt; -{$ENDIF} -begin -{$IFDEF COMPONENT_SET_LCL} - // In the current Lazarus 0.9.10 Bitmap.PixelFormat property is useless. - // We cannot change bitmap's format by changing it (it will just release - // old image but not convert it to new format) nor we can determine bitmaps's - // current format (it is usually set to pfDevice). So bitmap's format is obtained - // trough RawImage api and cannot be changed to mirror some Imaging format - // (so formats with no coresponding Imaging format cannot be saved now). - - if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then - case RawImage.Description.BitsPerPixel of - 8: Format := ifIndex8; - 16: - if RawImage.Description.Depth = 15 then - Format := ifA1R5G5B5 - else - Format := ifR5G6B5; - 24: Format := ifR8G8B8; - 32: Format := ifA8R8G8B8; - 48: Format := ifR16G16B16; - 64: Format := ifA16R16G16B16; - else - Format := ifUnknown; - end; -{$ELSE} - Format := PixelFormatToDataFormat(Bitmap.PixelFormat); - if Format = ifUnknown then - begin - // Convert from formats not supported by Imaging (1/4 bit) - if Bitmap.PixelFormat < pf8bit then - Bitmap.PixelFormat := pf8bit - else - Bitmap.PixelFormat := pf32bit; - Format := PixelFormatToDataFormat(Bitmap.PixelFormat); - end; -{$ENDIF} - - if Format = ifUnknown then - RaiseImaging(SBadFormatBitmapToData, []); - - Imaging.NewImage(Bitmap.Width, Bitmap.Height, Format, Data); - GetImageFormatInfo(Data.Format, Info); - LineBytes := Data.Width * Info.BytesPerPixel; - -{$IFDEF COMPONENT_SET_VCL} - if (Format = ifIndex8) and (GetObject(Bitmap.Palette, SizeOf(Colors), - @Colors) <> 0) then - begin - // Copy palette - GetPaletteEntries(Bitmap.Palette, 0, Colors, LogPalette.palPalEntry); - if Colors > Info.PaletteEntries then - Colors := Info.PaletteEntries; - for I := 0 to Colors - 1 do - with LogPalette do - begin - Data.Palette[I].A := $FF; - Data.Palette[I].R := palPalEntry[I].peRed; - Data.Palette[I].G := palPalEntry[I].peGreen; - Data.Palette[I].B := palPalEntry[I].peBlue; - end; - end; - // Copy scanlines - for I := 0 to Data.Height - 1 do - Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes); -{$ENDIF} -{$IFDEF COMPONENT_SET_LCL} - // Get raw image from bitmap (mask handle must be 0 or expect violations) - if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then - begin - LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel, - RawImage.Description.LineEnd); - // Copy scanlines - for I := 0 to Data.Height - 1 do - Move(PByteArray(RawImage.Data)[I * LineLazBytes], - PByteArray(Data.Bits)[I * LineBytes], LineBytes); - { If you get complitation error here upgrade to Lazarus 0.9.24+ } - RawImage.FreeData; - end; -{$ENDIF} -end; - -procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap); -begin - ConvertDataToBitmap(Image.ImageDataPointer^, Bitmap); -end; - -procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage); -begin - ConvertBitmapToData(Bitmap, Image.ImageDataPointer^); -end; - -{$IFDEF MSWINDOWS} -procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); -var - OldMode: Integer; - BitmapInfo: Windows.TBitmapInfo; - Bmp: TBitmap; -begin - if TestImage(ImageData) then - begin - Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay); - OldMode := Windows.SetStretchBltMode(DC, COLORONCOLOR); - - FillChar(BitmapInfo, SizeOf(BitmapInfo), 0); - with BitmapInfo.bmiHeader do - begin - biSize := SizeOf(TBitmapInfoHeader); - biPlanes := 1; - biBitCount := 32; - biCompression := BI_RGB; - biWidth := ImageData.Width; - biHeight := -ImageData.Height; - biSizeImage := ImageData.Size; - biXPelsPerMeter := 0; - biYPelsPerMeter := 0; - biClrUsed := 0; - biClrImportant := 0; - end; - - try - with SrcRect, ImageData do - if Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top, - DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left, - Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY) <> Height then - begin - // StretchDIBits may fail on some ocassions (error 487, http://support.microsoft.com/kb/269585). - // This fallback is slow but works every time. Thanks to Sergey Galezdinov for the fix. - Bmp := TBitmap.Create; - try - ConvertDataToBitmap(ImageData, Bmp); - StretchBlt(DC, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, - Bmp.Canvas.Handle, 0, 0, Width, Height, SRCCOPY); - finally - Bmp.Free; - end; - end; - finally - Windows.SetStretchBltMode(DC, OldMode); - end; - end; -end; -{$ENDIF} - -procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); -{$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32 -begin - DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect); -end; -{$ELSEIF Defined(LCLGTK) or Defined(LCLGTK2)} - - procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, - SrcWidth, SrcHeight: Integer; ImageData: TImageData); - var - P: TPoint; - begin - P := TGtkDeviceContext(Dest).Offset; - Inc(DstX, P.X); - Inc(DstY, P.Y); - gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC, - DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE, - @PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4); - end; - -var - DisplayImage: TImageData; - NewWidth, NewHeight: Integer; - SrcBounds, DstBounds, DstClip: TRect; -begin - if TestImage(ImageData) then - begin - Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay); - InitImage(DisplayImage); - - SrcBounds := RectToBounds(SrcRect); - DstBounds := RectToBounds(DstRect); - WidgetSet.GetClipBox(DstCanvas.Handle, @DstClip); - - ClipStretchBounds(SrcBounds.Left, SrcBounds.Top, SrcBounds.Right, SrcBounds.Bottom, - DstBounds.Left, DstBounds.Top, DstBounds.Right, DstBounds.Bottom, ImageData.Width, - ImageData.Height, DstClip); - - NewWidth := DstBounds.Right; - NewHeight := DstBounds.Bottom; - - if (NewWidth > 0) and (NewHeight > 0) then - begin - if (SrcBounds.Right = NewWidth) and (SrcBounds.Bottom = NewHeight) then - try - CloneImage(ImageData, DisplayImage); - // Swap R-B channels for GTK display compatability! - SwapChannels(DisplayImage, ChannelRed, ChannelBlue); - GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, - SrcBounds.Left, SrcBounds.Top, NewWidth, NewHeight, DisplayImage); - finally - FreeImage(DisplayImage); - end - else - try - // Create new image with desired dimensions - NewImage(NewWidth, NewHeight, ImageData.Format, DisplayImage); - // Stretch pixels from old image to new one TResizeFilter = (rfNearest, rfBilinear, rfBicubic); - StretchRect(ImageData, SrcBounds.Left, SrcBounds.Top, SrcBounds.Right, - SrcBounds.Bottom, DisplayImage, 0, 0, NewWidth, NewHeight, rfNearest); - // Swap R-B channels for GTK display compatability! - SwapChannels(DisplayImage, ChannelRed, ChannelBlue); - GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, 0, 0, - NewWidth, NewHeight, DisplayImage); - finally - FreeImage(DisplayImage); - end - end; - end; -end; -{$ELSE} -begin - raise Exception.Create(SUnsupportedLCLWidgetSet); -end; -{$IFEND} - -procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage); -begin - DisplayImageData(DstCanvas, BoundsToRect(DstX, DstY, Image.Width, Image.Height), - Image.ImageDataPointer^, Image.BoundsRect); -end; - -procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage); -begin - DisplayImageData(DstCanvas, DstRect, Image.ImageDataPointer^, Image.BoundsRect); -end; - -procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage; const SrcRect: TRect); -begin - DisplayImageData(DstCanvas, DstRect, Image.ImageDataPointer^, SrcRect); -end; - - -{ TImagingGraphic class implementation } - -constructor TImagingGraphic.Create; -begin - inherited Create; - PixelFormat := pf24Bit; -end; - -procedure TImagingGraphic.LoadFromStream(Stream: TStream); -begin - ReadDataFromStream(Stream); -end; - -procedure TImagingGraphic.ReadDataFromStream(Stream: TStream); -var - Image: TSingleImage; -begin - Image := TSingleImage.Create; - try - Image.LoadFromStream(Stream); - Assign(Image); - finally - Image.Free; - end; -end; - -procedure TImagingGraphic.AssignTo(Dest: TPersistent); -var - Arr: TDynImageDataArray; -begin - if Dest is TSingleImage then - begin - AssignToImage(TSingleImage(Dest)) - end - else if Dest is TMultiImage then - begin - SetLength(Arr, 1); - AssignToImageData(Arr[0]); - TMultiImage(Dest).CreateFromArray(Arr); - Imaging.FreeImagesInArray(Arr); - end - else - inherited AssignTo(Dest); -end; - -procedure TImagingGraphic.Assign(Source: TPersistent); -begin - if Source is TBaseImage then - AssignFromImage(TBaseImage(Source)) - else - inherited Assign(Source); -end; - -procedure TImagingGraphic.AssignFromImage(Image: TBaseImage); -begin - if (Image <> nil) and Image.Valid then - AssignFromImageData(Image.ImageDataPointer^); -end; - -procedure TImagingGraphic.AssignToImage(Image: TBaseImage); -begin - if (Image <> nil) and (Image.ImageDataPointer <> nil) then - AssignToImageData(Image.ImageDataPointer^); -end; - -procedure TImagingGraphic.AssignFromImageData(const ImageData: TImageData); -begin - if Imaging.TestImage(ImageData) then - ConvertDataToBitmap(ImageData, Self); -end; - -procedure TImagingGraphic.AssignToImageData(var ImageData: TImageData); -begin - Imaging.FreeImage(ImageData); - ConvertBitmapToData(Self, ImageData); -end; - - -{ TImagingGraphicForSave class implementation } - -constructor TImagingGraphicForSave.Create; -begin - inherited Create; - FDefaultFileExt := GetFileFormat.Extensions[0]; - FSavingFormat := ifUnknown; - GetFileFormat.CheckOptionsValidity; -end; - -procedure TImagingGraphicForSave.WriteDataToStream(Stream: TStream); -var - Image: TSingleImage; -begin - if FDefaultFileExt <> '' then - begin - Image := TSingleImage.Create; - try - Image.Assign(Self); - if FSavingFormat <> ifUnknown then - Image.Format := FSavingFormat; - Image.SaveToStream(FDefaultFileExt, Stream); - finally - Image.Free; - end; - end; -end; - -procedure TImagingGraphicForSave.SaveToStream(Stream: TStream); -begin - WriteDataToStream(Stream); -end; - -{$IFDEF COMPONENT_SET_LCL} -class function TImagingGraphicForSave.GetFileExtensions: string; -begin - Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]); -end; - -function TImagingGraphicForSave.GetMimeType: string; -begin - Result := 'image/' + FDefaultFileExt; -end; -{$ENDIF} - -{$IFNDEF DONT_LINK_BITMAP} - -{ TImagingBitmap class implementation } - -constructor TImagingBitmap.Create; -begin - inherited Create; - FUseRLE := (GetFileFormat as TBitmapFileFormat).UseRLE; -end; - -class function TImagingBitmap.GetFileFormat: TImageFileFormat; -begin - Result := FindImageFileFormatByClass(TBitmapFileFormat); -end; - -procedure TImagingBitmap.SaveToStream(Stream: TStream); -begin - Imaging.PushOptions; - Imaging.SetOption(ImagingBitmapRLE, Ord(FUseRLE)); - inherited SaveToStream(Stream); - Imaging.PopOptions; -end; -{$ENDIF} - -{$IFNDEF DONT_LINK_JPEG} - -{ TImagingJpeg class implementation } - -constructor TImagingJpeg.Create; -begin - inherited Create; - FQuality := (GetFileFormat as TJpegFileFormat).Quality; - FProgressive := (GetFileFormat as TJpegFileFormat).Progressive; -end; - -class function TImagingJpeg.GetFileFormat: TImageFileFormat; -begin - Result := FindImageFileFormatByClass(TJpegFileFormat); -end; - -{$IFDEF COMPONENT_SET_LCL} -function TImagingJpeg.GetMimeType: string; -begin - Result := 'image/jpeg'; -end; -{$ENDIF} - -procedure TImagingJpeg.SaveToStream(Stream: TStream); -begin - Imaging.PushOptions; - Imaging.SetOption(ImagingJpegQuality, FQuality); - Imaging.SetOption(ImagingJpegProgressive, Ord(FProgressive)); - inherited SaveToStream(Stream); - Imaging.PopOptions; -end; - -{$ENDIF} - -{$IFNDEF DONT_LINK_PNG} - -{ TImagingPNG class implementation } - -constructor TImagingPNG.Create; -begin - inherited Create; - FPreFilter := (GetFileFormat as TPNGFileFormat).PreFilter; - FCompressLevel := (GetFileFormat as TPNGFileFormat).CompressLevel; -end; - -class function TImagingPNG.GetFileFormat: TImageFileFormat; -begin - Result := FindImageFileFormatByClass(TPNGFileFormat); -end; - -procedure TImagingPNG.SaveToStream(Stream: TStream); -begin - Imaging.PushOptions; - Imaging.SetOption(ImagingPNGPreFilter, FPreFilter); - Imaging.SetOption(ImagingPNGCompressLevel, FCompressLevel); - inherited SaveToStream(Stream); - Imaging.PopOptions; -end; -{$ENDIF} - -{$IFNDEF DONT_LINK_GIF} - -{ TImagingGIF class implementation} - -class function TImagingGIF.GetFileFormat: TImageFileFormat; -begin - Result := FindImageFileFormatByClass(TGIFFileFormat); -end; - -{$ENDIF} - -{$IFNDEF DONT_LINK_TARGA} - -{ TImagingTarga class implementation } - -constructor TImagingTarga.Create; -begin - inherited Create; - FUseRLE := (GetFileFormat as TTargaFileFormat).UseRLE; -end; - -class function TImagingTarga.GetFileFormat: TImageFileFormat; -begin - Result := FindImageFileFormatByClass(TTargaFileFormat); -end; - -procedure TImagingTarga.SaveToStream(Stream: TStream); -begin - Imaging.PushOptions; - Imaging.SetOption(ImagingTargaRLE, Ord(FUseRLE)); - inherited SaveToStream(Stream); - Imaging.PopOptions; -end; -{$ENDIF} - -{$IFNDEF DONT_LINK_DDS} - -{ TImagingDDS class implementation } - -constructor TImagingDDS.Create; -begin - inherited Create; - FCompression := dcNone; -end; - -class function TImagingDDS.GetFileFormat: TImageFileFormat; -begin - Result := FindImageFileFormatByClass(TDDSFileFormat); -end; - -procedure TImagingDDS.SaveToStream(Stream: TStream); -begin - case FCompression of - dcNone: FSavingFormat := ifUnknown; - dcDXT1: FSavingFormat := ifDXT1; - dcDXT3: FSavingFormat := ifDXT3; - dcDXT5: FSavingFormat := ifDXT5; - end; - Imaging.PushOptions; - Imaging.SetOption(ImagingDDSSaveCubeMap, Ord(False)); - Imaging.SetOption(ImagingDDSSaveVolume, Ord(False)); - Imaging.SetOption(ImagingDDSSaveMipMapCount, 1); - Imaging.SetOption(ImagingDDSSaveDepth, 1); - inherited SaveToStream(Stream); - Imaging.PopOptions; -end; -{$ENDIF} - -{$IFNDEF DONT_LINK_MNG} - -{ TImagingMNG class implementation } - -constructor TImagingMNG.Create; -begin - inherited Create; - FLossyCompression := (GetFileFormat as TMNGFileFormat).LossyCompression; - FLossyAlpha := (GetFileFormat as TMNGFileFormat).LossyAlpha; - FPreFilter := (GetFileFormat as TMNGFileFormat).PreFilter; - FCompressLevel := (GetFileFormat as TMNGFileFormat).CompressLevel; - FQuality := (GetFileFormat as TMNGFileFormat).Quality; - FProgressive := (GetFileFormat as TMNGFileFormat).Progressive; -end; - -class function TImagingMNG.GetFileFormat: TImageFileFormat; -begin - Result := FindImageFileFormatByClass(TMNGFileFormat); -end; - -{$IFDEF COMPONENT_SET_LCL} -function TImagingMNG.GetMimeType: string; -begin - Result := 'video/mng'; -end; -{$ENDIF} - -procedure TImagingMNG.SaveToStream(Stream: TStream); -begin - Imaging.PushOptions; - Imaging.SetOption(ImagingMNGLossyCompression, Ord(FLossyCompression)); - Imaging.SetOption(ImagingMNGLossyAlpha, Ord(FLossyAlpha)); - Imaging.SetOption(ImagingMNGPreFilter, FPreFilter); - Imaging.SetOption(ImagingMNGCompressLevel, FCompressLevel); - Imaging.SetOption(ImagingMNGQuality, FQuality); - Imaging.SetOption(ImagingMNGProgressive, Ord(FProgressive)); - inherited SaveToStream(Stream); - Imaging.PopOptions; -end; -{$ENDIF} - -{$IFNDEF DONT_LINK_JNG} - -{ TImagingJNG class implementation } - -constructor TImagingJNG.Create; -begin - inherited Create; - FLossyAlpha := (GetFileFormat as TJNGFileFormat).LossyAlpha; - FAlphaPreFilter := (GetFileFormat as TJNGFileFormat).PreFilter; - FAlphaCompressLevel := (GetFileFormat as TJNGFileFormat).CompressLevel; - FQuality := (GetFileFormat as TJNGFileFormat).Quality; - FProgressive := (GetFileFormat as TJNGFileFormat).Progressive; -end; - -class function TImagingJNG.GetFileFormat: TImageFileFormat; -begin - Result := FindImageFileFormatByClass(TJNGFileFormat); -end; - -procedure TImagingJNG.SaveToStream(Stream: TStream); -begin - Imaging.PushOptions; - Imaging.SetOption(ImagingJNGLossyALpha, Ord(FLossyAlpha)); - Imaging.SetOption(ImagingJNGAlphaPreFilter, FAlphaPreFilter); - Imaging.SetOption(ImagingJNGAlphaCompressLevel, FAlphaCompressLevel); - Imaging.SetOption(ImagingJNGQuality, FQuality); - Imaging.SetOption(ImagingJNGProgressive, Ord(FProgressive)); - inherited SaveToStream(Stream); - Imaging.PopOptions; -end; -{$ENDIF} - -initialization - RegisterTypes; -finalization - UnRegisterTypes; - -{$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)} - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.26.3 Changes/Bug Fixes --------------------------------- - - Setting AlphaFormat property of TBitmap in ConvertDataToBitmap - when using Delphi 2009+. - - Fixed garbled LCL TBitmaps created by ConvertDataToBitmap - in Mac OS X (Carbon). - - -- 0.26.1 Changes/Bug Fixes --------------------------------- - - Added some more IFDEFs for Lazarus widget sets. - - Removed CLX code. - - GTK version of Unix DisplayImageData only used with LCL GTK so the - the rest of the unit can be used with Qt or other LCL interfaces. - - Fallback mechanism for DisplayImageDataOnDC, it may fail on occasions. - - Changed file format conditional compilation to reflect changes - in LINK symbols. - - Lazarus 0.9.26 compatibility changes. - - -- 0.24.1 Changes/Bug Fixes --------------------------------- - - Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus - with GTK2 target. - - Added commnets with code for Lazarus rev. 11861+ regarding - RawImage interface. Replace current code with that in comments - if you use Lazarus from SVN. New RawImage interface will be used by - default after next Lazarus release. - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Added TImagingGIF. - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Uses only high level interface now (except for saving options). - - Slightly changed class hierarchy. TImagingGraphic is now only for loading - and base class for savers is new TImagingGraphicForSave. Also - TImagingGraphic is now registered with all supported file formats - by TPicture's format support. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - added DisplayImage procedures (thanks to Paul Michell, modified) - - removed RegisterTypes and UnRegisterTypes from interface section, - they are called automatically - - added procedures: ConvertImageToBitmap and ConvertBitmapToImage - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - LCL data to bitmap conversion didn´t work in Linux, fixed - - added MNG file format - - added JNG file format - - -- 0.15 Changes/Bug Fixes ----------------------------------- - - made it LCL compatible - - made it CLX compatible - - added all initial stuff -} - -end. - +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains VCL/LCL TGraphic descendant which uses Imaging library + for saving and loading.} +unit ImagingComponents; + +{$I ImagingOptions.inc} + +interface + +{$IF Defined(FPC) and Defined(LCL)} + {$DEFINE COMPONENT_SET_LCL} +{$ELSEIF Defined(DELPHI)} + {$DEFINE COMPONENT_SET_VCL} +{$IFEND} + +{$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)} +// If no component sets should be used just include empty unit. +implementation +{$ELSE} + +uses +{$IFDEF MSWINDOWS} + Windows, +{$ENDIF} + SysUtils, Types, Classes, +{$IFDEF COMPONENT_SET_VCL} + Graphics, +{$ENDIF} +{$IFDEF COMPONENT_SET_LCL} + GraphType, + Graphics, + LCLType, + LCLIntf, +{$ENDIF} + ImagingTypes, Imaging, ImagingClasses; + +type + { Graphic class which uses Imaging to load images. + It has standard TBitmap class as ancestor and it can + Assign also to/from TImageData structures and TBaseImage + classes. If you want to perfectly preserve the original pixel format + of the source image then these classes may not for you. + + This class is automatically registered to TPicture for all + file extensions supported by Imaging (useful only for loading). + If you just want to load images in various formats you can use this + class or simply use TPicture.LoadFromXXX which will create this class + automatically. + + For saving it always uses PNG fallback. + For TGraphic classes that save in different formats look + at TImagingGraphicForSave class.} + TImagingGraphic = class(TBitmap) + protected + procedure AssignTo(Dest: TPersistent); override; + { Called by TFiler when reading and writing TPicture.Data property. + We need to override ReadData+WriteData otherwise inherited ones from + TBitmap would be called resulting in errors.} + procedure ReadData(Stream: TStream); override; + procedure WriteData(Stream: TStream); override; + public + constructor Create; override; + + { Loads new image from the stream. It can load all image + file formats supported by Imaging (and enabled of course) + even though it is called by descendant class capable of + saving only one file format.} + procedure LoadFromStream(Stream: TStream); override; + { Always saves as PNG.} + procedure SaveToStream(Stream: TStream); override; + { Copies the image contained in Source to this graphic object. + Supports also TBaseImage descendants from ImagingClasses unit. } + procedure Assign(Source: TPersistent); override; + { Copies the image contained in TBaseImage to this graphic object.} + procedure AssignFromImage(Image: TBaseImage); + { Copies the current image to TBaseImage object.} + procedure AssignToImage(Image: TBaseImage); + { Copies the image contained in TImageData structure to this graphic object.} + procedure AssignFromImageData(const ImageData: TImageData); + { Copies the current image to TImageData structure.} + procedure AssignToImageData(var ImageData: TImageData); + + {$IFDEF COMPONENT_SET_LCL} + { Needed for TGraphic.LoadFromResourceName() to work. + We return RT_RCDATA here. Also for TImagingBitmap since + RT_BITMAP is stored differently than bitmap on disk (no BITMAPFILEHEADER).} + function GetResourceType: TResourceType; override; + { Used by TPicture.LoadFromStream to find the right TGraphic class for streams. } + class function IsStreamFormatSupported(Stream: TStream): boolean; override; + {$ENDIF} + end; + + TImagingGraphicClass = class of TImagingGraphic; + + { Base (abstract) class for file format specific TGraphic classes that use + Imaging for saving. Each descendant class can load all file formats + supported by Imaging but save only one format (TImagingBitmap + for *.bmp, TImagingJpeg for *.jpg). The image is saved in this one file + format regardless of the extension you request). + + Format specific classes also allow easy access to Imaging options that + affect saving of files (they are properties here).} + TImagingGraphicForSave = class(TImagingGraphic) + protected + FDefaultFileExt: string; + FSavingFormat: TImageFormat; + procedure WriteData(Stream: TStream); override; + public + constructor Create; override; + { Saves the current image to the stream. It is saved in the + file format according to the DefaultFileExt property. + So each descendant class can save some other file format.} + procedure SaveToStream(Stream: TStream); override; + { Returns TImageFileFormat descendant for this graphic class.} + class function GetFileFormat: TImageFileFormat; virtual; abstract; + {$IFDEF COMPONENT_SET_LCL} + { Returns file extensions of this graphic class.} + class function GetFileExtensions: string; override; + { Returns default MIME type of this graphic class.} + function GetMimeType: string; override; + {$ENDIF} + { Default (the most common) file extension of this graphic class.} + property DefaultFileExt: string read FDefaultFileExt; + end; + + TImagingGraphicForSaveClass = class of TImagingGraphicForSave; + +{$IFNDEF DONT_LINK_BITMAP} + { TImagingGraphic descendant for loading/saving Windows bitmaps. + VCL/LCL both have native support for bitmaps so you might + want to disable this class (although you can save bitmaps with + RLE compression with this class).} + TImagingBitmap = class(TImagingGraphicForSave) + protected + FUseRLE: Boolean; + public + constructor Create; override; + procedure SaveToStream(Stream: TStream); override; + class function GetFileFormat: TImageFileFormat; override; + { See ImagingBitmapRLE option for details.} + property UseRLE: Boolean read FUseRLE write FUseRLE; + end; +{$ENDIF} + +{$IFNDEF DONT_LINK_JPEG} + { TImagingGraphic descendant for loading/saving JPEG images.} + TImagingJpeg = class(TImagingGraphicForSave) + protected + FQuality: LongInt; + FProgressive: Boolean; + public + constructor Create; override; + procedure SaveToStream(Stream: TStream); override; + class function GetFileFormat: TImageFileFormat; override; + {$IFDEF COMPONENT_SET_LCL} + function GetMimeType: string; override; + {$ENDIF} + { See ImagingJpegQuality option for details.} + property Quality: LongInt read FQuality write FQuality; + { See ImagingJpegProgressive option for details.} + property Progressive: Boolean read FProgressive write FProgressive; + end; +{$ENDIF} + +{$IFNDEF DONT_LINK_PNG} + { TImagingGraphic descendant for loading/saving PNG images.} + TImagingPNG = class(TImagingGraphicForSave) + protected + FPreFilter: LongInt; + FCompressLevel: LongInt; + public + constructor Create; override; + procedure SaveToStream(Stream: TStream); override; + class function GetFileFormat: TImageFileFormat; override; + { See ImagingPNGPreFilter option for details.} + property PreFilter: LongInt read FPreFilter write FPreFilter; + { See ImagingPNGCompressLevel option for details.} + property CompressLevel: LongInt read FCompressLevel write FCompressLevel; + end; +{$ENDIF} + +{$IFNDEF DONT_LINK_GIF} + { TImagingGraphic descendant for loading/saving GIF images.} + TImagingGIF = class(TImagingGraphicForSave) + public + class function GetFileFormat: TImageFileFormat; override; + end; +{$ENDIF} + +{$IFNDEF DONT_LINK_TARGA} + { TImagingGraphic descendant for loading/saving Targa images.} + TImagingTarga = class(TImagingGraphicForSave) + protected + FUseRLE: Boolean; + public + constructor Create; override; + procedure SaveToStream(Stream: TStream); override; + class function GetFileFormat: TImageFileFormat; override; + { See ImagingTargaRLE option for details.} + property UseRLE: Boolean read FUseRLE write FUseRLE; + end; +{$ENDIF} + +{$IFNDEF DONT_LINK_DDS} + { Compression type used when saving DDS files by TImagingDds.} + TDDSCompression = (dcNone, dcDXT1, dcDXT3, dcDXT5); + + { TImagingGraphic descendant for loading/saving DDS images.} + TImagingDDS = class(TImagingGraphicForSave) + protected + FCompression: TDDSCompression; + public + constructor Create; override; + procedure SaveToStream(Stream: TStream); override; + class function GetFileFormat: TImageFileFormat; override; + { You can choose compression type used when saving DDS file. + dcNone means that file will be saved in the current bitmaps pixel format.} + property Compression: TDDSCompression read FCompression write FCompression; + end; +{$ENDIF} + +{$IFNDEF DONT_LINK_MNG} + { TImagingGraphic descendant for loading/saving MNG images.} + TImagingMNG = class(TImagingGraphicForSave) + protected + FLossyCompression: Boolean; + FLossyAlpha: Boolean; + FPreFilter: LongInt; + FCompressLevel: LongInt; + FQuality: LongInt; + FProgressive: Boolean; + public + constructor Create; override; + procedure SaveToStream(Stream: TStream); override; + class function GetFileFormat: TImageFileFormat; override; + {$IFDEF COMPONENT_SET_LCL} + function GetMimeType: string; override; + {$ENDIF} + { See ImagingMNGLossyCompression option for details.} + property LossyCompression: Boolean read FLossyCompression write FLossyCompression; + { See ImagingMNGLossyAlpha option for details.} + property LossyAlpha: Boolean read FLossyAlpha write FLossyAlpha; + { See ImagingMNGPreFilter option for details.} + property PreFilter: LongInt read FPreFilter write FPreFilter; + { See ImagingMNGCompressLevel option for details.} + property CompressLevel: LongInt read FCompressLevel write FCompressLevel; + { See ImagingMNGQuality option for details.} + property Quality: LongInt read FQuality write FQuality; + { See ImagingMNGProgressive option for details.} + property Progressive: Boolean read FProgressive write FProgressive; + end; +{$ENDIF} + +{$IFNDEF DONT_LINK_JNG} + { TImagingGraphic descendant for loading/saving JNG images.} + TImagingJNG = class(TImagingGraphicForSave) + protected + FLossyAlpha: Boolean; + FAlphaPreFilter: LongInt; + FAlphaCompressLevel: LongInt; + FQuality: LongInt; + FProgressive: Boolean; + public + constructor Create; override; + procedure SaveToStream(Stream: TStream); override; + class function GetFileFormat: TImageFileFormat; override; + { See ImagingJNGLossyAlpha option for details.} + property LossyAlpha: Boolean read FLossyAlpha write FLossyAlpha; + { See ImagingJNGPreFilter option for details.} + property AlphaPreFilter: LongInt read FAlphaPreFilter write FAlphaPreFilter; + { See ImagingJNGCompressLevel option for details.} + property AlphaCompressLevel: LongInt read FAlphaCompressLevel write FAlphaCompressLevel; + { See ImagingJNGQuality option for details.} + property Quality: LongInt read FQuality write FQuality; + { See ImagingJNGProgressive option for details.} + property Progressive: Boolean read FProgressive write FProgressive; + end; +{$ENDIF} + +{ Returns bitmap pixel format with the closest match with given data format.} +function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat; +{ Returns data format with closest match with given bitmap pixel format.} +function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat; + +{ Converts TImageData structure to VCL/CLX/LCL bitmap.} +procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap); +{ Converts VCL/CLX/LCL bitmap to TImageData structure.} +procedure ConvertBitmapToData(Bitmap: TBitmap; var Data: TImageData); +{ Converts TBaseImage instance to VCL/CLX/LCL bitmap.} +procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap); +{ Converts VCL/CLX/LCL bitmap to TBaseImage. Image must exist before + procedure is called. It overwrites its current image data. + When Image is TMultiImage only the current image level is overwritten.} +procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage); + +{ Displays image onto TCanvas to rectangle DstRect. This procedure + draws image without converting from Imaging format to TBitmap. + Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this + when you want displaying images that change frequently (because converting to + TBitmap by ConvertImageDataToBitmap is generally slow).} +procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData); overload; +{ Displays image stored in TImageData structure onto TCanvas. This procedure + draws image without converting from Imaging format to TBitmap. + Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this + when you want displaying images that change frequently (because converting to + TBitmap by ConvertImageDataToBitmap is generally slow). Dest and Src + rectangles represent coordinates in the form (X1, Y1, X2, Y2).} +procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); overload; +{ Displays image onto TCanvas at position [DstX, DstY]. This procedure + draws image without converting from Imaging format to TBitmap. + Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this + when you want displaying images that change frequently (because converting to + TBitmap by ConvertImageDataToBitmap is generally slow).} +procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage); overload; +{ Displays image onto TCanvas to rectangle DstRect. This procedure + draws image without converting from Imaging format to TBitmap. + Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this + when you want displaying images that change frequently (because converting to + TBitmap by ConvertImageDataToBitmap is generally slow).} +procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage); overload; +{ Displays part of the image specified by SrcRect onto TCanvas to rectangle DstRect. + This procedure draws image without converting from Imaging format to TBitmap. + Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this + when you want displaying images that change frequently (because converting to + TBitmap by ConvertImageDataToBitmap is generally slow).} +procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage; const SrcRect: TRect); overload; + +{$IFDEF MSWINDOWS} +{ Displays image stored in TImageData structure onto Windows device context. + Behaviour is the same as of DisplayImageData.} +procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); +{$ENDIF} + +procedure RegisterTypes; + +implementation + +uses +{$IF Defined(LCL)} + InterfaceBase, + {$IF Defined(LCLGTK2)} + GLib2, GDK2, GTK2, GTK2Def, GTK2Proc, + {$ELSEIF Defined(LCLqt5)} + Qt5, qtobjects, + {$ELSEIF Defined(LCLcocoa)} + CocoaGDIObjects, CocoaUtils, + {$IFEND} +{$IFEND} +{$IFNDEF DONT_LINK_BITMAP} + ImagingBitmap, +{$ENDIF} +{$IFNDEF DONT_LINK_JPEG} + ImagingJpeg, +{$ENDIF} +{$IFNDEF DONT_LINK_GIF} + ImagingGif, +{$ENDIF} +{$IFNDEF DONT_LINK_TARGA} + ImagingTarga, +{$ENDIF} +{$IFNDEF DONT_LINK_DDS} + ImagingDds, +{$ENDIF} +{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)} + ImagingNetworkGraphics, +{$IFEND} + ImagingFormats, ImagingUtility; + +resourcestring + SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s'; + SBadFormatBitmapToData = 'Cannot find compatible data format for bitmap %p'; + SBadFormatDisplay = 'Unsupported image format passed'; + SUnsupportedLCLWidgetSet = 'This function is not implemented for current LCL widget set'; + SImagingGraphicName = 'Imaging Graphic AllInOne'; + +var + RegisteredFormats: TList; + RegisteredGraphicsClasses: Boolean = False; + +{ Registers types to VCL/LCL. + In some cases (base+ext package installed in Lazarus) RegisterTypes can be + called twice so must keep track of which formats were already registered. } +procedure RegisterTypes; +var + I: LongInt; + + procedure RegisterFileFormatAllInOne(Format: TImageFileFormat); + var + I: LongInt; + begin + if RegisteredFormats.IndexOf(Format) >= 0 then + Exit; + + for I := 0 to Format.Extensions.Count - 1 do + begin + TPicture.RegisterFileFormat(Format.Extensions[I], SImagingGraphicName, + TImagingGraphic); + end; + RegisteredFormats.Add(Format); + end; + + procedure RegisterFileFormat(AClass: TImagingGraphicForSaveClass); + var + I: LongInt; + begin + for I := 0 to AClass.GetFileFormat.Extensions.Count - 1 do + TPicture.RegisterFileFormat(AClass.GetFileFormat.Extensions[I], + AClass.GetFileFormat.Name, AClass); + end; + +begin + for I := Imaging.GetFileFormatCount - 1 downto 0 do + RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I)); + Classes.RegisterClass(TImagingGraphic); + + if RegisteredGraphicsClasses then + Exit; + +{$IFNDEF DONT_LINK_TARGA} + RegisterFileFormat(TImagingTarga); + Classes.RegisterClass(TImagingTarga); +{$ENDIF} +{$IFNDEF DONT_LINK_DDS} + RegisterFileFormat(TImagingDDS); + Classes.RegisterClass(TImagingDDS); +{$ENDIF} +{$IFNDEF DONT_LINK_JNG} + RegisterFileFormat(TImagingJNG); + Classes.RegisterClass(TImagingJNG); +{$ENDIF} +{$IFNDEF DONT_LINK_MNG} + RegisterFileFormat(TImagingMNG); + Classes.RegisterClass(TImagingMNG); +{$ENDIF} +{$IFNDEF DONT_LINK_GIF} + RegisterFileFormat(TImagingGIF); + Classes.RegisterClass(TImagingGIF); +{$ENDIF} +{$IFNDEF DONT_LINK_PNG} + {$IFDEF COMPONENT_SET_LCL} + // Unregister Lazarus default PNG loader which crashes on some PNG files + TPicture.UnregisterGraphicClass(TPortableNetworkGraphic); + {$ENDIF} + RegisterFileFormat(TImagingPNG); + Classes.RegisterClass(TImagingPNG); +{$ENDIF} +{$IFNDEF DONT_LINK_JPEG} + RegisterFileFormat(TImagingJpeg); + Classes.RegisterClass(TImagingJpeg); +{$ENDIF} +{$IFNDEF DONT_LINK_BITMAP} + RegisterFileFormat(TImagingBitmap); + Classes.RegisterClass(TImagingBitmap); +{$ENDIF} + + RegisteredGraphicsClasses := True; +end; + +{ Unregisters types from VCL/LCL.} +procedure UnRegisterTypes; +begin +{$IFNDEF DONT_LINK_BITMAP} + TPicture.UnregisterGraphicClass(TImagingBitmap); + Classes.UnRegisterClass(TImagingBitmap); +{$ENDIF} +{$IFNDEF DONT_LINK_JPEG} + TPicture.UnregisterGraphicClass(TImagingJpeg); + Classes.UnRegisterClass(TImagingJpeg); +{$ENDIF} +{$IFNDEF DONT_LINK_PNG} + TPicture.UnregisterGraphicClass(TImagingPNG); + Classes.UnRegisterClass(TImagingPNG); +{$ENDIF} +{$IFNDEF DONT_LINK_GIF} + TPicture.UnregisterGraphicClass(TImagingGIF); + Classes.UnRegisterClass(TImagingGIF); +{$ENDIF} +{$IFNDEF DONT_LINK_TARGA} + TPicture.UnregisterGraphicClass(TImagingTarga); + Classes.UnRegisterClass(TImagingTarga); +{$ENDIF} +{$IFNDEF DONT_LINK_DDS} + TPicture.UnregisterGraphicClass(TImagingDDS); + Classes.UnRegisterClass(TImagingDDS); +{$ENDIF} + TPicture.UnregisterGraphicClass(TImagingGraphic); + Classes.UnRegisterClass(TImagingGraphic); +end; + +function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat; +begin + case Format of +{$IFDEF COMPONENT_SET_VCL} + ifIndex8: Result := pf8bit; + ifR5G6B5: Result := pf16bit; + ifR8G8B8: Result := pf24bit; +{$ENDIF} + ifA8R8G8B8, + ifX8R8G8B8: Result := pf32bit; + else + Result := pfCustom; + end; +end; + +function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat; +begin + case Format of + pf8bit: Result := ifIndex8; + pf15bit: Result := ifA1R5G5B5; + pf16bit: Result := ifR5G6B5; + pf24bit: Result := ifR8G8B8; + pf32bit: Result := ifA8R8G8B8; + else + Result := ifUnknown; + end; +end; + +procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap); +var + PF: TPixelFormat; + Info: TImageFormatInfo; + WorkData: TImageData; +{$IFDEF COMPONENT_SET_VCL} + I, LineBytes: LongInt; + LogPalette: TMaxLogPalette; +{$ENDIF} +{$IFDEF COMPONENT_SET_LCL} + RawImage: TRawImage; + ImgHandle, ImgMaskHandle: HBitmap; +{$ENDIF} +begin + PF := DataFormatToPixelFormat(Data.Format); + GetImageFormatInfo(Data.Format, Info); + + if (PF = pf8bit) and PaletteHasAlpha(Data.Palette, Info.PaletteEntries) then + begin + // Some indexed images may have valid alpha data, don't lose it! + // (e.g. transparent 8bit PNG or GIF images) + PF := pfCustom; + end; + + if PF = pfCustom then + begin + // Convert from formats not supported by Graphics unit + Imaging.InitImage(WorkData); + Imaging.CloneImage(Data, WorkData); + if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then + Imaging.ConvertImage(WorkData, ifA8R8G8B8) + else + begin +{$IFDEF COMPONENT_SET_VCL} + if Info.IsIndexed or Info.HasGrayChannel then + Imaging.ConvertImage(WorkData, ifIndex8) + else if Info.UsePixelFormat then + Imaging.ConvertImage(WorkData, ifR5G6B5) + else + Imaging.ConvertImage(WorkData, ifR8G8B8); +{$ELSE} + Imaging.ConvertImage(WorkData, ifA8R8G8B8); +{$ENDIF} + end; + + PF := DataFormatToPixelFormat(WorkData.Format); + GetImageFormatInfo(WorkData.Format, Info); + end + else + WorkData := Data; + + if PF = pfCustom then + RaiseImaging(SBadFormatDataToBitmap, [ImageToStr(WorkData)]); + +{$IFDEF COMPONENT_SET_VCL} + Bitmap.Width := WorkData.Width; + Bitmap.Height := WorkData.Height; + Bitmap.PixelFormat := PF; + + if (PF = pf8bit) and (WorkData.Palette <> nil) then + begin + // Copy palette, this must be done before copying bits + FillChar(LogPalette, SizeOf(LogPalette), 0); + LogPalette.palVersion := $300; + LogPalette.palNumEntries := Info.PaletteEntries; + for I := 0 to Info.PaletteEntries - 1 do + with LogPalette do + begin + palPalEntry[I].peRed := WorkData.Palette[I].R; + palPalEntry[I].peGreen := WorkData.Palette[I].G; + palPalEntry[I].peBlue := WorkData.Palette[I].B; + end; + Bitmap.Palette := CreatePalette(PLogPalette(@LogPalette)^); + end; + + // Copy scanlines + LineBytes := WorkData.Width * Info.BytesPerPixel; + for I := 0 to WorkData.Height - 1 do + Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes); + + // Delphi 2009 and newer support alpha transparency for TBitmap +{$IF Defined(DELPHI) and (CompilerVersion >= 20.0)} + if Bitmap.PixelFormat = pf32bit then + Bitmap.AlphaFormat := afDefined; +{$IFEND} +{$ENDIF} + +{$IFDEF COMPONENT_SET_LCL} + // Create 32bit raw image from image data + FillChar(RawImage, SizeOf(RawImage), 0); + with RawImage.Description do + begin + Width := WorkData.Width; + Height := WorkData.Height; + BitsPerPixel := 32; + Format := ricfRGBA; + LineEnd := rileDWordBoundary; + BitOrder := riboBitsInOrder; + ByteOrder := riboLSBFirst; + LineOrder := riloTopToBottom; + AlphaPrec := 8; + RedPrec := 8; + GreenPrec := 8; + BluePrec := 8; + AlphaShift := 24; + RedShift := 16; + GreenShift := 8; + BlueShift := 0; + Depth := 32; // Must be 32 for alpha blending (and for working in MacOSX Carbon) + end; + RawImage.Data := WorkData.Bits; + RawImage.DataSize := WorkData.Size; + + // Create bitmap from raw image + if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle) then + begin + Bitmap.Handle := ImgHandle; + Bitmap.MaskHandle := ImgMaskHandle; + end; +{$ENDIF} + if WorkData.Bits <> Data.Bits then + Imaging.FreeImage(WorkData); +end; + +procedure ConvertBitmapToData(Bitmap: TBitmap; var Data: TImageData); +var + I, LineBytes: LongInt; + Format: TImageFormat; + Info: TImageFormatInfo; +{$IFDEF COMPONENT_SET_VCL} + Colors: Word; + LogPalette: TMaxLogPalette; +{$ENDIF} +{$IFDEF COMPONENT_SET_LCL} + RawImage: TRawImage; + LineLazBytes: LongInt; +{$ENDIF} +begin + Format := ifUnknown; +{$IFDEF COMPONENT_SET_LCL} + // In the current Lazarus 0.9.10 Bitmap.PixelFormat property is useless. + // We cannot change bitmap's format by changing it (it will just release + // old image but not convert it to new format) nor we can determine bitmaps's + // current format (it is usually set to pfDevice). So bitmap's format is obtained + // trough RawImage api and cannot be changed to mirror some Imaging format + // (so formats with no corresponding Imaging format cannot be saved now). + + if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then + case RawImage.Description.BitsPerPixel of + 8: Format := ifIndex8; + 16: + if RawImage.Description.Depth = 15 then + Format := ifA1R5G5B5 + else + Format := ifR5G6B5; + 24: Format := ifR8G8B8; + 32: Format := ifA8R8G8B8; + 48: Format := ifR16G16B16; + 64: Format := ifA16R16G16B16; + end; +{$ELSE} + Format := PixelFormatToDataFormat(Bitmap.PixelFormat); + if Format = ifUnknown then + begin + // Convert from formats not supported by Imaging (1/4 bit) + if Bitmap.PixelFormat < pf8bit then + Bitmap.PixelFormat := pf8bit + else + Bitmap.PixelFormat := pf32bit; + Format := PixelFormatToDataFormat(Bitmap.PixelFormat); + end; +{$ENDIF} + + if Format = ifUnknown then + RaiseImaging(SBadFormatBitmapToData, []); + + Imaging.NewImage(Bitmap.Width, Bitmap.Height, Format, Data); + GetImageFormatInfo(Data.Format, Info); + LineBytes := Data.Width * Info.BytesPerPixel; + +{$IFDEF COMPONENT_SET_VCL} + if (Format = ifIndex8) and (GetObject(Bitmap.Palette, SizeOf(Colors), + @Colors) <> 0) then + begin + // Copy palette + GetPaletteEntries(Bitmap.Palette, 0, Colors, LogPalette.palPalEntry); + if Colors > Info.PaletteEntries then + Colors := Info.PaletteEntries; + for I := 0 to Colors - 1 do + with LogPalette do + begin + Data.Palette[I].A := $FF; + Data.Palette[I].R := palPalEntry[I].peRed; + Data.Palette[I].G := palPalEntry[I].peGreen; + Data.Palette[I].B := palPalEntry[I].peBlue; + end; + end; + // Copy scanlines + for I := 0 to Data.Height - 1 do + Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes); +{$ENDIF} +{$IFDEF COMPONENT_SET_LCL} + // Get raw image from bitmap (mask handle must be 0 or expect violations) + if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then + begin + LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel, + RawImage.Description.LineEnd); + // Copy scanlines + for I := 0 to Data.Height - 1 do + begin + Move(PByteArray(RawImage.Data)[I * LineLazBytes], + PByteArray(Data.Bits)[I * LineBytes], LineBytes); + end; + // May need to swap RB order, depends on widget set + if RawImage.Description.BlueShift > RawImage.Description.RedShift then + SwapChannels(Data, ChannelRed, ChannelBlue); + + RawImage.FreeData; + end; +{$ENDIF} +end; + +procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap); +begin + ConvertDataToBitmap(Image.ImageDataPointer^, Bitmap); +end; + +procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage); +begin + ConvertBitmapToData(Bitmap, Image.ImageDataPointer^); +end; + +{$IFDEF MSWINDOWS} +procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); +var + OldMode: Integer; + BitmapInfo: Windows.TBitmapInfo; + Bmp: TBitmap; +begin + if TestImage(ImageData) then + begin + Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay); + OldMode := Windows.SetStretchBltMode(DC, COLORONCOLOR); + + FillChar(BitmapInfo, SizeOf(BitmapInfo), 0); + with BitmapInfo.bmiHeader do + begin + biSize := SizeOf(TBitmapInfoHeader); + biPlanes := 1; + biBitCount := 32; + biCompression := BI_RGB; + biWidth := ImageData.Width; + biHeight := -ImageData.Height; + biSizeImage := ImageData.Size; + biXPelsPerMeter := 0; + biYPelsPerMeter := 0; + biClrUsed := 0; + biClrImportant := 0; + end; + + try + with SrcRect, ImageData do + if Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top, + DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left, + Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY) <> Height then + begin + // StretchDIBits may fail on some occasions (error 487, http://support.microsoft.com/kb/269585). + // This fallback is slow but works every time. Thanks to Sergey Galezdinov for the fix. + Bmp := TBitmap.Create; + try + ConvertDataToBitmap(ImageData, Bmp); + StretchBlt(DC, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, + Bmp.Canvas.Handle, 0, 0, Width, Height, SRCCOPY); + finally + Bmp.Free; + end; + end; + finally + Windows.SetStretchBltMode(DC, OldMode); + end; + end; +end; +{$ENDIF} + +procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData); +begin + DisplayImageData(DstCanvas, DstRect, ImageData, Rect(0, 0, ImageData.Width, ImageData.Height)); +end; + +procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); +{$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32 +begin + DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect); +end; +{$ELSEIF Defined(LCLGTK2)} + procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, + SrcWidth, SrcHeight: Integer; ImageData: TImageData); + var + P: TPoint; + begin + P := TGtkDeviceContext(Dest).Offset; + Inc(DstX, P.X); + Inc(DstY, P.Y); + + if ImageData.Format = ifR8G8B8 then + begin + gdk_draw_rgb_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC, + DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE, + @PUInt32Array(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 3); + end + else + begin + gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC, + DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE, + @PUInt32Array(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4); + end; + end; + +var + DisplayImage: TImageData; + NewWidth, NewHeight: Integer; + SrcBounds, DstBounds, DstClip: TRect; +begin + if TestImage(ImageData) then + begin + if not (ImageData.Format in [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8]) then + raise EImagingError.Create(SBadFormatDisplay); + + InitImage(DisplayImage); + SrcBounds := RectToBounds(SrcRect); + DstBounds := RectToBounds(DstRect); + WidgetSet.GetClipBox(DstCanvas.Handle, @DstClip); + + ClipStretchBounds(SrcBounds.Left, SrcBounds.Top, SrcBounds.Right, SrcBounds.Bottom, + DstBounds.Left, DstBounds.Top, DstBounds.Right, DstBounds.Bottom, ImageData.Width, + ImageData.Height, DstClip); + + NewWidth := DstBounds.Right; + NewHeight := DstBounds.Bottom; + + if (NewWidth > 0) and (NewHeight > 0) then + begin + if (SrcBounds.Right = NewWidth) and (SrcBounds.Bottom = NewHeight) then + try + CloneImage(ImageData, DisplayImage); + // Swap R-B channels for GTK display compatibility! + SwapChannels(DisplayImage, ChannelRed, ChannelBlue); + GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, + SrcBounds.Left, SrcBounds.Top, NewWidth, NewHeight, DisplayImage); + finally + FreeImage(DisplayImage); + end + else + try + // Create new image with desired dimensions + NewImage(NewWidth, NewHeight, ImageData.Format, DisplayImage); + // Stretch pixels from old image to new one TResizeFilter = (rfNearest, rfBilinear, rfBicubic); + StretchRect(ImageData, SrcBounds.Left, SrcBounds.Top, SrcBounds.Right, + SrcBounds.Bottom, DisplayImage, 0, 0, NewWidth, NewHeight, rfNearest); + // Swap R-B channels for GTK display compatibility! + SwapChannels(DisplayImage, ChannelRed, ChannelBlue); + GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, 0, 0, + NewWidth, NewHeight, DisplayImage); + finally + FreeImage(DisplayImage); + end + end; + end; +end; +{$ELSEIF Defined(LCLqt5)} +var + QImage: TQtImage; + Context: TQtDeviceContext; +begin + if TestImage(ImageData) then + begin + if not (ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8]) then + raise EImagingError.Create(SBadFormatDisplay); + + Context := TQtDeviceContext(DstCanvas.Handle); + + // QImage directly uses the image memory, there is no copy done + QImage := TQtImage.Create(ImageData.Bits, ImageData.Width, ImageData.Height, + ImageData.Width * 4, QImageFormat_ARGB32, False); + try + QPainter_drawImage(Context.Widget, PRect(@DstRect), QImage.Handle, @SrcRect, QtAutoColor); + finally + QImage.Free; + end; + end; +end; +{$ELSEIF Defined(LCLcocoa)} +var + CocoaBmp: TCocoaBitmap; + Context: TCocoaContext; +begin + if TestImage(ImageData) then + begin + if not (ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8]) then + raise EImagingError.Create(SBadFormatDisplay); + + Context := CheckDC(DstCanvas.Handle); + + // We copy the data since it needs R/B swap and potentially alpha pre-multiply + CocoaBmp := TCocoaBitmap.Create(ImageData.Width, ImageData.Height, 32, 32, + cbaDWord, cbtBGRA, ImageData.Bits, True); + try + Context.DrawImageRep(RectToNSRect(DstRect), RectToNSRect(SrcRect), CocoaBmp.ImageRep); + finally + CocoaBmp.Free; + end; + end; +end; +{$ELSE} +begin + raise EImagingError.Create(SUnsupportedLCLWidgetSet); +end; +{$IFEND} + +procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage); +begin + DisplayImageData(DstCanvas, BoundsToRect(DstX, DstY, Image.Width, Image.Height), + Image.ImageDataPointer^, Image.BoundsRect); +end; + +procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage); +begin + DisplayImageData(DstCanvas, DstRect, Image.ImageDataPointer^, Image.BoundsRect); +end; + +procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseImage; const SrcRect: TRect); +begin + DisplayImageData(DstCanvas, DstRect, Image.ImageDataPointer^, SrcRect); +end; + + +{ TImagingGraphic class implementation } + +constructor TImagingGraphic.Create; +begin + inherited Create; + PixelFormat := pf24Bit; +end; + +procedure TImagingGraphic.ReadData(Stream: TStream); +begin + // Here we need to skip ReadData+WriteData of TBitmap (and LCL TRasterBitmap) + // and go to the basics in TGraphic's ReadData+WriteData with just LoadFromStream + // and SaveToStream. + // Some VCL/LCL TGraphic classes also store size of the written data + // before the stream contents. However, the stream passed here + // from TReader.DefineBinaryProperty is already + // a memory stream capped to the size of binary property data. + // Picture.Data = + LoadFromStream(Stream); +end; + +procedure TImagingGraphic.WriteData(Stream: TStream); +begin + // This can happen when streaming some of the formats that don't have + // TImagingGraphicForSave descendant. + SaveToStream(Stream); +end; + +procedure TImagingGraphic.LoadFromStream(Stream: TStream); +var + Image: TSingleImage; +begin + Image := TSingleImage.Create; + try + Image.LoadFromStream(Stream); + Assign(Image); + finally + Image.Free; + end; +end; + +procedure TImagingGraphic.SaveToStream(Stream: TStream); +var + Image: TSingleImage; +begin + Image := TSingleImage.Create; + try + Image.Assign(Self); + Image.SaveToStream('png', Stream); + finally + Image.Free; + end; +end; + +procedure TImagingGraphic.AssignTo(Dest: TPersistent); +var + Arr: TDynImageDataArray; +begin + if Dest is TSingleImage then + begin + AssignToImage(TSingleImage(Dest)) + end + else if Dest is TMultiImage then + begin + SetLength(Arr, 1); + AssignToImageData(Arr[0]); + TMultiImage(Dest).CreateFromArray(Arr); + Imaging.FreeImagesInArray(Arr); + end + else + inherited AssignTo(Dest); +end; + +{$IFDEF COMPONENT_SET_LCL} +function TImagingGraphic.GetResourceType: TResourceType; +begin + Result := RT_RCDATA; +end; + +class function TImagingGraphic.IsStreamFormatSupported(Stream: TStream): Boolean; +begin + Result := DetermineStreamFormat(Stream) <> ''; +end; +{$ENDIF} + +procedure TImagingGraphic.Assign(Source: TPersistent); +begin + if Source is TBaseImage then + AssignFromImage(TBaseImage(Source)) + else + inherited Assign(Source); +end; + +procedure TImagingGraphic.AssignFromImage(Image: TBaseImage); +begin + if (Image <> nil) and Image.Valid then + AssignFromImageData(Image.ImageDataPointer^); +end; + +procedure TImagingGraphic.AssignToImage(Image: TBaseImage); +begin + if (Image <> nil) and (Image.ImageDataPointer <> nil) then + AssignToImageData(Image.ImageDataPointer^); +end; + +procedure TImagingGraphic.AssignFromImageData(const ImageData: TImageData); +begin + if Imaging.TestImage(ImageData) then + ConvertDataToBitmap(ImageData, Self); +end; + +procedure TImagingGraphic.AssignToImageData(var ImageData: TImageData); +begin + Imaging.FreeImage(ImageData); + ConvertBitmapToData(Self, ImageData); +end; + +{ TImagingGraphicForSave class implementation } + +constructor TImagingGraphicForSave.Create; +begin + inherited Create; + FDefaultFileExt := GetFileFormat.Extensions[0]; + FSavingFormat := ifUnknown; + GetFileFormat.CheckOptionsValidity; +end; + +procedure TImagingGraphicForSave.WriteData(Stream: TStream); +begin + SaveToStream(Stream); +end; + +procedure TImagingGraphicForSave.SaveToStream(Stream: TStream); +var + Image: TSingleImage; +begin + if FDefaultFileExt <> '' then + begin + Image := TSingleImage.Create; + try + Image.Assign(Self); + if FSavingFormat <> ifUnknown then + Image.Format := FSavingFormat; + Image.SaveToStream(FDefaultFileExt, Stream); + finally + Image.Free; + end; + end; +end; + +{$IFDEF COMPONENT_SET_LCL} +class function TImagingGraphicForSave.GetFileExtensions: string; +begin + Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]); +end; + +function TImagingGraphicForSave.GetMimeType: string; +begin + Result := 'image/' + FDefaultFileExt; +end; +{$ENDIF} + +{$IFNDEF DONT_LINK_BITMAP} +constructor TImagingBitmap.Create; +begin + inherited Create; + FUseRLE := (GetFileFormat as TBitmapFileFormat).UseRLE; +end; + +class function TImagingBitmap.GetFileFormat: TImageFileFormat; +begin + Result := FindImageFileFormatByClass(TBitmapFileFormat); +end; + +procedure TImagingBitmap.SaveToStream(Stream: TStream); +begin + Imaging.PushOptions; + Imaging.SetOption(ImagingBitmapRLE, Ord(FUseRLE)); + inherited SaveToStream(Stream); + Imaging.PopOptions; +end; +{$ENDIF} + +{$IFNDEF DONT_LINK_JPEG} +constructor TImagingJpeg.Create; +begin + inherited Create; + FQuality := (GetFileFormat as TJpegFileFormat).Quality; + FProgressive := (GetFileFormat as TJpegFileFormat).Progressive; +end; + +class function TImagingJpeg.GetFileFormat: TImageFileFormat; +begin + Result := FindImageFileFormatByClass(TJpegFileFormat); +end; + +{$IFDEF COMPONENT_SET_LCL} +function TImagingJpeg.GetMimeType: string; +begin + Result := 'image/jpeg'; +end; +{$ENDIF} + +procedure TImagingJpeg.SaveToStream(Stream: TStream); +begin + Imaging.PushOptions; + Imaging.SetOption(ImagingJpegQuality, FQuality); + Imaging.SetOption(ImagingJpegProgressive, Ord(FProgressive)); + inherited SaveToStream(Stream); + Imaging.PopOptions; +end; + +{$ENDIF} + +{$IFNDEF DONT_LINK_PNG} +constructor TImagingPNG.Create; +begin + inherited Create; + FPreFilter := (GetFileFormat as TPNGFileFormat).PreFilter; + FCompressLevel := (GetFileFormat as TPNGFileFormat).CompressLevel; +end; + +class function TImagingPNG.GetFileFormat: TImageFileFormat; +begin + Result := FindImageFileFormatByClass(TPNGFileFormat); +end; + +procedure TImagingPNG.SaveToStream(Stream: TStream); +begin + Imaging.PushOptions; + Imaging.SetOption(ImagingPNGPreFilter, FPreFilter); + Imaging.SetOption(ImagingPNGCompressLevel, FCompressLevel); + inherited SaveToStream(Stream); + Imaging.PopOptions; +end; +{$ENDIF} + +{$IFNDEF DONT_LINK_GIF} +class function TImagingGIF.GetFileFormat: TImageFileFormat; +begin + Result := FindImageFileFormatByClass(TGIFFileFormat); +end; +{$ENDIF} + +{$IFNDEF DONT_LINK_TARGA} +constructor TImagingTarga.Create; +begin + inherited Create; + FUseRLE := (GetFileFormat as TTargaFileFormat).UseRLE; +end; + +class function TImagingTarga.GetFileFormat: TImageFileFormat; +begin + Result := FindImageFileFormatByClass(TTargaFileFormat); +end; + +procedure TImagingTarga.SaveToStream(Stream: TStream); +begin + Imaging.PushOptions; + Imaging.SetOption(ImagingTargaRLE, Ord(FUseRLE)); + inherited SaveToStream(Stream); + Imaging.PopOptions; +end; +{$ENDIF} + +{$IFNDEF DONT_LINK_DDS} +constructor TImagingDDS.Create; +begin + inherited Create; + FCompression := dcNone; +end; + +class function TImagingDDS.GetFileFormat: TImageFileFormat; +begin + Result := FindImageFileFormatByClass(TDDSFileFormat); +end; + +procedure TImagingDDS.SaveToStream(Stream: TStream); +begin + case FCompression of + dcNone: FSavingFormat := ifUnknown; + dcDXT1: FSavingFormat := ifDXT1; + dcDXT3: FSavingFormat := ifDXT3; + dcDXT5: FSavingFormat := ifDXT5; + end; + Imaging.PushOptions; + Imaging.SetOption(ImagingDDSSaveCubeMap, Ord(False)); + Imaging.SetOption(ImagingDDSSaveVolume, Ord(False)); + Imaging.SetOption(ImagingDDSSaveMipMapCount, 1); + Imaging.SetOption(ImagingDDSSaveDepth, 1); + inherited SaveToStream(Stream); + Imaging.PopOptions; +end; +{$ENDIF} + +{$IFNDEF DONT_LINK_MNG} +constructor TImagingMNG.Create; +begin + inherited Create; + FLossyCompression := (GetFileFormat as TMNGFileFormat).LossyCompression; + FLossyAlpha := (GetFileFormat as TMNGFileFormat).LossyAlpha; + FPreFilter := (GetFileFormat as TMNGFileFormat).PreFilter; + FCompressLevel := (GetFileFormat as TMNGFileFormat).CompressLevel; + FQuality := (GetFileFormat as TMNGFileFormat).Quality; + FProgressive := (GetFileFormat as TMNGFileFormat).Progressive; +end; + +class function TImagingMNG.GetFileFormat: TImageFileFormat; +begin + Result := FindImageFileFormatByClass(TMNGFileFormat); +end; + +{$IFDEF COMPONENT_SET_LCL} +function TImagingMNG.GetMimeType: string; +begin + Result := 'video/mng'; +end; +{$ENDIF} + +procedure TImagingMNG.SaveToStream(Stream: TStream); +begin + Imaging.PushOptions; + Imaging.SetOption(ImagingMNGLossyCompression, Ord(FLossyCompression)); + Imaging.SetOption(ImagingMNGLossyAlpha, Ord(FLossyAlpha)); + Imaging.SetOption(ImagingMNGPreFilter, FPreFilter); + Imaging.SetOption(ImagingMNGCompressLevel, FCompressLevel); + Imaging.SetOption(ImagingMNGQuality, FQuality); + Imaging.SetOption(ImagingMNGProgressive, Ord(FProgressive)); + inherited SaveToStream(Stream); + Imaging.PopOptions; +end; +{$ENDIF} + +{$IFNDEF DONT_LINK_JNG} +constructor TImagingJNG.Create; +begin + inherited Create; + FLossyAlpha := (GetFileFormat as TJNGFileFormat).LossyAlpha; + FAlphaPreFilter := (GetFileFormat as TJNGFileFormat).PreFilter; + FAlphaCompressLevel := (GetFileFormat as TJNGFileFormat).CompressLevel; + FQuality := (GetFileFormat as TJNGFileFormat).Quality; + FProgressive := (GetFileFormat as TJNGFileFormat).Progressive; +end; + +class function TImagingJNG.GetFileFormat: TImageFileFormat; +begin + Result := FindImageFileFormatByClass(TJNGFileFormat); +end; + +procedure TImagingJNG.SaveToStream(Stream: TStream); +begin + Imaging.PushOptions; + Imaging.SetOption(ImagingJNGLossyALpha, Ord(FLossyAlpha)); + Imaging.SetOption(ImagingJNGAlphaPreFilter, FAlphaPreFilter); + Imaging.SetOption(ImagingJNGAlphaCompressLevel, FAlphaCompressLevel); + Imaging.SetOption(ImagingJNGQuality, FQuality); + Imaging.SetOption(ImagingJNGProgressive, Ord(FProgressive)); + inherited SaveToStream(Stream); + Imaging.PopOptions; +end; +{$ENDIF} + +initialization + RegisteredFormats := TList.Create; + RegisterTypes; +finalization + UnRegisterTypes; + RegisteredFormats.Free; + +{$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)} + +{ + File Notes: + + -- 0.77.1 --------------------------------------------------- + - Fixed bug in ConvertBitmapToData causing images from GTK2 bitmaps + to have swapped RB channels. + - LCL: Removed GTK1 support (deprecated). + + -- 0.26.3 Changes/Bug Fixes --------------------------------- + - Transparency of 8bit images (like loaded from 8bit PNG or GIF) is + kept intact during conversion to TBitmap in ConvertDataToBitmap + (32bit bitmap is created). + + -- 0.26.3 Changes/Bug Fixes --------------------------------- + - Setting AlphaFormat property of TBitmap in ConvertDataToBitmap + when using Delphi 2009+. + - Fixed garbled LCL TBitmaps created by ConvertDataToBitmap + in Mac OS X (Carbon). + + -- 0.26.1 Changes/Bug Fixes --------------------------------- + - Added some more IFDEFs for Lazarus widget sets. + - Removed CLX code. + - GTK version of Unix DisplayImageData only used with LCL GTK so the + the rest of the unit can be used with Qt or other LCL interfaces. + - Fallback mechanism for DisplayImageDataOnDC, it may fail on occasions. + - Changed file format conditional compilation to reflect changes + in LINK symbols. + - Lazarus 0.9.26 compatibility changes. + + -- 0.24.1 Changes/Bug Fixes --------------------------------- + - Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus + with GTK2 target. + - Added comments with code for Lazarus rev. 11861+ regarding + RawImage interface. Replace current code with that in comments + if you use Lazarus from SVN. New RawImage interface will be used by + default after next Lazarus release. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Added TImagingGIF. + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Uses only high level interface now (except for saving options). + - Slightly changed class hierarchy. TImagingGraphic is now only for loading + and base class for savers is new TImagingGraphicForSave. Also + TImagingGraphic is now registered with all supported file formats + by TPicture's format support. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - added DisplayImage procedures (thanks to Paul Michell, modified) + - removed RegisterTypes and UnRegisterTypes from interface section, + they are called automatically + - added procedures: ConvertImageToBitmap and ConvertBitmapToImage + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - LCL data to bitmap conversion didn't work in Linux, fixed + - added MNG file format + - added JNG file format + + -- 0.15 Changes/Bug Fixes ----------------------------------- + - made it LCL compatible + - made it CLX compatible + - added all initial stuff +} + +end. + diff --git a/Imaging/ImagingDds.pas b/Imaging/ImagingDds.pas index 08090d7..2be4b19 100644 --- a/Imaging/ImagingDds.pas +++ b/Imaging/ImagingDds.pas @@ -1,864 +1,1129 @@ -{ - $Id: ImagingDds.pas 129 2008-08-06 20:01:30Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains image format loader/saver for DirectDraw Surface images.} -unit ImagingDds; - -{$I ImagingOptions.inc} - -interface - -uses - ImagingTypes, Imaging, ImagingUtility, ImagingFormats; - -type - { Class for loading and saving Microsoft DirectDraw surfaces. - It can load/save all D3D formats which have coresponding - TImageFormat. It supports plain textures, cube textures and - volume textures, all of these can have mipmaps. It can also - load some formats which have no exact TImageFormat, but can be easily - converted to one (bump map formats). - You can get some information about last loaded DDS file by calling - GetOption with ImagingDDSLoadedXXX options and you can set some - saving options by calling SetOption with ImagingDDSSaveXXX or you can - simply use properties of this class. - Note that when saving cube maps and volumes input image array must contain - at least number of images to build cube/volume based on current - Depth and MipMapCount settings.} - TDDSFileFormat = class(TImageFileFormat) - protected - FLoadedCubeMap: LongBool; - FLoadedVolume: LongBool; - FLoadedMipMapCount: LongInt; - FLoadedDepth: LongInt; - FSaveCubeMap: LongBool; - FSaveVolume: LongBool; - FSaveMipMapCount: LongInt; - FSaveDepth: LongInt; - procedure ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt; - IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt); - function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean): Boolean; override; - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); override; - public - constructor Create; override; - function TestFormat(Handle: TImagingHandle): Boolean; override; - procedure CheckOptionsValidity; override; - published - { True if last loaded DDS file was cube map.} - property LoadedCubeMap: LongBool read FLoadedCubeMap write FLoadedCubeMap; - { True if last loaded DDS file was volume texture.} - property LoadedVolume: LongBool read FLoadedVolume write FLoadedVolume; - { Number of mipmap levels of last loaded DDS image.} - property LoadedMipMapCount: LongInt read FLoadedMipMapCount write FLoadedMipMapCount; - { Depth (slices of volume texture or faces of cube map) of last loaded DDS image.} - property LoadedDepth: LongInt read FLoadedDepth write FLoadedDepth; - { True if next DDS file to be saved should be stored as cube map.} - property SaveCubeMap: LongBool read FSaveCubeMap write FSaveCubeMap; - { True if next DDS file to be saved should be stored as volume texture.} - property SaveVolume: LongBool read FSaveVolume write FSaveVolume; - { Sets the number of mipmaps which should be stored in the next saved DDS file. - Only applies to cube maps and volumes, ordinary 2D textures save all - levels present in input.} - property SaveMipMapCount: LongInt read FSaveMipMapCount write FSaveMipMapCount; - { Sets the depth (slices of volume texture or faces of cube map) - of the next saved DDS file.} - property SaveDepth: LongInt read FSaveDepth write FSaveDepth; - end; - -implementation - -const - SDDSFormatName = 'DirectDraw Surface'; - SDDSMasks = '*.dds'; - DDSSupportedFormats: TImageFormats = [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8, - ifA1R5G5B5, ifA4R4G4B4, ifX1R5G5B5, ifX4R4G4B4, ifR5G6B5, ifA16B16G16R16, - ifR32F, ifA32B32G32R32F, ifR16F, ifA16B16G16R16F, ifR3G3B2, ifGray8, ifA8Gray8, - ifGray16, ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N]; - -const - { Four character codes.} - DDSMagic = LongWord(Byte('D') or (Byte('D') shl 8) or (Byte('S') shl 16) or - (Byte(' ') shl 24)); - FOURCC_DXT1 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or - (Byte('1') shl 24)); - FOURCC_DXT3 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or - (Byte('3') shl 24)); - FOURCC_DXT5 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or - (Byte('5') shl 24)); - FOURCC_ATI1 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or - (Byte('1') shl 24)); - FOURCC_ATI2 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or - (Byte('2') shl 24)); - - { Some D3DFORMAT values used in DDS files as FourCC value.} - D3DFMT_A16B16G16R16 = 36; - D3DFMT_R32F = 114; - D3DFMT_A32B32G32R32F = 116; - D3DFMT_R16F = 111; - D3DFMT_A16B16G16R16F = 113; - - { Constans used by TDDSurfaceDesc2.Flags.} - DDSD_CAPS = $00000001; - DDSD_HEIGHT = $00000002; - DDSD_WIDTH = $00000004; - DDSD_PITCH = $00000008; - DDSD_PIXELFORMAT = $00001000; - DDSD_MIPMAPCOUNT = $00020000; - DDSD_LINEARSIZE = $00080000; - DDSD_DEPTH = $00800000; - - { Constans used by TDDSPixelFormat.Flags.} - DDPF_ALPHAPIXELS = $00000001; // used by formats which contain alpha - DDPF_FOURCC = $00000004; // used by DXT and large ARGB formats - DDPF_RGB = $00000040; // used by RGB formats - DDPF_LUMINANCE = $00020000; // used by formats like D3DFMT_L16 - DDPF_BUMPLUMINANCE = $00040000; // used by mixed signed-unsigned formats - DDPF_BUMPDUDV = $00080000; // used by signed formats - - { Constans used by TDDSCaps.Caps1.} - DDSCAPS_COMPLEX = $00000008; - DDSCAPS_TEXTURE = $00001000; - DDSCAPS_MIPMAP = $00400000; - - { Constans used by TDDSCaps.Caps2.} - DDSCAPS2_CUBEMAP = $00000200; - DDSCAPS2_POSITIVEX = $00000400; - DDSCAPS2_NEGATIVEX = $00000800; - DDSCAPS2_POSITIVEY = $00001000; - DDSCAPS2_NEGATIVEY = $00002000; - DDSCAPS2_POSITIVEZ = $00004000; - DDSCAPS2_NEGATIVEZ = $00008000; - DDSCAPS2_VOLUME = $00200000; - - { Flags for TDDSurfaceDesc2.Flags used when saving DDS file.} - DDS_SAVE_FLAGS = DDSD_CAPS or DDSD_PIXELFORMAT or DDSD_WIDTH or - DDSD_HEIGHT or DDSD_LINEARSIZE; - -type - { Stores the pixel format information.} - TDDPixelFormat = packed record - Size: LongWord; // Size of the structure = 32 bytes - Flags: LongWord; // Flags to indicate valid fields - FourCC: LongWord; // Four-char code for compressed textures (DXT) - BitCount: LongWord; // Bits per pixel if uncomp. usually 16,24 or 32 - RedMask: LongWord; // Bit mask for the Red component - GreenMask: LongWord; // Bit mask for the Green component - BlueMask: LongWord; // Bit mask for the Blue component - AlphaMask: LongWord; // Bit mask for the Alpha component - end; - - { Specifies capabilities of surface.} - TDDSCaps = packed record - Caps1: LongWord; // Should always include DDSCAPS_TEXTURE - Caps2: LongWord; // For cubic environment maps - Reserved: array[0..1] of LongWord; // Reserved - end; - - { Record describing DDS file contents.} - TDDSurfaceDesc2 = packed record - Size: LongWord; // Size of the structure = 124 Bytes - Flags: LongWord; // Flags to indicate valid fields - Height: LongWord; // Height of the main image in pixels - Width: LongWord; // Width of the main image in pixels - PitchOrLinearSize: LongWord; // For uncomp formats number of bytes per - // scanline. For comp it is the size in - // bytes of the main image - Depth: LongWord; // Only for volume text depth of the volume - MipMaps: LongInt; // Total number of levels in the mipmap chain - Reserved1: array[0..10] of LongWord; // Reserved - PixelFormat: TDDPixelFormat; // Format of the pixel data - Caps: TDDSCaps; // Capabilities - Reserved2: LongWord; // Reserved - end; - - { DDS file header.} - TDDSFileHeader = packed record - Magic: LongWord; // File format magic - Desc: TDDSurfaceDesc2; // Surface description - end; - - -{ TDDSFileFormat class implementation } - -constructor TDDSFileFormat.Create; -begin - inherited Create; - FName := SDDSFormatName; - FCanLoad := True; - FCanSave := True; - FIsMultiImageFormat := True; - FSupportedFormats := DDSSupportedFormats; - - FSaveCubeMap := False; - FSaveVolume := False; - FSaveMipMapCount := 1; - FSaveDepth := 1; - - AddMasks(SDDSMasks); - - RegisterOption(ImagingDDSLoadedCubeMap, @FLoadedCubeMap); - RegisterOption(ImagingDDSLoadedVolume, @FLoadedVolume); - RegisterOption(ImagingDDSLoadedMipMapCount, @FLoadedMipMapCount); - RegisterOption(ImagingDDSLoadedDepth, @FLoadedDepth); - RegisterOption(ImagingDDSSaveCubeMap, @FSaveCubeMap); - RegisterOption(ImagingDDSSaveVolume, @FSaveVolume); - RegisterOption(ImagingDDSSaveMipMapCount, @FSaveMipMapCount); - RegisterOption(ImagingDDSSaveDepth, @FSaveDepth); -end; - -procedure TDDSFileFormat.CheckOptionsValidity; -begin - if FSaveCubeMap then - FSaveVolume := False; - if FSaveVolume then - FSaveCubeMap := False; - if FSaveDepth < 1 then - FSaveDepth := 1; - if FSaveMipMapCount < 1 then - FSaveMipMapCount := 1; -end; - -procedure TDDSFileFormat.ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt; - IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt); -var - I, Last, Shift: LongInt; -begin - CurWidth := Width; - CurHeight := Height; - if MipMaps > 1 then - begin - if not IsVolume then - begin - if IsCubeMap then - begin - // Cube maps are stored like this - // Face 0 mimap 0 - // Face 0 mipmap 1 - // ... - // Face 1 mipmap 0 - // Face 1 mipmap 1 - // ... - - // Modify index so later in for loop we iterate less times - Idx := Idx - ((Idx div MipMaps) * MipMaps); - end; - for I := 0 to Idx - 1 do - begin - CurWidth := ClampInt(CurWidth shr 1, 1, CurWidth); - CurHeight := ClampInt(CurHeight shr 1, 1, CurHeight); - end; - end - else - begin - // Volume textures are stored in DDS files like this: - // Slice 0 mipmap 0 - // Slice 1 mipmap 0 - // Slice 2 mipmap 0 - // Slice 3 mipmap 0 - // Slice 0 mipmap 1 - // Slice 1 mipmap 1 - // Slice 0 mipmap 2 - // Slice 0 mipmap 3 ... - Shift := 0; - Last := Depth; - while Idx > Last - 1 do - begin - CurWidth := ClampInt(CurWidth shr 1, 1, CurWidth); - CurHeight := ClampInt(CurHeight shr 1, 1, CurHeight); - if (CurWidth = 1) and (CurHeight = 1) then - Break; - Inc(Shift); - Inc(Last, ClampInt(Depth shr Shift, 1, Depth)); - end; - end; - end; -end; - -function TDDSFileFormat.LoadData(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - Hdr: TDDSFileHeader; - SrcFormat: TImageFormat; - FmtInfo: TImageFormatInfo; - NeedsSwapChannels: Boolean; - CurrentWidth, CurrentHeight, ImageCount, LoadSize, I, PitchOrLinear: LongInt; - Data: PByte; - UseAsPitch: Boolean; - UseAsLinear: Boolean; - - function MasksEqual(const DDPF: TDDPixelFormat; PF: PPixelFormatInfo): Boolean; - begin - Result := (DDPF.AlphaMask = PF.ABitMask) and - (DDPF.RedMask = PF.RBitMask) and (DDPF.GreenMask = PF.GBitMask) and - (DDPF.BlueMask = PF.BBitMask); - end; - -begin - Result := False; - ImageCount := 1; - FLoadedMipMapCount := 1; - FLoadedDepth := 1; - FLoadedVolume := False; - FLoadedCubeMap := False; - - with GetIO, Hdr, Hdr.Desc.PixelFormat do - begin - Read(Handle, @Hdr, SizeOF(Hdr)); - { - // Set position to the end of the header (for possible future versions - // ith larger header) - Seek(Handle, Hdr.Desc.Size + SizeOf(Hdr.Magic) - SizeOf(Hdr), - smFromCurrent); - } - SrcFormat := ifUnknown; - NeedsSwapChannels := False; - // Get image data format - if (Flags and DDPF_FOURCC) = DDPF_FOURCC then - begin - // Handle FourCC and large ARGB formats - case FourCC of - D3DFMT_A16B16G16R16: SrcFormat := ifA16B16G16R16; - D3DFMT_R32F: SrcFormat := ifR32F; - D3DFMT_A32B32G32R32F: SrcFormat := ifA32B32G32R32F; - D3DFMT_R16F: SrcFormat := ifR16F; - D3DFMT_A16B16G16R16F: SrcFormat := ifA16B16G16R16F; - FOURCC_DXT1: SrcFormat := ifDXT1; - FOURCC_DXT3: SrcFormat := ifDXT3; - FOURCC_DXT5: SrcFormat := ifDXT5; - FOURCC_ATI1: SrcFormat := ifATI1N; - FOURCC_ATI2: SrcFormat := ifATI2N; - end; - end - else if (Flags and DDPF_RGB) = DDPF_RGB then - begin - // Handle RGB formats - if (Flags and DDPF_ALPHAPIXELS) = DDPF_ALPHAPIXELS then - begin - // Handle RGB with alpha formats - case BitCount of - 16: - begin - if MasksEqual(Desc.PixelFormat, - GetFormatInfo(ifA4R4G4B4).PixelFormat) then - SrcFormat := ifA4R4G4B4; - if MasksEqual(Desc.PixelFormat, - GetFormatInfo(ifA1R5G5B5).PixelFormat) then - SrcFormat := ifA1R5G5B5; - end; - 32: - begin - SrcFormat := ifA8R8G8B8; - if BlueMask = $00FF0000 then - NeedsSwapChannels := True; - end; - end; - end - else - begin - // Handle RGB without alpha formats - case BitCount of - 8: - if MasksEqual(Desc.PixelFormat, - GetFormatInfo(ifR3G3B2).PixelFormat) then - SrcFormat := ifR3G3B2; - 16: - begin - if MasksEqual(Desc.PixelFormat, - GetFormatInfo(ifX4R4G4B4).PixelFormat) then - SrcFormat := ifX4R4G4B4; - if MasksEqual(Desc.PixelFormat, - GetFormatInfo(ifX1R5G5B5).PixelFormat) then - SrcFormat := ifX1R5G5B5; - if MasksEqual(Desc.PixelFormat, - GetFormatInfo(ifR5G6B5).PixelFormat) then - SrcFormat := ifR5G6B5; - end; - 24: SrcFormat := ifR8G8B8; - 32: - begin - SrcFormat := ifX8R8G8B8; - if BlueMask = $00FF0000 then - NeedsSwapChannels := True; - end; - end; - end; - end - else if (Flags and DDPF_LUMINANCE) = DDPF_LUMINANCE then - begin - // Handle luminance formats - if (Flags and DDPF_ALPHAPIXELS) = DDPF_ALPHAPIXELS then - begin - // Handle luminance with alpha formats - if BitCount = 16 then - SrcFormat := ifA8Gray8; - end - else - begin - // Handle luminance without alpha formats - case BitCount of - 8: SrcFormat := ifGray8; - 16: SrcFormat := ifGray16; - end; - end; - end - else if (Flags and DDPF_BUMPLUMINANCE) = DDPF_BUMPLUMINANCE then - begin - // Handle mixed bump-luminance formats like D3DFMT_X8L8V8U8 - case BitCount of - 32: - if BlueMask = $00FF0000 then - begin - SrcFormat := ifX8R8G8B8; // D3DFMT_X8L8V8U8 - NeedsSwapChannels := True; - end; - end; - end - else if (Flags and DDPF_BUMPDUDV) = DDPF_BUMPDUDV then - begin - // Handle bumpmap formats like D3DFMT_Q8W8V8U8 - case BitCount of - 16: SrcFormat := ifA8Gray8; // D3DFMT_V8U8 - 32: - if AlphaMask = $FF000000 then - begin - SrcFormat := ifA8R8G8B8; // D3DFMT_Q8W8V8U8 - NeedsSwapChannels := True; - end; - 64: SrcFormat := ifA16B16G16R16; // D3DFMT_Q16W16V16U16 - end; - end; - - // If DDS format is not supported we will exit - if SrcFormat = ifUnknown then Exit; - - // File contains mipmaps for each subimage. - { Some DDS writers ignore setting proper Caps and Flags so - this check is not usable: - if ((Desc.Caps.Caps1 and DDSCAPS_MIPMAP) = DDSCAPS_MIPMAP) and - ((Desc.Flags and DDSD_MIPMAPCOUNT) = DDSD_MIPMAPCOUNT) then} - if Desc.MipMaps > 1 then - begin - FLoadedMipMapCount := Desc.MipMaps; - ImageCount := Desc.MipMaps; - end; - - // File stores volume texture - if ((Desc.Caps.Caps2 and DDSCAPS2_VOLUME) = DDSCAPS2_VOLUME) and - ((Desc.Flags and DDSD_DEPTH) = DDSD_DEPTH) then - begin - FLoadedVolume := True; - FLoadedDepth := Desc.Depth; - ImageCount := GetVolumeLevelCount(Desc.Depth, ImageCount); - end; - - // File stores cube texture - if (Desc.Caps.Caps2 and DDSCAPS2_CUBEMAP) = DDSCAPS2_CUBEMAP then - begin - FLoadedCubeMap := True; - I := 0; - if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEX) = DDSCAPS2_POSITIVEX then Inc(I); - if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEY) = DDSCAPS2_POSITIVEY then Inc(I); - if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEZ) = DDSCAPS2_POSITIVEZ then Inc(I); - if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEX) = DDSCAPS2_NEGATIVEX then Inc(I); - if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEY) = DDSCAPS2_NEGATIVEY then Inc(I); - if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEZ) = DDSCAPS2_NEGATIVEZ then Inc(I); - FLoadedDepth := I; - ImageCount := ImageCount * I; - end; - - // Allocate and load all images in file - FmtInfo := GetFormatInfo(SrcFormat); - SetLength(Images, ImageCount); - - // Compute the pitch or get if from file if present - UseAsPitch := (Desc.Flags and DDSD_PITCH) = DDSD_PITCH; - UseAsLinear := (Desc.Flags and DDSD_LINEARSIZE) = DDSD_LINEARSIZE; - // Use linear as default if none is set - if not UseAsPitch and not UseAsLinear then - UseAsLinear := True; - // Main image pitch or linear size - PitchOrLinear := Desc.PitchOrLinearSize; - - for I := 0 to ImageCount - 1 do - begin - // Compute dimensions of surrent subimage based on texture type and - // number of mipmaps - ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth, - FloadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight); - NewImage(CurrentWidth, CurrentHeight, SrcFormat, Images[I]); - - if (I > 0) or (PitchOrLinear = 0) then - begin - // Compute pitch or linear size for mipmap levels, or even for main image - // since some formats do not fill pitch nor size - if UseAsLinear then - PitchOrLinear := FmtInfo.GetPixelsSize(SrcFormat, CurrentWidth, CurrentHeight) - else - PitchOrLinear := (CurrentWidth * FmtInfo.BytesPerPixel + 3) div 4 * 4; // must be DWORD aligned - end; - - if UseAsLinear then - LoadSize := PitchOrLinear - else - LoadSize := CurrentHeight * PitchOrLinear; - - if UseAsLinear or (LoadSize = Images[I].Size) then - begin - // If DDS does not use Pitch we can simply copy data - Read(Handle, Images[I].Bits, LoadSize) - end - else - begin - // If DDS uses Pitch we must load aligned scanlines - // and then remove padding - GetMem(Data, LoadSize); - try - Read(Handle, Data, LoadSize); - RemovePadBytes(Data, Images[I].Bits, CurrentWidth, CurrentHeight, - FmtInfo.BytesPerPixel, PitchOrLinear); - finally - FreeMem(Data); - end; - end; - - if NeedsSwapChannels then - SwapChannels(Images[I], ChannelRed, ChannelBlue); - end; - Result := True; - end; -end; - -function TDDSFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: LongInt): Boolean; -var - Hdr: TDDSFileHeader; - MainImage, ImageToSave: TImageData; - I, MainIdx, Len, ImageCount: LongInt; - J: LongWord; - FmtInfo: TImageFormatInfo; - MustBeFreed: Boolean; - Is2DTexture, IsCubeMap, IsVolume: Boolean; - MipMapCount, CurrentWidth, CurrentHeight: LongInt; - NeedsResize: Boolean; - NeedsConvert: Boolean; -begin - Result := False; - FillChar(Hdr, Sizeof(Hdr), 0); - - MainIdx := FFirstIdx; - Len := FLastIdx - MainIdx + 1; - // Some DDS saving rules: - // 2D textures: Len is used as mipmap count (FSaveMipMapCount not used!). - // Cube maps: FSaveDepth * FSaveMipMapCount images are used, if Len is - // smaller than this file is saved as regular 2D texture. - // Volume maps: GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount) images are - // used, if Len is smaller than this file is - // saved as regular 2D texture. - - IsCubeMap := FSaveCubeMap; - IsVolume := FSaveVolume; - MipMapCount := FSaveMipMapCount; - - if IsCubeMap then - begin - // Check if we have enough images on Input to save cube map - if Len < FSaveDepth * FSaveMipMapCount then - IsCubeMap := False; - end - else if IsVolume then - begin - // Check if we have enough images on Input to save volume texture - if Len < GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount) then - IsVolume := False; - end; - - Is2DTexture := not IsCubeMap and not IsVolume; - if Is2DTexture then - begin - // Get number of mipmaps used with 2D texture - MipMapCount := Min(Len, GetNumMipMapLevels(Images[MainIdx].Width, Images[MainIdx].Height)); - end; - - // we create compatible main image and fill headers - if MakeCompatible(Images[MainIdx], MainImage, MustBeFreed) then - with GetIO, MainImage, Hdr do - try - FmtInfo := GetFormatInfo(Format); - Magic := DDSMagic; - Desc.Size := SizeOf(Desc); - Desc.Width := Width; - Desc.Height := Height; - Desc.Flags := DDS_SAVE_FLAGS; - Desc.Caps.Caps1 := DDSCAPS_TEXTURE; - Desc.PixelFormat.Size := SizeOf(Desc.PixelFormat); - Desc.PitchOrLinearSize := MainImage.Size; - ImageCount := MipMapCount; - - if MipMapCount > 1 then - begin - // Set proper flags if we have some mipmaps to be saved - Desc.Flags := Desc.Flags or DDSD_MIPMAPCOUNT; - Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_MIPMAP or DDSCAPS_COMPLEX; - Desc.MipMaps := MipMapCount; - end; - - if IsCubeMap then - begin - // Set proper cube map flags - number of stored faces is taken - // from FSaveDepth - Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_COMPLEX; - Desc.Caps.Caps2 := Desc.Caps.Caps2 or DDSCAPS2_CUBEMAP; - J := DDSCAPS2_POSITIVEX; - for I := 0 to FSaveDepth - 1 do - begin - Desc.Caps.Caps2 := Desc.Caps.Caps2 or J; - J := J shl 1; - end; - ImageCount := FSaveDepth * FSaveMipMapCount; - end - else if IsVolume then - begin - // Set proper flags for volume texture - Desc.Flags := Desc.Flags or DDSD_DEPTH; - Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_COMPLEX; - Desc.Caps.Caps2 := Desc.Caps.Caps2 or DDSCAPS2_VOLUME; - Desc.Depth := FSaveDepth; - ImageCount := GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount); - end; - - // Now we set DDS pixel format for main image - if FmtInfo.IsSpecial or FmtInfo.IsFloatingPoint or - (FmtInfo.BytesPerPixel > 4) then - begin - Desc.PixelFormat.Flags := DDPF_FOURCC; - case Format of - ifA16B16G16R16: Desc.PixelFormat.FourCC := D3DFMT_A16B16G16R16; - ifR32F: Desc.PixelFormat.FourCC := D3DFMT_R32F; - ifA32B32G32R32F: Desc.PixelFormat.FourCC := D3DFMT_A32B32G32R32F; - ifR16F: Desc.PixelFormat.FourCC := D3DFMT_R16F; - ifA16B16G16R16F: Desc.PixelFormat.FourCC := D3DFMT_A16B16G16R16F; - ifDXT1: Desc.PixelFormat.FourCC := FOURCC_DXT1; - ifDXT3: Desc.PixelFormat.FourCC := FOURCC_DXT3; - ifDXT5: Desc.PixelFormat.FourCC := FOURCC_DXT5; - ifATI1N: Desc.PixelFormat.FourCC := FOURCC_ATI1; - ifATI2N: Desc.PixelFormat.FourCC := FOURCC_ATI2; - end; - end - else if FmtInfo.HasGrayChannel then - begin - Desc.PixelFormat.Flags := DDPF_LUMINANCE; - Desc.PixelFormat.BitCount := FmtInfo.BytesPerPixel * 8; - case Format of - ifGray8: Desc.PixelFormat.RedMask := 255; - ifGray16: Desc.PixelFormat.RedMask := 65535; - ifA8Gray8: - begin - Desc.PixelFormat.Flags := Desc.PixelFormat.Flags or DDPF_ALPHAPIXELS; - Desc.PixelFormat.RedMask := 255; - Desc.PixelFormat.AlphaMask := 65280; - end; - end; - end - else - begin - Desc.PixelFormat.Flags := DDPF_RGB; - Desc.PixelFormat.BitCount := FmtInfo.BytesPerPixel * 8; - if FmtInfo.HasAlphaChannel then - begin - Desc.PixelFormat.Flags := Desc.PixelFormat.Flags or DDPF_ALPHAPIXELS; - Desc.PixelFormat.AlphaMask := $FF000000; - end; - if FmtInfo.BytesPerPixel > 2 then - begin - Desc.PixelFormat.RedMask := $00FF0000; - Desc.PixelFormat.GreenMask := $0000FF00; - Desc.PixelFormat.BlueMask := $000000FF; - end - else - begin - Desc.PixelFormat.AlphaMask := FmtInfo.PixelFormat.ABitMask; - Desc.PixelFormat.RedMask := FmtInfo.PixelFormat.RBitMask; - Desc.PixelFormat.GreenMask := FmtInfo.PixelFormat.GBitMask; - Desc.PixelFormat.BlueMask := FmtInfo.PixelFormat.BBitMask; - end; - end; - - // Header and main image are written to output - Write(Handle, @Hdr, SizeOf(Hdr)); - Write(Handle, MainImage.Bits, MainImage.Size); - - // Write the rest of the images and convert them to - // the same format as main image if necessary and ensure proper mipmap - // simensions too. - for I := MainIdx + 1 to MainIdx + ImageCount - 1 do - begin - // Get proper dimensions for this level - ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth, - IsCubeMap, IsVolume, CurrentWidth, CurrentHeight); - - // Check if input image for this level has the right size and format - NeedsResize := not ((Images[I].Width = CurrentWidth) and (Images[I].Height = CurrentHeight)); - NeedsConvert := not (Images[I].Format = Format); - - if NeedsResize or NeedsConvert then - begin - // Input image must be resized or converted to different format - // to become valid mipmap level - InitImage(ImageToSave); - CloneImage(Images[I], ImageToSave); - if NeedsConvert then - ConvertImage(ImageToSave, Format); - if NeedsResize then - ResizeImage(ImageToSave, CurrentWidth, CurrentHeight, rfBilinear); - end - else - // Input image can be used without any changes - ImageToSave := Images[I]; - - // Write level data and release temp image if necessary - Write(Handle, ImageToSave.Bits, ImageToSave.Size); - if Images[I].Bits <> ImageToSave.Bits then - FreeImage(ImageToSave); - end; - - Result := True; - finally - if MustBeFreed then - FreeImage(MainImage); - end; -end; - -procedure TDDSFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -var - ConvFormat: TImageFormat; -begin - if Info.IsIndexed or Info.IsSpecial then - // convert indexed and unsupported special formatd to A8R8G8B8 - ConvFormat := ifA8R8G8B8 - else if Info.IsFloatingPoint then - begin - if Info.Format = ifA16R16G16B16F then - // only swap channels here - ConvFormat := ifA16B16G16R16F - else - // convert other floating point formats to A32B32G32R32F - ConvFormat := ifA32B32G32R32F - end - else if Info.HasGrayChannel then - begin - if Info.HasAlphaChannel then - // convert grayscale with alpha to A8Gray8 - ConvFormat := ifA8Gray8 - else if Info.BytesPerPixel = 1 then - // convert 8bit grayscale to Gray8 - ConvFormat := ifGray8 - else - // convert 16-64bit grayscales to Gray16 - ConvFormat := ifGray16; - end - else if Info.BytesPerPixel > 4 then - ConvFormat := ifA16B16G16R16 - else if Info.HasAlphaChannel then - // convert the other images with alpha channel to A8R8G8B8 - ConvFormat := ifA8R8G8B8 - else - // convert the other formats to X8R8G8B8 - ConvFormat := ifX8R8G8B8; - - ConvertImage(Image, ConvFormat); -end; - -function TDDSFileFormat.TestFormat(Handle: TImagingHandle): Boolean; -var - Hdr: TDDSFileHeader; - ReadCount: LongInt; -begin - Result := False; - if Handle <> nil then - with GetIO do - begin - ReadCount := Read(Handle, @Hdr, SizeOf(Hdr)); - Seek(Handle, -ReadCount, smFromCurrent); - Result := (Hdr.Magic = DDSMagic) and (ReadCount = SizeOf(Hdr)) and - ((Hdr.Desc.Caps.Caps1 and DDSCAPS_TEXTURE) = DDSCAPS_TEXTURE); - end; -end; - -initialization - RegisterImageFileFormat(TDDSFileFormat); - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.25.0 Changes/Bug Fixes --------------------------------- - - Added support for 3Dc ATI1/2 formats. - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Saved DDS with mipmaps now correctly defineds COMPLEX flag. - - Fixed loading of RGB DDS files that use pitch and have mipmaps - - mipmaps were loaded wrongly. - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Changed saving behaviour a bit: mipmaps are inlcuded automatically for - 2D textures if input image array has more than 1 image (no need to - set SaveMipMapCount manually). - - Mipmap levels are now saved with proper dimensions when saving DDS files. - - Made some changes to not be so strict when loading DDS files. - Many programs seem to save them in non-standard format - (by MS DDS File Reference). - - Added missing ifX8R8G8B8 to SupportedFormats, MakeCompatible failed - when image was converted to this format (inside). - - MakeCompatible method moved to base class, put ConvertToSupported here. - GetSupportedFormats removed, it is now set in constructor. - - Fixed bug that sometimes saved non-standard DDS files and another - one that caused crash when these files were loaded. - - Changed extensions to filename masks. - - Changed SaveData, LoadData, and MakeCompatible methods according - to changes in base class in Imaging unit. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - added support for half-float image formats - - change in LoadData to allow support for more images - in one stream loading - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - fixed bug in TestFormat which does not recognize many DDS files - - changed pitch/linearsize handling in DDS loading code to - load DDS files produced by NVidia's Photoshop plugin -} - -end. - +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains image format loader/saver for DirectDraw Surface images.} +unit ImagingDds; + +{$I ImagingOptions.inc} + +interface + +uses + ImagingTypes, Imaging, ImagingUtility, ImagingFormats; + +type + { Class for loading and saving Microsoft DirectDraw surfaces. + It can load/save all D3D formats which have corresponding + TImageFormat. It supports plain textures, cube textures and + volume textures, all of these can have mipmaps. It can also + load some formats which have no exact TImageFormat, but can be easily + converted to one (bump map formats, etc.). + You can get some information about last loaded DDS file by calling + GetOption with ImagingDDSLoadedXXX options and you can set some + saving options by calling SetOption with ImagingDDSSaveXXX or you can + simply use properties of this class. + Note that when saving cube maps and volumes input image array must contain + at least number of images to build cube/volume based on current + Depth and MipMapCount settings.} + TDDSFileFormat = class(TImageFileFormat) + private + FLoadedCubeMap: LongBool; + FLoadedVolume: LongBool; + FLoadedMipMapCount: LongInt; + FLoadedDepth: LongInt; + FSaveCubeMap: LongBool; + FSaveVolume: LongBool; + FSaveMipMapCount: LongInt; + FSaveDepth: LongInt; + procedure ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt; + IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt); + protected + procedure Define; override; + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean): Boolean; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + public + function TestFormat(Handle: TImagingHandle): Boolean; override; + procedure CheckOptionsValidity; override; + published + { True if last loaded DDS file was cube map.} + property LoadedCubeMap: LongBool read FLoadedCubeMap write FLoadedCubeMap; + { True if last loaded DDS file was volume texture.} + property LoadedVolume: LongBool read FLoadedVolume write FLoadedVolume; + { Number of mipmap levels of last loaded DDS image.} + property LoadedMipMapCount: LongInt read FLoadedMipMapCount write FLoadedMipMapCount; + { Depth (slices of volume texture or faces of cube map) of last loaded DDS image.} + property LoadedDepth: LongInt read FLoadedDepth write FLoadedDepth; + { True if next DDS file to be saved should be stored as cube map.} + property SaveCubeMap: LongBool read FSaveCubeMap write FSaveCubeMap; + { True if next DDS file to be saved should be stored as volume texture.} + property SaveVolume: LongBool read FSaveVolume write FSaveVolume; + { Sets the number of mipmaps which should be stored in the next saved DDS file. + Only applies to cube maps and volumes, ordinary 2D textures save all + levels present in input.} + property SaveMipMapCount: LongInt read FSaveMipMapCount write FSaveMipMapCount; + { Sets the depth (slices of volume texture or faces of cube map) + of the next saved DDS file.} + property SaveDepth: LongInt read FSaveDepth write FSaveDepth; + end; + +const + { DDS related metadata Ids } + + { DXGI format of textures stored in DDS files with DX10 extension. Type is + Enum (value corresponding to DXGI_FORMAT enum from DX SDK).} + SMetaDdsDxgiFormat = 'DdsDxgiFormat'; + { Number of mipmaps for each main image in DDS file.} + SMetaDdsMipMapCount = 'DdsMipMapCount'; + { Texture array size stored in DDS file (DX10 extension).} + SMetaDdsArraySize = 'DdsArraySize'; + +implementation + +const + SDDSFormatName = 'DirectDraw Surface'; + SDDSMasks = '*.dds'; + DDSSupportedFormats: TImageFormats = [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8, + ifA1R5G5B5, ifA4R4G4B4, ifX1R5G5B5, ifX4R4G4B4, ifR5G6B5, ifA16B16G16R16, + ifR32F, ifA32B32G32R32F, ifR16F, ifA16B16G16R16F, ifR3G3B2, ifGray8, ifA8Gray8, + ifGray16, ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N]; + +const + { Four character codes.} + DDSMagic = UInt32(Byte('D') or (Byte('D') shl 8) or (Byte('S') shl 16) or + (Byte(' ') shl 24)); + FOURCC_DXT1 = UInt32(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or + (Byte('1') shl 24)); + FOURCC_DXT3 = UInt32(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or + (Byte('3') shl 24)); + FOURCC_DXT5 = UInt32(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or + (Byte('5') shl 24)); + FOURCC_ATI1 = UInt32(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or + (Byte('1') shl 24)); + FOURCC_ATI2 = UInt32(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or + (Byte('2') shl 24)); + FOURCC_DX10 = UInt32(Byte('D') or (Byte('X') shl 8) or (Byte('1') shl 16) or + (Byte('0') shl 24)); + + { Some D3DFORMAT values used in DDS files as FourCC value.} + D3DFMT_A16B16G16R16 = 36; + D3DFMT_R32F = 114; + D3DFMT_A32B32G32R32F = 116; + D3DFMT_R16F = 111; + D3DFMT_A16B16G16R16F = 113; + + { Constants used by TDDSurfaceDesc2.Flags.} + DDSD_CAPS = $00000001; + DDSD_HEIGHT = $00000002; + DDSD_WIDTH = $00000004; + DDSD_PITCH = $00000008; + DDSD_PIXELFORMAT = $00001000; + DDSD_MIPMAPCOUNT = $00020000; + DDSD_LINEARSIZE = $00080000; + DDSD_DEPTH = $00800000; + + { Constants used by TDDSPixelFormat.Flags.} + DDPF_ALPHAPIXELS = $00000001; // used by formats which contain alpha + DDPF_FOURCC = $00000004; // used by DXT and large ARGB formats + DDPF_RGB = $00000040; // used by RGB formats + DDPF_LUMINANCE = $00020000; // used by formats like D3DFMT_L16 + DDPF_BUMPLUMINANCE = $00040000; // used by mixed signed-unsigned formats + DDPF_BUMPDUDV = $00080000; // used by signed formats + + { Constants used by TDDSCaps.Caps1.} + DDSCAPS_COMPLEX = $00000008; + DDSCAPS_TEXTURE = $00001000; + DDSCAPS_MIPMAP = $00400000; + + { Constants used by TDDSCaps.Caps2.} + DDSCAPS2_CUBEMAP = $00000200; + DDSCAPS2_POSITIVEX = $00000400; + DDSCAPS2_NEGATIVEX = $00000800; + DDSCAPS2_POSITIVEY = $00001000; + DDSCAPS2_NEGATIVEY = $00002000; + DDSCAPS2_POSITIVEZ = $00004000; + DDSCAPS2_NEGATIVEZ = $00008000; + DDSCAPS2_VOLUME = $00200000; + + { Flags for TDDSurfaceDesc2.Flags used when saving DDS file.} + DDS_SAVE_FLAGS = DDSD_CAPS or DDSD_PIXELFORMAT or DDSD_WIDTH or + DDSD_HEIGHT or DDSD_LINEARSIZE; + +type + { Stores the pixel format information.} + TDDPixelFormat = packed record + Size: UInt32; // Size of the structure = 32 bytes + Flags: UInt32; // Flags to indicate valid fields + FourCC: UInt32; // Four-char code for compressed textures (DXT) + BitCount: UInt32; // Bits per pixel if uncomp. usually 16,24 or 32 + RedMask: UInt32; // Bit mask for the Red component + GreenMask: UInt32; // Bit mask for the Green component + BlueMask: UInt32; // Bit mask for the Blue component + AlphaMask: UInt32; // Bit mask for the Alpha component + end; + + { Specifies capabilities of surface.} + TDDSCaps = packed record + Caps1: UInt32; // Should always include DDSCAPS_TEXTURE + Caps2: UInt32; // For cubic environment maps + Reserved: array[0..1] of UInt32; // Reserved + end; + + { Record describing DDS file contents.} + TDDSurfaceDesc2 = packed record + Size: UInt32; // Size of the structure = 124 Bytes + Flags: UInt32; // Flags to indicate valid fields + Height: UInt32; // Height of the main image in pixels + Width: UInt32; // Width of the main image in pixels + PitchOrLinearSize: UInt32; // For uncomp formats number of bytes per + // scanline. For comp it is the size in + // bytes of the main image + Depth: UInt32; // Only for volume text depth of the volume + MipMaps: Int32; // Total number of levels in the mipmap chain + Reserved1: array[0..10] of UInt32; // Reserved + PixelFormat: TDDPixelFormat; // Format of the pixel data + Caps: TDDSCaps; // Capabilities + Reserved2: UInt32; // Reserved + end; + + { DDS file header.} + TDDSFileHeader = packed record + Magic: UInt32; // File format magic + Desc: TDDSurfaceDesc2; // Surface description + end; + + { Resource types for D3D 10+ } + TD3D10ResourceDimension = ( + D3D10_RESOURCE_DIMENSION_UNKNOWN = 0, + D3D10_RESOURCE_DIMENSION_BUFFER = 1, + D3D10_RESOURCE_DIMENSION_TEXTURE1D = 2, + D3D10_RESOURCE_DIMENSION_TEXTURE2D = 3, + D3D10_RESOURCE_DIMENSION_TEXTURE3D = 4 + ); + + { Texture formats for D3D 10+ } + TDXGIFormat = ( + DXGI_FORMAT_UNKNOWN = 0, + DXGI_FORMAT_R32G32B32A32_TYPELESS = 1, + DXGI_FORMAT_R32G32B32A32_FLOAT = 2, + DXGI_FORMAT_R32G32B32A32_UINT = 3, + DXGI_FORMAT_R32G32B32A32_SINT = 4, + DXGI_FORMAT_R32G32B32_TYPELESS = 5, + DXGI_FORMAT_R32G32B32_FLOAT = 6, + DXGI_FORMAT_R32G32B32_UINT = 7, + DXGI_FORMAT_R32G32B32_SINT = 8, + DXGI_FORMAT_R16G16B16A16_TYPELESS = 9, + DXGI_FORMAT_R16G16B16A16_FLOAT = 10, + DXGI_FORMAT_R16G16B16A16_UNORM = 11, + DXGI_FORMAT_R16G16B16A16_UINT = 12, + DXGI_FORMAT_R16G16B16A16_SNORM = 13, + DXGI_FORMAT_R16G16B16A16_SINT = 14, + DXGI_FORMAT_R32G32_TYPELESS = 15, + DXGI_FORMAT_R32G32_FLOAT = 16, + DXGI_FORMAT_R32G32_UINT = 17, + DXGI_FORMAT_R32G32_SINT = 18, + DXGI_FORMAT_R32G8X24_TYPELESS = 19, + DXGI_FORMAT_D32_FLOAT_S8X24_UINT = 20, + DXGI_FORMAT_R32_FLOAT_X8X24_TYPELESS = 21, + DXGI_FORMAT_X32_TYPELESS_G8X24_UINT = 22, + DXGI_FORMAT_R10G10B10A2_TYPELESS = 23, + DXGI_FORMAT_R10G10B10A2_UNORM = 24, + DXGI_FORMAT_R10G10B10A2_UINT = 25, + DXGI_FORMAT_R11G11B10_FLOAT = 26, + DXGI_FORMAT_R8G8B8A8_TYPELESS = 27, + DXGI_FORMAT_R8G8B8A8_UNORM = 28, + DXGI_FORMAT_R8G8B8A8_UNORM_SRGB = 29, + DXGI_FORMAT_R8G8B8A8_UINT = 30, + DXGI_FORMAT_R8G8B8A8_SNORM = 31, + DXGI_FORMAT_R8G8B8A8_SINT = 32, + DXGI_FORMAT_R16G16_TYPELESS = 33, + DXGI_FORMAT_R16G16_FLOAT = 34, + DXGI_FORMAT_R16G16_UNORM = 35, + DXGI_FORMAT_R16G16_UINT = 36, + DXGI_FORMAT_R16G16_SNORM = 37, + DXGI_FORMAT_R16G16_SINT = 38, + DXGI_FORMAT_R32_TYPELESS = 39, + DXGI_FORMAT_D32_FLOAT = 40, + DXGI_FORMAT_R32_FLOAT = 41, + DXGI_FORMAT_R32_UINT = 42, + DXGI_FORMAT_R32_SINT = 43, + DXGI_FORMAT_R24G8_TYPELESS = 44, + DXGI_FORMAT_D24_UNORM_S8_UINT = 45, + DXGI_FORMAT_R24_UNORM_X8_TYPELESS = 46, + DXGI_FORMAT_X24_TYPELESS_G8_UINT = 47, + DXGI_FORMAT_R8G8_TYPELESS = 48, + DXGI_FORMAT_R8G8_UNORM = 49, + DXGI_FORMAT_R8G8_UINT = 50, + DXGI_FORMAT_R8G8_SNORM = 51, + DXGI_FORMAT_R8G8_SINT = 52, + DXGI_FORMAT_R16_TYPELESS = 53, + DXGI_FORMAT_R16_FLOAT = 54, + DXGI_FORMAT_D16_UNORM = 55, + DXGI_FORMAT_R16_UNORM = 56, + DXGI_FORMAT_R16_UINT = 57, + DXGI_FORMAT_R16_SNORM = 58, + DXGI_FORMAT_R16_SINT = 59, + DXGI_FORMAT_R8_TYPELESS = 60, + DXGI_FORMAT_R8_UNORM = 61, + DXGI_FORMAT_R8_UINT = 62, + DXGI_FORMAT_R8_SNORM = 63, + DXGI_FORMAT_R8_SINT = 64, + DXGI_FORMAT_A8_UNORM = 65, + DXGI_FORMAT_R1_UNORM = 66, + DXGI_FORMAT_R9G9B9E5_SHAREDEXP = 67, + DXGI_FORMAT_R8G8_B8G8_UNORM = 68, + DXGI_FORMAT_G8R8_G8B8_UNORM = 69, + DXGI_FORMAT_BC1_TYPELESS = 70, + DXGI_FORMAT_BC1_UNORM = 71, + DXGI_FORMAT_BC1_UNORM_SRGB = 72, + DXGI_FORMAT_BC2_TYPELESS = 73, + DXGI_FORMAT_BC2_UNORM = 74, + DXGI_FORMAT_BC2_UNORM_SRGB = 75, + DXGI_FORMAT_BC3_TYPELESS = 76, + DXGI_FORMAT_BC3_UNORM = 77, + DXGI_FORMAT_BC3_UNORM_SRGB = 78, + DXGI_FORMAT_BC4_TYPELESS = 79, + DXGI_FORMAT_BC4_UNORM = 80, + DXGI_FORMAT_BC4_SNORM = 81, + DXGI_FORMAT_BC5_TYPELESS = 82, + DXGI_FORMAT_BC5_UNORM = 83, + DXGI_FORMAT_BC5_SNORM = 84, + DXGI_FORMAT_B5G6R5_UNORM = 85, + DXGI_FORMAT_B5G5R5A1_UNORM = 86, + DXGI_FORMAT_B8G8R8A8_UNORM = 87, + DXGI_FORMAT_B8G8R8X8_UNORM = 88, + DXGI_FORMAT_R10G10B10_XR_BIAS_A2_UNORM = 89, + DXGI_FORMAT_B8G8R8A8_TYPELESS = 90, + DXGI_FORMAT_B8G8R8A8_UNORM_SRGB = 91, + DXGI_FORMAT_B8G8R8X8_TYPELESS = 92, + DXGI_FORMAT_B8G8R8X8_UNORM_SRGB = 93, + DXGI_FORMAT_BC6H_TYPELESS = 94, + DXGI_FORMAT_BC6H_UF16 = 95, + DXGI_FORMAT_BC6H_SF16 = 96, + DXGI_FORMAT_BC7_TYPELESS = 97, + DXGI_FORMAT_BC7_UNORM = 98, + DXGI_FORMAT_BC7_UNORM_SRGB = 99, + DXGI_FORMAT_AYUV = 100, + DXGI_FORMAT_Y410 = 101, + DXGI_FORMAT_Y416 = 102, + DXGI_FORMAT_NV12 = 103, + DXGI_FORMAT_P010 = 104, + DXGI_FORMAT_P016 = 105, + DXGI_FORMAT_420_OPAQUE = 106, + DXGI_FORMAT_YUY2 = 107, + DXGI_FORMAT_Y210 = 108, + DXGI_FORMAT_Y216 = 109, + DXGI_FORMAT_NV11 = 110, + DXGI_FORMAT_AI44 = 111, + DXGI_FORMAT_IA44 = 112, + DXGI_FORMAT_P8 = 113, + DXGI_FORMAT_A8P8 = 114, + DXGI_FORMAT_B4G4R4A4_UNORM = 115 + ); + + { DX10 extension header for DDS file format } + TDX10Header = packed record + DXGIFormat: TDXGIFormat; + ResourceDimension: TD3D10ResourceDimension; + MiscFlags: UInt32; + ArraySize: UInt32; + Reserved: UInt32; + end; + +{ TDDSFileFormat class implementation } + +procedure TDDSFileFormat.Define; +begin + inherited; + FName := SDDSFormatName; + FFeatures := [ffLoad, ffSave, ffMultiImage]; + FSupportedFormats := DDSSupportedFormats; + + FSaveCubeMap := False; + FSaveVolume := False; + FSaveMipMapCount := 1; + FSaveDepth := 1; + + AddMasks(SDDSMasks); + + RegisterOption(ImagingDDSLoadedCubeMap, @FLoadedCubeMap); + RegisterOption(ImagingDDSLoadedVolume, @FLoadedVolume); + RegisterOption(ImagingDDSLoadedMipMapCount, @FLoadedMipMapCount); + RegisterOption(ImagingDDSLoadedDepth, @FLoadedDepth); + RegisterOption(ImagingDDSSaveCubeMap, @FSaveCubeMap); + RegisterOption(ImagingDDSSaveVolume, @FSaveVolume); + RegisterOption(ImagingDDSSaveMipMapCount, @FSaveMipMapCount); + RegisterOption(ImagingDDSSaveDepth, @FSaveDepth); +end; + +procedure TDDSFileFormat.CheckOptionsValidity; +begin + if FSaveCubeMap then + FSaveVolume := False; + if FSaveVolume then + FSaveCubeMap := False; + if FSaveDepth < 1 then + FSaveDepth := 1; + if FSaveMipMapCount < 1 then + FSaveMipMapCount := 1; +end; + +procedure TDDSFileFormat.ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt; + IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt); +var + I, Last, Shift: LongInt; +begin + CurWidth := Width; + CurHeight := Height; + if MipMaps > 1 then + begin + if not IsVolume then + begin + if IsCubeMap then + begin + // Cube maps are stored like this + // Face 0 mipmap 0 + // Face 0 mipmap 1 + // ... + // Face 1 mipmap 0 + // Face 1 mipmap 1 + // ... + + // Modify index so later in for loop we iterate less times + Idx := Idx - ((Idx div MipMaps) * MipMaps); + end; + for I := 0 to Idx - 1 do + begin + CurWidth := ClampInt(CurWidth shr 1, 1, CurWidth); + CurHeight := ClampInt(CurHeight shr 1, 1, CurHeight); + end; + end + else + begin + // Volume textures are stored in DDS files like this: + // Slice 0 mipmap 0 + // Slice 1 mipmap 0 + // Slice 2 mipmap 0 + // Slice 3 mipmap 0 + // Slice 0 mipmap 1 + // Slice 1 mipmap 1 + // Slice 0 mipmap 2 + // Slice 0 mipmap 3 ... + Shift := 0; + Last := Depth; + while Idx > Last - 1 do + begin + CurWidth := ClampInt(CurWidth shr 1, 1, CurWidth); + CurHeight := ClampInt(CurHeight shr 1, 1, CurHeight); + if (CurWidth = 1) and (CurHeight = 1) then + Break; + Inc(Shift); + Inc(Last, ClampInt(Depth shr Shift, 1, Depth)); + end; + end; + end; +end; + +function TDDSFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + Hdr: TDDSFileHeader; + HdrDX10: TDX10Header; + SrcFormat: TImageFormat; + FmtInfo: TImageFormatInfo; + NeedsSwapChannels: Boolean; + CurrentWidth, CurrentHeight, ImageCount, LoadSize, I, + PitchOrLinear, MainImageLinearSize: LongInt; + Data: PByte; + UseAsPitch: Boolean; + UseAsLinear: Boolean; + + function MasksEqual(const DDPF: TDDPixelFormat; PF: PPixelFormatInfo): Boolean; + begin + Result := (DDPF.AlphaMask = PF.ABitMask) and + (DDPF.RedMask = PF.RBitMask) and (DDPF.GreenMask = PF.GBitMask) and + (DDPF.BlueMask = PF.BBitMask); + end; + + function FindFourCCFormat(FourCC: UInt32): TImageFormat; + begin + // Handle FourCC and large ARGB formats + case FourCC of + D3DFMT_A16B16G16R16: Result := ifA16B16G16R16; + D3DFMT_R32F: Result := ifR32F; + D3DFMT_A32B32G32R32F: Result := ifA32B32G32R32F; + D3DFMT_R16F: Result := ifR16F; + D3DFMT_A16B16G16R16F: Result := ifA16B16G16R16F; + FOURCC_DXT1: Result := ifDXT1; + FOURCC_DXT3: Result := ifDXT3; + FOURCC_DXT5: Result := ifDXT5; + FOURCC_ATI1: Result := ifATI1N; + FOURCC_ATI2: Result := ifATI2N; + else + Result := ifUnknown; + end; + end; + + function FindDX10Format(DXGIFormat: TDXGIFormat; var NeedsSwapChannels: Boolean): TImageFormat; + begin + Result := ifUnknown; + NeedsSwapChannels := False; + + case DXGIFormat of + DXGI_FORMAT_UNKNOWN: ; + DXGI_FORMAT_R32G32B32A32_TYPELESS, DXGI_FORMAT_R32G32B32A32_FLOAT: + Result := ifA32B32G32R32F; + DXGI_FORMAT_R32G32B32A32_UINT: ; + DXGI_FORMAT_R32G32B32A32_SINT: ; + DXGI_FORMAT_R32G32B32_TYPELESS, DXGI_FORMAT_R32G32B32_FLOAT: + Result := ifB32G32R32F; + DXGI_FORMAT_R32G32B32_UINT: ; + DXGI_FORMAT_R32G32B32_SINT: ; + DXGI_FORMAT_R16G16B16A16_FLOAT: + Result := ifA16B16G16R16F; + DXGI_FORMAT_R16G16B16A16_TYPELESS, DXGI_FORMAT_R16G16B16A16_UNORM, + DXGI_FORMAT_R16G16B16A16_UINT, DXGI_FORMAT_R16G16B16A16_SNORM, + DXGI_FORMAT_R16G16B16A16_SINT: + Result := ifA16B16G16R16; + DXGI_FORMAT_R32G32_TYPELESS: ; + DXGI_FORMAT_R32G32_FLOAT: ; + DXGI_FORMAT_R32G32_UINT: ; + DXGI_FORMAT_R32G32_SINT: ; + DXGI_FORMAT_R32G8X24_TYPELESS: ; + DXGI_FORMAT_D32_FLOAT_S8X24_UINT: ; + DXGI_FORMAT_R32_FLOAT_X8X24_TYPELESS: ; + DXGI_FORMAT_X32_TYPELESS_G8X24_UINT: ; + DXGI_FORMAT_R10G10B10A2_TYPELESS: ; + DXGI_FORMAT_R10G10B10A2_UNORM: ; + DXGI_FORMAT_R10G10B10A2_UINT: ; + DXGI_FORMAT_R11G11B10_FLOAT: ; + DXGI_FORMAT_R8G8B8A8_TYPELESS, DXGI_FORMAT_R8G8B8A8_UNORM, + DXGI_FORMAT_R8G8B8A8_UINT, DXGI_FORMAT_R8G8B8A8_SNORM,DXGI_FORMAT_R8G8B8A8_SINT, + DXGI_FORMAT_R8G8B8A8_UNORM_SRGB: + begin + Result := ifA8R8G8B8; + NeedsSwapChannels := True; + end; + DXGI_FORMAT_R16G16_TYPELESS: ; + DXGI_FORMAT_R16G16_FLOAT: ; + DXGI_FORMAT_R16G16_UNORM: ; + DXGI_FORMAT_R16G16_UINT: ; + DXGI_FORMAT_R16G16_SNORM: ; + DXGI_FORMAT_R16G16_SINT: ; + DXGI_FORMAT_R32_TYPELESS, DXGI_FORMAT_R32_UINT, DXGI_FORMAT_R32_SINT: + Result := ifGray32; + DXGI_FORMAT_D32_FLOAT, DXGI_FORMAT_R32_FLOAT: + Result := ifR32F; + DXGI_FORMAT_R24G8_TYPELESS: ; + DXGI_FORMAT_D24_UNORM_S8_UINT: ; + DXGI_FORMAT_R24_UNORM_X8_TYPELESS: ; + DXGI_FORMAT_X24_TYPELESS_G8_UINT: ; + DXGI_FORMAT_R8G8_TYPELESS, DXGI_FORMAT_R8G8_UNORM, DXGI_FORMAT_R8G8_UINT, + DXGI_FORMAT_R8G8_SNORM, DXGI_FORMAT_R8G8_SINT: + Result := ifA8Gray8; + DXGI_FORMAT_R16_TYPELESS, DXGI_FORMAT_D16_UNORM, DXGI_FORMAT_R16_UNORM, + DXGI_FORMAT_R16_UINT, DXGI_FORMAT_R16_SNORM, DXGI_FORMAT_R16_SINT: + Result := ifGray16; + DXGI_FORMAT_R16_FLOAT: + Result := ifR16F; + DXGI_FORMAT_R8_TYPELESS, DXGI_FORMAT_R8_UNORM, DXGI_FORMAT_R8_UINT, + DXGI_FORMAT_R8_SNORM, DXGI_FORMAT_R8_SINT, DXGI_FORMAT_A8_UNORM: + Result := ifGray8; + DXGI_FORMAT_R1_UNORM: ; + DXGI_FORMAT_R9G9B9E5_SHAREDEXP: ; + DXGI_FORMAT_R8G8_B8G8_UNORM: ; + DXGI_FORMAT_G8R8_G8B8_UNORM: ; + DXGI_FORMAT_BC1_TYPELESS, DXGI_FORMAT_BC1_UNORM, DXGI_FORMAT_BC1_UNORM_SRGB: + Result := ifDXT1; + DXGI_FORMAT_BC2_TYPELESS, DXGI_FORMAT_BC2_UNORM, DXGI_FORMAT_BC2_UNORM_SRGB: + Result := ifDXT3; + DXGI_FORMAT_BC3_TYPELESS, DXGI_FORMAT_BC3_UNORM, DXGI_FORMAT_BC3_UNORM_SRGB: + Result := ifDXT5; + DXGI_FORMAT_BC4_TYPELESS, DXGI_FORMAT_BC4_UNORM, DXGI_FORMAT_BC4_SNORM: + Result := ifATI1N; + DXGI_FORMAT_BC5_TYPELESS, DXGI_FORMAT_BC5_UNORM, DXGI_FORMAT_BC5_SNORM: + Result := ifATI2N; + DXGI_FORMAT_B5G6R5_UNORM: + Result := ifR5G6B5; + DXGI_FORMAT_B5G5R5A1_UNORM: + Result := ifA1R5G5B5; + DXGI_FORMAT_B8G8R8A8_UNORM, DXGI_FORMAT_B8G8R8A8_TYPELESS: + Result := ifA8R8G8B8; + DXGI_FORMAT_B8G8R8X8_UNORM, DXGI_FORMAT_B8G8R8X8_TYPELESS: + Result := ifX8R8G8B8; + DXGI_FORMAT_R10G10B10_XR_BIAS_A2_UNORM: ; + DXGI_FORMAT_B8G8R8A8_UNORM_SRGB: ; + DXGI_FORMAT_B8G8R8X8_UNORM_SRGB: ; + DXGI_FORMAT_BC6H_TYPELESS: ; + DXGI_FORMAT_BC6H_UF16: ; + DXGI_FORMAT_BC6H_SF16: ; + DXGI_FORMAT_BC7_TYPELESS: ; + DXGI_FORMAT_BC7_UNORM: ; + DXGI_FORMAT_BC7_UNORM_SRGB: ; + DXGI_FORMAT_P8: ; + DXGI_FORMAT_A8P8: ; + DXGI_FORMAT_B4G4R4A4_UNORM: + Result := ifA4R4G4B4; + end; + end; + +begin + Result := False; + ImageCount := 1; + FLoadedMipMapCount := 1; + FLoadedDepth := 1; + FLoadedVolume := False; + FLoadedCubeMap := False; + ZeroMemory(@HdrDX10, SizeOf(HdrDX10)); + + with GetIO, Hdr, Hdr.Desc.PixelFormat do + begin + Read(Handle, @Hdr, SizeOf(Hdr)); + + SrcFormat := ifUnknown; + NeedsSwapChannels := False; + + // Get image data format + if (Flags and DDPF_FOURCC) = DDPF_FOURCC then + begin + if FourCC = FOURCC_DX10 then + begin + Read(Handle, @HdrDX10, SizeOf(HdrDX10)); + SrcFormat := FindDX10Format(HdrDX10.DXGIFormat, NeedsSwapChannels); + FMetadata.SetMetaItem(SMetaDdsDxgiFormat, HdrDX10.DXGIFormat); + FMetadata.SetMetaItem(SMetaDdsArraySize, HdrDX10.ArraySize); + end + else + SrcFormat := FindFourCCFormat(FourCC); + end + else if (Flags and DDPF_RGB) = DDPF_RGB then + begin + // Handle RGB formats + if (Flags and DDPF_ALPHAPIXELS) = DDPF_ALPHAPIXELS then + begin + // Handle RGB with alpha formats + case BitCount of + 16: + begin + if MasksEqual(Desc.PixelFormat, GetFormatInfo(ifA4R4G4B4).PixelFormat) then + SrcFormat := ifA4R4G4B4; + if MasksEqual(Desc.PixelFormat, GetFormatInfo(ifA1R5G5B5).PixelFormat) then + SrcFormat := ifA1R5G5B5; + end; + 32: + begin + SrcFormat := ifA8R8G8B8; + if BlueMask = $00FF0000 then + NeedsSwapChannels := True; + end; + end; + end + else + begin + // Handle RGB without alpha formats + case BitCount of + 8: + if MasksEqual(Desc.PixelFormat, + GetFormatInfo(ifR3G3B2).PixelFormat) then + SrcFormat := ifR3G3B2; + 16: + begin + if MasksEqual(Desc.PixelFormat, + GetFormatInfo(ifX4R4G4B4).PixelFormat) then + SrcFormat := ifX4R4G4B4; + if MasksEqual(Desc.PixelFormat, + GetFormatInfo(ifX1R5G5B5).PixelFormat) then + SrcFormat := ifX1R5G5B5; + if MasksEqual(Desc.PixelFormat, + GetFormatInfo(ifR5G6B5).PixelFormat) then + SrcFormat := ifR5G6B5; + end; + 24: SrcFormat := ifR8G8B8; + 32: + begin + SrcFormat := ifX8R8G8B8; + if BlueMask = $00FF0000 then + NeedsSwapChannels := True; + end; + end; + end; + end + else if (Flags and DDPF_LUMINANCE) = DDPF_LUMINANCE then + begin + // Handle luminance formats + if (Flags and DDPF_ALPHAPIXELS) = DDPF_ALPHAPIXELS then + begin + // Handle luminance with alpha formats + if BitCount = 16 then + SrcFormat := ifA8Gray8; + end + else + begin + // Handle luminance without alpha formats + case BitCount of + 8: SrcFormat := ifGray8; + 16: SrcFormat := ifGray16; + end; + end; + end + else if (Flags and DDPF_BUMPLUMINANCE) = DDPF_BUMPLUMINANCE then + begin + // Handle mixed bump-luminance formats like D3DFMT_X8L8V8U8 + case BitCount of + 32: + if BlueMask = $00FF0000 then + begin + SrcFormat := ifX8R8G8B8; // D3DFMT_X8L8V8U8 + NeedsSwapChannels := True; + end; + end; + end + else if (Flags and DDPF_BUMPDUDV) = DDPF_BUMPDUDV then + begin + // Handle bumpmap formats like D3DFMT_Q8W8V8U8 + case BitCount of + 16: SrcFormat := ifA8Gray8; // D3DFMT_V8U8 + 32: + if AlphaMask = $FF000000 then + begin + SrcFormat := ifA8R8G8B8; // D3DFMT_Q8W8V8U8 + NeedsSwapChannels := True; + end; + 64: SrcFormat := ifA16B16G16R16; // D3DFMT_Q16W16V16U16 + end; + end; + + // If DDS format is not supported we will exit + if SrcFormat = ifUnknown then + Exit; + + // File contains mipmaps for each subimage. + { Some DDS writers ignore setting proper Caps and Flags so + this check is not usable: + if ((Desc.Caps.Caps1 and DDSCAPS_MIPMAP) = DDSCAPS_MIPMAP) and + ((Desc.Flags and DDSD_MIPMAPCOUNT) = DDSD_MIPMAPCOUNT) then} + if Desc.MipMaps > 1 then + begin + FLoadedMipMapCount := Desc.MipMaps; + FMetadata.SetMetaItem(SMetaDdsMipMapCount, Desc.MipMaps); + ImageCount := Desc.MipMaps; + end; + + // File stores volume texture + if ((Desc.Caps.Caps2 and DDSCAPS2_VOLUME) = DDSCAPS2_VOLUME) and + ((Desc.Flags and DDSD_DEPTH) = DDSD_DEPTH) then + begin + FLoadedVolume := True; + FLoadedDepth := Desc.Depth; + ImageCount := GetVolumeLevelCount(Desc.Depth, ImageCount); + end; + + // File stores cube texture + if (Desc.Caps.Caps2 and DDSCAPS2_CUBEMAP) = DDSCAPS2_CUBEMAP then + begin + FLoadedCubeMap := True; + I := 0; + if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEX) = DDSCAPS2_POSITIVEX then Inc(I); + if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEY) = DDSCAPS2_POSITIVEY then Inc(I); + if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEZ) = DDSCAPS2_POSITIVEZ then Inc(I); + if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEX) = DDSCAPS2_NEGATIVEX then Inc(I); + if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEY) = DDSCAPS2_NEGATIVEY then Inc(I); + if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEZ) = DDSCAPS2_NEGATIVEZ then Inc(I); + FLoadedDepth := I; + ImageCount := ImageCount * I; + end; + + // Allocate and load all images in file + FmtInfo := GetFormatInfo(SrcFormat); + SetLength(Images, ImageCount); + + // Compute the pitch or get if from file if present + UseAsPitch := (Desc.Flags and DDSD_PITCH) = DDSD_PITCH; + UseAsLinear := (Desc.Flags and DDSD_LINEARSIZE) = DDSD_LINEARSIZE; + // Use linear as default if none is set + if not UseAsPitch and not UseAsLinear then + UseAsLinear := True; + // Main image pitch or linear size + PitchOrLinear := Desc.PitchOrLinearSize; + + // Check: some writers just write garbage to pitch/linear size fields and flags + MainImageLinearSize := FmtInfo.GetPixelsSize(SrcFormat, Desc.Width, Desc.Height); + if UseAsLinear and ((PitchOrLinear < MainImageLinearSize) or + (PitchOrLinear * Integer(Desc.Height) = MainImageLinearSize)) then + begin + // Explicitly set linear size + PitchOrLinear := MainImageLinearSize; + end; + + for I := 0 to ImageCount - 1 do + begin + // Compute dimensions of surrent subimage based on texture type and + // number of mipmaps + ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth, + FLoadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight); + NewImage(CurrentWidth, CurrentHeight, SrcFormat, Images[I]); + + if (I > 0) or (PitchOrLinear = 0) then + begin + // Compute pitch or linear size for mipmap levels, or even for main image + // since some formats do not fill pitch nor size + if UseAsLinear then + PitchOrLinear := FmtInfo.GetPixelsSize(SrcFormat, CurrentWidth, CurrentHeight) + else + PitchOrLinear := (CurrentWidth * FmtInfo.BytesPerPixel + 3) div 4 * 4; // must be DWORD aligned + end; + + if UseAsLinear then + LoadSize := PitchOrLinear + else + LoadSize := CurrentHeight * PitchOrLinear; + + if UseAsLinear or (LoadSize = Images[I].Size) then + begin + // If DDS does not use Pitch we can simply copy data + Read(Handle, Images[I].Bits, LoadSize) + end + else + begin + // If DDS uses Pitch we must load aligned scanlines + // and then remove padding + GetMem(Data, LoadSize); + try + Read(Handle, Data, LoadSize); + RemovePadBytes(Data, Images[I].Bits, CurrentWidth, CurrentHeight, + FmtInfo.BytesPerPixel, PitchOrLinear); + finally + FreeMem(Data); + end; + end; + + if NeedsSwapChannels then + SwapChannels(Images[I], ChannelRed, ChannelBlue); + end; + Result := True; + end; +end; + +function TDDSFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + Hdr: TDDSFileHeader; + MainImage, ImageToSave: TImageData; + I, MainIdx, Len, ImageCount: LongInt; + J: UInt32; + FmtInfo: TImageFormatInfo; + MustBeFreed: Boolean; + Is2DTexture, IsCubeMap, IsVolume: Boolean; + MipMapCount, CurrentWidth, CurrentHeight: LongInt; + NeedsResize: Boolean; + NeedsConvert: Boolean; +begin + Result := False; + FillChar(Hdr, Sizeof(Hdr), 0); + + MainIdx := FFirstIdx; + Len := FLastIdx - MainIdx + 1; + // Some DDS saving rules: + // 2D textures: Len is used as mipmap count (FSaveMipMapCount not used!). + // Cube maps: FSaveDepth * FSaveMipMapCount images are used, if Len is + // smaller than this file is saved as regular 2D texture. + // Volume maps: GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount) images are + // used, if Len is smaller than this file is + // saved as regular 2D texture. + + IsCubeMap := FSaveCubeMap; + IsVolume := FSaveVolume; + MipMapCount := FSaveMipMapCount; + + if IsCubeMap then + begin + // Check if we have enough images on Input to save cube map + if Len < FSaveDepth * FSaveMipMapCount then + IsCubeMap := False; + end + else if IsVolume then + begin + // Check if we have enough images on Input to save volume texture + if Len < GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount) then + IsVolume := False; + end; + + Is2DTexture := not IsCubeMap and not IsVolume; + if Is2DTexture then + begin + // Get number of mipmaps used with 2D texture + MipMapCount := Min(Len, GetNumMipMapLevels(Images[MainIdx].Width, Images[MainIdx].Height)); + end; + + // we create compatible main image and fill headers + if MakeCompatible(Images[MainIdx], MainImage, MustBeFreed) then + with GetIO, MainImage, Hdr do + try + FmtInfo := GetFormatInfo(Format); + Magic := DDSMagic; + Desc.Size := SizeOf(Desc); + Desc.Width := Width; + Desc.Height := Height; + Desc.Flags := DDS_SAVE_FLAGS; + Desc.Caps.Caps1 := DDSCAPS_TEXTURE; + Desc.PixelFormat.Size := SizeOf(Desc.PixelFormat); + Desc.PitchOrLinearSize := MainImage.Size; + ImageCount := MipMapCount; + + if MipMapCount > 1 then + begin + // Set proper flags if we have some mipmaps to be saved + Desc.Flags := Desc.Flags or DDSD_MIPMAPCOUNT; + Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_MIPMAP or DDSCAPS_COMPLEX; + Desc.MipMaps := MipMapCount; + end; + + if IsCubeMap then + begin + // Set proper cube map flags - number of stored faces is taken + // from FSaveDepth + Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_COMPLEX; + Desc.Caps.Caps2 := Desc.Caps.Caps2 or DDSCAPS2_CUBEMAP; + J := DDSCAPS2_POSITIVEX; + for I := 0 to FSaveDepth - 1 do + begin + Desc.Caps.Caps2 := Desc.Caps.Caps2 or J; + J := J shl 1; + end; + ImageCount := FSaveDepth * FSaveMipMapCount; + end + else if IsVolume then + begin + // Set proper flags for volume texture + Desc.Flags := Desc.Flags or DDSD_DEPTH; + Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_COMPLEX; + Desc.Caps.Caps2 := Desc.Caps.Caps2 or DDSCAPS2_VOLUME; + Desc.Depth := FSaveDepth; + ImageCount := GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount); + end; + + // Now we set DDS pixel format for main image + if FmtInfo.IsSpecial or FmtInfo.IsFloatingPoint or + (FmtInfo.BytesPerPixel > 4) then + begin + Desc.PixelFormat.Flags := DDPF_FOURCC; + case Format of + ifA16B16G16R16: Desc.PixelFormat.FourCC := D3DFMT_A16B16G16R16; + ifR32F: Desc.PixelFormat.FourCC := D3DFMT_R32F; + ifA32B32G32R32F: Desc.PixelFormat.FourCC := D3DFMT_A32B32G32R32F; + ifR16F: Desc.PixelFormat.FourCC := D3DFMT_R16F; + ifA16B16G16R16F: Desc.PixelFormat.FourCC := D3DFMT_A16B16G16R16F; + ifDXT1: Desc.PixelFormat.FourCC := FOURCC_DXT1; + ifDXT3: Desc.PixelFormat.FourCC := FOURCC_DXT3; + ifDXT5: Desc.PixelFormat.FourCC := FOURCC_DXT5; + ifATI1N: Desc.PixelFormat.FourCC := FOURCC_ATI1; + ifATI2N: Desc.PixelFormat.FourCC := FOURCC_ATI2; + end; + end + else if FmtInfo.HasGrayChannel then + begin + Desc.PixelFormat.Flags := DDPF_LUMINANCE; + Desc.PixelFormat.BitCount := FmtInfo.BytesPerPixel * 8; + case Format of + ifGray8: Desc.PixelFormat.RedMask := 255; + ifGray16: Desc.PixelFormat.RedMask := 65535; + ifA8Gray8: + begin + Desc.PixelFormat.Flags := Desc.PixelFormat.Flags or DDPF_ALPHAPIXELS; + Desc.PixelFormat.RedMask := 255; + Desc.PixelFormat.AlphaMask := 65280; + end; + end; + end + else + begin + Desc.PixelFormat.Flags := DDPF_RGB; + Desc.PixelFormat.BitCount := FmtInfo.BytesPerPixel * 8; + if FmtInfo.HasAlphaChannel then + begin + Desc.PixelFormat.Flags := Desc.PixelFormat.Flags or DDPF_ALPHAPIXELS; + Desc.PixelFormat.AlphaMask := $FF000000; + end; + if FmtInfo.BytesPerPixel > 2 then + begin + Desc.PixelFormat.RedMask := $00FF0000; + Desc.PixelFormat.GreenMask := $0000FF00; + Desc.PixelFormat.BlueMask := $000000FF; + end + else + begin + Desc.PixelFormat.AlphaMask := FmtInfo.PixelFormat.ABitMask; + Desc.PixelFormat.RedMask := FmtInfo.PixelFormat.RBitMask; + Desc.PixelFormat.GreenMask := FmtInfo.PixelFormat.GBitMask; + Desc.PixelFormat.BlueMask := FmtInfo.PixelFormat.BBitMask; + end; + end; + + // Header and main image are written to output + Write(Handle, @Hdr, SizeOf(Hdr)); + Write(Handle, MainImage.Bits, MainImage.Size); + + // Write the rest of the images and convert them to + // the same format as main image if necessary and ensure proper mipmap + // simensions too. + for I := MainIdx + 1 to MainIdx + ImageCount - 1 do + begin + // Get proper dimensions for this level + ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth, + IsCubeMap, IsVolume, CurrentWidth, CurrentHeight); + + // Check if input image for this level has the right size and format + NeedsResize := not ((Images[I].Width = CurrentWidth) and (Images[I].Height = CurrentHeight)); + NeedsConvert := not (Images[I].Format = Format); + + if NeedsResize or NeedsConvert then + begin + // Input image must be resized or converted to different format + // to become valid mipmap level + InitImage(ImageToSave); + CloneImage(Images[I], ImageToSave); + if NeedsConvert then + ConvertImage(ImageToSave, Format); + if NeedsResize then + ResizeImage(ImageToSave, CurrentWidth, CurrentHeight, rfBilinear); + end + else + // Input image can be used without any changes + ImageToSave := Images[I]; + + // Write level data and release temp image if necessary + Write(Handle, ImageToSave.Bits, ImageToSave.Size); + if Images[I].Bits <> ImageToSave.Bits then + FreeImage(ImageToSave); + end; + + Result := True; + finally + if MustBeFreed then + FreeImage(MainImage); + end; +end; + +procedure TDDSFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +var + ConvFormat: TImageFormat; +begin + if Info.IsIndexed or Info.IsSpecial then + // convert indexed and unsupported special formatd to A8R8G8B8 + ConvFormat := ifA8R8G8B8 + else if Info.IsFloatingPoint then + begin + if Info.Format = ifA16R16G16B16F then + // only swap channels here + ConvFormat := ifA16B16G16R16F + else + // convert other floating point formats to A32B32G32R32F + ConvFormat := ifA32B32G32R32F + end + else if Info.HasGrayChannel then + begin + if Info.HasAlphaChannel then + // convert grayscale with alpha to A8Gray8 + ConvFormat := ifA8Gray8 + else if Info.BytesPerPixel = 1 then + // convert 8bit grayscale to Gray8 + ConvFormat := ifGray8 + else + // convert 16-64bit grayscales to Gray16 + ConvFormat := ifGray16; + end + else if Info.BytesPerPixel > 4 then + ConvFormat := ifA16B16G16R16 + else if Info.HasAlphaChannel then + // convert the other images with alpha channel to A8R8G8B8 + ConvFormat := ifA8R8G8B8 + else + // convert the other formats to X8R8G8B8 + ConvFormat := ifX8R8G8B8; + + ConvertImage(Image, ConvFormat); +end; + +function TDDSFileFormat.TestFormat(Handle: TImagingHandle): Boolean; +var + Hdr: TDDSFileHeader; + ReadCount: LongInt; +begin + Result := False; + if Handle <> nil then + with GetIO do + begin + ReadCount := Read(Handle, @Hdr, SizeOf(Hdr)); + Seek(Handle, -ReadCount, smFromCurrent); + Result := (Hdr.Magic = DDSMagic) and (ReadCount = SizeOf(Hdr)) and + ((Hdr.Desc.Caps.Caps1 and DDSCAPS_TEXTURE) = DDSCAPS_TEXTURE); + end; +end; + +initialization + RegisterImageFileFormat(TDDSFileFormat); + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - nothing now + + -- 0.77.1 ---------------------------------------------------- + - Texture and D3D specific info stored in DDS is now available as metadata + (loading). + - Added support for loading DDS files with DX10 extension + (http://msdn.microsoft.com/en-us/library/windows/desktop/bb943991(v=vs.85).aspx) + and few compatibility fixes. + + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - Added support for 3Dc ATI1/2 formats. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Saved DDS with mipmaps now correctly defineds COMPLEX flag. + - Fixed loading of RGB DDS files that use pitch and have mipmaps - + mipmaps were loaded wrongly. + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Changed saving behaviour a bit: mipmaps are inlcuded automatically for + 2D textures if input image array has more than 1 image (no need to + set SaveMipMapCount manually). + - Mipmap levels are now saved with proper dimensions when saving DDS files. + - Made some changes to not be so strict when loading DDS files. + Many programs seem to save them in non-standard format + (by MS DDS File Reference). + - Added missing ifX8R8G8B8 to SupportedFormats, MakeCompatible failed + when image was converted to this format (inside). + - MakeCompatible method moved to base class, put ConvertToSupported here. + GetSupportedFormats removed, it is now set in constructor. + - Fixed bug that sometimes saved non-standard DDS files and another + one that caused crash when these files were loaded. + - Changed extensions to filename masks. + - Changed SaveData, LoadData, and MakeCompatible methods according + to changes in base class in Imaging unit. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - added support for half-float image formats + - change in LoadData to allow support for more images + in one stream loading + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - fixed bug in TestFormat which does not recognize many DDS files + - changed pitch/linearsize handling in DDS loading code to + load DDS files produced by NVidia's Photoshop plugin +} + +end. + diff --git a/Imaging/ImagingExport.pas b/Imaging/ImagingExport.pas deleted file mode 100644 index daf5bf7..0000000 --- a/Imaging/ImagingExport.pas +++ /dev/null @@ -1,891 +0,0 @@ -{ - $Id: ImagingExport.pas 173 2009-09-04 17:05:52Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This function contains functions exported from Imaging dynamic link library. - All string are exported as PChars and all var parameters are exported - as pointers. All posible exceptions getting out of dll are catched.} -unit ImagingExport; - -{$I ImagingOptions.inc} - -interface - -uses - ImagingTypes, - Imaging; - -{ Returns version of Imaging library. } -procedure ImGetVersion(var Major, Minor, Patch: LongInt); cdecl; -{ Look at InitImage for details.} -procedure ImInitImage(var Image: TImageData); cdecl; -{ Look at NewImage for details.} -function ImNewImage(Width, Height: LongInt; Format: TImageFormat; - var Image: TImageData): Boolean; cdecl; -{ Look at TestImage for details.} -function ImTestImage(var Image: TImageData): Boolean; cdecl; -{ Look at FreeImage for details.} -function ImFreeImage(var Image: TImageData): Boolean; cdecl; -{ Look at DetermineFileFormat for details. Ext should have enough space for - result file extension.} -function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean; cdecl; -{ Look at DetermineMemoryFormat for details. Ext should have enough space for - result file extension.} -function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean; cdecl; -{ Look at IsFileFormatSupported for details.} -function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean; cdecl; -{ Look at EnumFileFormats for details.} -function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar; - var CanSave, IsMultiImageFormat: Boolean): Boolean; cdecl; - -{ Inits image list.} -function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean; cdecl; -{ Returns size of image list.} -function ImGetImageListSize(ImageList: TImageDataList): LongInt; cdecl; -{ Returns image list's element at given index. Output image is not cloned it's - Bits point to Bits in list => do not free OutImage.} -function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt; - var OutImage: TImageData): Boolean; cdecl; -{ Sets size of image list.} -function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt): Boolean; cdecl; -{ Sets image list element at given index. Input image is not cloned - image in - list will point to InImage's Bits.} -function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt; - const InImage: TImageData): Boolean; cdecl; -{ Returns True if all images in list pass ImTestImage test. } -function ImTestImagesInList(ImageList: TImageDataList): Boolean; cdecl; -{ Frees image list and all images in it.} -function ImFreeImageList(var ImageList: TImageDataList): Boolean; cdecl; - -{ Look at LoadImageFromFile for details.} -function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean; cdecl; -{ Look at LoadImageFromMemory for details.} -function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; cdecl; -{ Look at LoadMultiImageFromFile for details.} -function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList): Boolean; cdecl; -{ Look at LoadMultiImageFromMemory for details.} -function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt; - var ImageList: TImageDataList): Boolean; cdecl; - -{ Look at SaveImageToFile for details.} -function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean; cdecl; -{ Look at SaveImageToMemory for details.} -function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt; - const Image: TImageData): Boolean; cdecl; -{ Look at SaveMultiImageToFile for details.} -function ImSaveMultiImageToFile(FileName: PAnsiChar; ImageList: TImageDataList): Boolean; cdecl; -{ Look at SaveMultiImageToMemory for details.} -function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt; - ImageList: TImageDataList): Boolean; cdecl; - -{ Look at CloneImage for details.} -function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean; cdecl; -{ Look at ConvertImage for details.} -function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; cdecl; -{ Look at FlipImage for details.} -function ImFlipImage(var Image: TImageData): Boolean; cdecl; -{ Look at MirrorImage for details.} -function ImMirrorImage(var Image: TImageData): Boolean; cdecl; -{ Look at ResizeImage for details.} -function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt; - Filter: TResizeFilter): Boolean; cdecl; -{ Look at SwapChannels for details.} -function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean; cdecl; -{ Look at ReduceColors for details.} -function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; cdecl; -{ Look at GenerateMipMaps for details.} -function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt; - var MipMaps: TImageDataList): Boolean; cdecl; -{ Look at MapImageToPalette for details.} -function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32; - Entries: LongInt): Boolean; cdecl; -{ Look at SplitImage for details.} -function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList; - ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt; - PreserveSize: Boolean; Fill: Pointer): Boolean; cdecl; -{ Look at MakePaletteForImages for details.} -function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32; - MaxColors: LongInt; ConvertImages: Boolean): Boolean; cdecl; -{ Look at RotateImage for details.} -function ImRotateImage(var Image: TImageData; Angle: Single): Boolean; cdecl; - -{ Look at CopyRect for details.} -function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt; - var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl; -{ Look at FillRect for details.} -function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt; - Fill: Pointer): Boolean; cdecl; -{ Look at ReplaceColor for details.} -function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt; - OldPixel, NewPixel: Pointer): Boolean; cdecl; -{ Look at StretchRect for details.} -function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, - SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, - DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl; -{ Look at GetPixelDirect for details.} -procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl; -{ Look at SetPixelDirect for details.} -procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl; -{ Look at GetPixel32 for details.} -function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl; -{ Look at SetPixel32 for details.} -procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); cdecl; -{ Look at GetPixelFP for details.} -function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl; -{ Look at SetPixelFP for details.} -procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); cdecl; - -{ Look at NewPalette for details.} -function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean; cdecl; -{ Look at FreePalette for details.} -function ImFreePalette(var Pal: PPalette32): Boolean; cdecl; -{ Look at CopyPalette for details.} -function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean; cdecl; -{ Look at FindColor for details.} -function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt; cdecl; -{ Look at FillGrayscalePalette for details.} -function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean; cdecl; -{ Look at FillCustomPalette for details.} -function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits, - BBits: Byte; Alpha: Byte): Boolean; cdecl; -{ Look at SwapChannelsOfPalette for details.} -function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel, - DstChannel: LongInt): Boolean; cdecl; - -{ Look at SetOption for details.} -function ImSetOption(OptionId, Value: LongInt): Boolean; cdecl; -{ Look at GetOption for details.} -function ImGetOption(OptionId: LongInt): LongInt; cdecl; -{ Look at PushOptions for details.} -function ImPushOptions: Boolean; cdecl; -{ Look at PopOptions for details.} -function ImPopOptions: Boolean; cdecl; - -{ Look at GetImageFormatInfo for details.} -function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean; cdecl; -{ Look at GetPixelsSize for details.} -function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; cdecl; - -{ Look at SetUserFileIO for details.} -procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc: - TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc; - TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); cdecl; -{ Look at ResetFileIO for details.} -procedure ImResetFileIO; cdecl; - -{ These are only for documentation generation reasons.} -{ Loads Imaging functions from dll/so library.} -function ImLoadLibrary: Boolean; -{ Frees Imaging functions loaded from dll/so and releases library.} -function ImFreeLibrary: Boolean; - -implementation - -uses - SysUtils, - ImagingUtility; - -function ImLoadLibrary: Boolean; begin Result := True; end; -function ImFreeLibrary: Boolean; begin Result := True; end; - -type - TInternalList = record - List: TDynImageDataArray; - end; - PInternalList = ^TInternalList; - -procedure ImGetVersion(var Major, Minor, Patch: LongInt); -begin - Major := ImagingVersionMajor; - Minor := ImagingVersionMinor; - Patch := ImagingVersionPatch; -end; - -procedure ImInitImage(var Image: TImageData); -begin - try - Imaging.InitImage(Image); - except - end; -end; - -function ImNewImage(Width, Height: LongInt; Format: TImageFormat; - var Image: TImageData): Boolean; -begin - try - Result := Imaging.NewImage(Width, Height, Format, Image); - except - Result := False; - end; -end; - -function ImTestImage(var Image: TImageData): Boolean; -begin - try - Result := Imaging.TestImage(Image); - except - Result := False; - end; -end; - -function ImFreeImage(var Image: TImageData): Boolean; -begin - try - Imaging.FreeImage(Image); - Result := True; - except - Result := False; - end; -end; - -function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean; -var - S: string; -begin - try - S := Imaging.DetermineFileFormat(FileName); - Result := S <> ''; - StrCopy(Ext, PAnsiChar(AnsiString(S))); - except - Result := False; - end; -end; - -function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean; -var - S: string; -begin - try - S := Imaging.DetermineMemoryFormat(Data, Size); - Result := S <> ''; - StrCopy(Ext, PAnsiChar(AnsiString(S))); - except - Result := False; - end; -end; - -function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean; -begin - try - Result := Imaging.IsFileFormatSupported(FileName); - except - Result := False; - end; -end; - -function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar; - var CanSave, IsMultiImageFormat: Boolean): Boolean; -var - StrName, StrDefaultExt, StrMasks: string; -begin - try - Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave, - IsMultiImageFormat); - StrCopy(Name, PAnsiChar(AnsiString(StrName))); - StrCopy(DefaultExt, PAnsiChar(AnsiString(StrDefaultExt))); - StrCopy(Masks, PAnsiChar(AnsiString(StrMasks))); - except - Result := False; - end; -end; - -function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean; -var - Int: PInternalList; -begin - try - try - ImFreeImageList(ImageList); - except - end; - New(Int); - SetLength(Int.List, Size); - ImageList := TImageDataList(Int); - Result := True; - except - Result := False; - ImageList := nil; - end; -end; - -function ImGetImageListSize(ImageList: TImageDataList): LongInt; -begin - try - Result := Length(PInternalList(ImageList).List); - except - Result := -1; - end; -end; - -function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt; - var OutImage: TImageData): Boolean; -begin - try - Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1); - ImCloneImage(PInternalList(ImageList).List[Index], OutImage); - Result := True; - except - Result := False; - end; -end; - -function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt): - Boolean; -var - I, OldSize: LongInt; -begin - try - OldSize := Length(PInternalList(ImageList).List); - if NewSize < OldSize then - for I := NewSize to OldSize - 1 do - Imaging.FreeImage(PInternalList(ImageList).List[I]); - SetLength(PInternalList(ImageList).List, NewSize); - Result := True; - except - Result := False; - end; -end; - -function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt; - const InImage: TImageData): Boolean; -begin - try - Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1); - ImCloneImage(InImage, PInternalList(ImageList).List[Index]); - Result := True; - except - Result := False; - end; -end; - -function ImTestImagesInList(ImageList: TImageDataList): Boolean; -var - I: LongInt; - Arr: TDynImageDataArray; -begin - Arr := nil; - try - Arr := PInternalList(ImageList).List; - Result := True; - for I := 0 to Length(Arr) - 1 do - begin - Result := Result and Imaging.TestImage(Arr[I]); - if not Result then Break; - end; - except - Result := False; - end; -end; - -function ImFreeImageList(var ImageList: TImageDataList): Boolean; -var - Int: PInternalList; -begin - try - if ImageList <> nil then - begin - Int := PInternalList(ImageList); - FreeImagesInArray(Int.List); - Dispose(Int); - ImageList := nil; - end; - Result := True; - except - Result := False; - end; -end; - -function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean; -begin - try - Result := Imaging.LoadImageFromFile(FileName, Image); - except - Result := False; - end; -end; - -function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; -begin - try - Result := Imaging.LoadImageFromMemory(Data, Size, Image); - except - Result := False; - end; -end; - -function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList): - Boolean; -begin - try - ImInitImageList(0, ImageList); - Result := Imaging.LoadMultiImageFromFile(FileName, - PInternalList(ImageList).List); - except - Result := False; - end; -end; - -function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt; - var ImageList: TImageDataList): Boolean; -begin - try - ImInitImageList(0, ImageList); - Result := Imaging.LoadMultiImageFromMemory(Data, Size, PInternalList(ImageList).List); - except - Result := False; - end; -end; - -function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean; -begin - try - Result := Imaging.SaveImageToFile(FileName, Image); - except - Result := False; - end; -end; - -function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt; - const Image: TImageData): Boolean; -begin - try - Result := Imaging.SaveImageToMemory(Ext, Data, Size, Image); - except - Result := False; - end; -end; - -function ImSaveMultiImageToFile(FileName: PAnsiChar; - ImageList: TImageDataList): Boolean; -begin - try - Result := Imaging.SaveMultiImageToFile(FileName, - PInternalList(ImageList).List); - except - Result := False; - end; -end; - -function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt; - ImageList: TImageDataList): Boolean; -begin - try - Result := Imaging.SaveMultiImageToMemory(Ext, Data, Size^, - PInternalList(ImageList).List); - except - Result := False; - end; -end; - -function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean; -begin - try - Result := Imaging.CloneImage(Image, Clone); - except - Result := False; - end; -end; - -function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; -begin - try - Result := Imaging.ConvertImage(Image, DestFormat); - except - Result := False; - end; -end; - -function ImFlipImage(var Image: TImageData): Boolean; -begin - try - Result := Imaging.FlipImage(Image); - except - Result := False; - end; -end; - -function ImMirrorImage(var Image: TImageData): Boolean; -begin - try - Result := Imaging.MirrorImage(Image); - except - Result := False; - end; -end; - -function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt; - Filter: TResizeFilter): Boolean; -begin - try - Result := Imaging.ResizeImage(Image, NewWidth, NewHeight, Filter); - except - Result := False; - end; -end; - -function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): - Boolean; -begin - try - Result := Imaging.SwapChannels(Image, SrcChannel, DstChannel); - except - Result := False; - end; -end; - -function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; -begin - try - Result := Imaging.ReduceColors(Image, MaxColors); - except - Result := False; - end; -end; - -function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt; - var MipMaps: TImageDataList): Boolean; -begin - try - ImInitImageList(0, MipMaps); - Result := Imaging.GenerateMipMaps(Image, Levels, - PInternalList(MipMaps).List); - except - Result := False; - end; -end; - -function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32; - Entries: LongInt): Boolean; -begin - try - Result := Imaging.MapImageToPalette(Image, Pal, Entries); - except - Result := False; - end; -end; - -function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList; - ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt; - PreserveSize: Boolean; Fill: Pointer): Boolean; -begin - try - ImInitImageList(0, Chunks); - Result := Imaging.SplitImage(Image, PInternalList(Chunks).List, - ChunkWidth, ChunkHeight, XChunks, YChunks, PreserveSize, Fill); - except - Result := False; - end; -end; - -function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32; - MaxColors: LongInt; ConvertImages: Boolean): Boolean; -begin - try - Result := Imaging.MakePaletteForImages(PInternalList(Images).List, - Pal, MaxColors, ConvertImages); - except - Result := False; - end; -end; - -function ImRotateImage(var Image: TImageData; Angle: Single): Boolean; -begin - try - Result := Imaging.RotateImage(Image, Angle); - except - Result := False; - end; -end; - -function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt; - var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl; -begin - try - Result := Imaging.CopyRect(SrcImage, SrcX, SrcY, Width, Height, - DstImage, DstX, DstY); - except - Result := False; - end; -end; - -function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt; - Fill: Pointer): Boolean; -begin - try - Result := Imaging.FillRect(Image, X, Y, Width, Height, Fill); - except - Result := False; - end; -end; - -function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt; - OldPixel, NewPixel: Pointer): Boolean; -begin - try - Result := Imaging.ReplaceColor(Image, X, Y, Width, Height, OldPixel, NewPixel); - except - Result := False; - end; -end; - -function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, - SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, - DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl; -begin - try - Result := Imaging.StretchRect(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, - DstImage, DstX, DstY, DstWidth, DstHeight, Filter); - except - Result := False; - end; -end; - -procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); -begin - try - Imaging.GetPixelDirect(Image, X, Y, Pixel); - except - end; -end; - -procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); -begin - try - Imaging.SetPixelDirect(Image, X, Y, Pixel); - except - end; -end; - -function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl; -begin - try - Result := Imaging.GetPixel32(Image, X, Y); - except - Result.Color := 0; - end; -end; - -procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); -begin - try - Imaging.SetPixel32(Image, X, Y, Color); - except - end; -end; - -function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl; -begin - try - Result := Imaging.GetPixelFP(Image, X, Y); - except - FillChar(Result, SizeOf(Result), 0); - end; -end; - -procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); -begin - try - Imaging.SetPixelFP(Image, X, Y, Color); - except - end; -end; - -function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean; -begin - try - Imaging.NewPalette(Entries, Pal); - Result := True; - except - Result := False; - end; -end; - -function ImFreePalette(var Pal: PPalette32): Boolean; -begin - try - Imaging.FreePalette(Pal); - Result := True; - except - Result := False; - end; -end; - -function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean; -begin - try - Imaging.CopyPalette(SrcPal, DstPal, SrcIdx, DstIdx, Count); - Result := True; - except - Result := False; - end; -end; - -function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt; -begin - try - Result := Imaging.FindColor(Pal, Entries, Color); - except - Result := 0; - end; -end; - -function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean; -begin - try - Imaging.FillGrayscalePalette(Pal, Entries); - Result := True; - except - Result := False; - end; -end; - -function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits, - BBits: Byte; Alpha: Byte): Boolean; -begin - try - Imaging.FillCustomPalette(Pal, Entries, RBits, GBits, BBits, Alpha); - Result := True; - except - Result := False; - end; -end; - -function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel, - DstChannel: LongInt): Boolean; -begin - try - Imaging.SwapChannelsOfPalette(Pal, Entries, SrcChannel, DstChannel); - Result := True; - except - Result := False; - end; -end; - -function ImSetOption(OptionId, Value: LongInt): Boolean; -begin - try - Result := Imaging.SetOption(OptionId, Value); - except - Result := False; - end; -end; - -function ImGetOption(OptionId: LongInt): LongInt; -begin - try - Result := GetOption(OptionId); - except - Result := InvalidOption; - end; -end; - -function ImPushOptions: Boolean; -begin - try - Result := Imaging.PushOptions; - except - Result := False; - end; -end; - -function ImPopOptions: Boolean; -begin - try - Result := Imaging.PopOptions; - except - Result := False; - end; -end; - -function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean; -begin - try - Result := Imaging.GetImageFormatInfo(Format, Info); - except - Result := False; - end; -end; - -function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; -begin - try - Result := Imaging.GetPixelsSize(Format, Width, Height); - except - Result := 0; - end; -end; - -procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc: - TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc; - TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); -begin - try - Imaging.SetUserFileIO(OpenReadProc, OpenWriteProc, CloseProc, EofProc, - SeekProc, TellProc, ReadProc, WriteProc); - except - end; -end; - -procedure ImResetFileIO; -begin - try - Imaging.ResetFileIO; - except - end; -end; - -{ - Changes/Bug Fixes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.26.3 --------------------------------------------------- - - changed PChars to PAnsiChars and some more D2009 friendly - casts. - - -- 0.19 ----------------------------------------------------- - - updated to reflect changes in low level interface (added pixel set/get, ...) - - changed ImInitImage to procedure to reflect change in Imaging.pas - - added ImIsFileFormatSupported - - -- 0.15 ----------------------------------------------------- - - behaviour of ImGetImageListElement and ImSetImageListElement - has changed - list items are now cloned rather than referenced, - because of this ImFreeImageListKeepImages was no longer needed - and was removed - - many function headers were changed - mainly pointers were - replaced with var and const parameters - - -- 0.13 ----------------------------------------------------- - - added TestImagesInList function and new 0.13 functions - - images were not freed when image list was resized in ImSetImageListSize - - ImSaveMultiImageTo* recreated the input image list with size = 0 - -} -end. - diff --git a/Imaging/ImagingFormats.pas b/Imaging/ImagingFormats.pas index 717e629..57acfff 100644 --- a/Imaging/ImagingFormats.pas +++ b/Imaging/ImagingFormats.pas @@ -1,4288 +1,4435 @@ -{ - $Id: ImagingFormats.pas 174 2009-09-08 09:37:59Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit manages information about all image data formats and contains - low level format conversion, manipulation, and other related functions.} -unit ImagingFormats; - -{$I ImagingOptions.inc} - -interface - -uses - ImagingTypes, Imaging, ImagingUtility; - -type - TImageFormatInfoArray = array[TImageFormat] of PImageFormatInfo; - PImageFormatInfoArray = ^TImageFormatInfoArray; - - -{ Additional image manipulation functions (usually used internally by Imaging unit) } - -type - { Color reduction operations.} - TReduceColorsAction = (raCreateHistogram, raUpdateHistogram, raMakeColorMap, - raMapImage); - TReduceColorsActions = set of TReduceColorsAction; -const - AllReduceColorsActions = [raCreateHistogram, raUpdateHistogram, - raMakeColorMap, raMapImage]; -{ Reduces the number of colors of source. Src is bits of source image - (ARGB or floating point) and Dst is in some indexed format. MaxColors - is the number of colors to which reduce and DstPal is palette to which - the resulting colors are written and it must be allocated to at least - MaxColors entries. ChannelMask is 'anded' with every pixel's channel value - when creating color histogram. If $FF is used all 8bits of color channels - are used which can be slow for large images with many colors so you can - use lower masks to speed it up.} -procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte; - DstPal: PPalette32; Actions: TReduceColorsActions = AllReduceColorsActions); -{ Stretches rectangle in source image to rectangle in destination image - using nearest neighbor filtering. It is fast but results look blocky - because there is no interpolation used. SrcImage and DstImage must be - in the same data format. Works for all data formats except special formats.} -procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, - SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, - DstHeight: LongInt); -type - { Built-in sampling filters.} - TSamplingFilter = (sfNearest, sfLinear, sfCosine, sfHermite, sfQuadratic, - sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom); - { Type of custom sampling function} - TFilterFunction = function(Value: Single): Single; -const - { Default resampling filter used for bicubic resizing.} - DefaultCubicFilter = sfCatmullRom; -var - { Built-in filter functions.} - SamplingFilterFunctions: array[TSamplingFilter] of TFilterFunction; - { Default radii of built-in filter functions.} - SamplingFilterRadii: array[TSamplingFilter] of Single; - -{ Stretches rectangle in source image to rectangle in destination image - with resampling. One of built-in resampling filters defined by - Filter is used. Set WrapEdges to True for seamlessly tileable images. - SrcImage and DstImage must be in the same data format. - Works for all data formats except special and indexed formats.} -procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, - SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, - DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean = False); overload; -{ Stretches rectangle in source image to rectangle in destination image - with resampling. You can use custom sampling function and filter radius. - Set WrapEdges to True for seamlessly tileable images. SrcImage and DstImage - must be in the same data format. - Works for all data formats except special and indexed formats.} -procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, - SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, - DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; - WrapEdges: Boolean = False); overload; -{ Helper for functions that create mipmap levels. BiggerLevel is - valid image and SmallerLevel is empty zeroed image. SmallerLevel is created - with Width and Height dimensions and it is filled with pixels of BiggerLevel - using resampling filter specified by ImagingMipMapFilter option. - Uses StretchNearest and StretchResample internally so the same image data format - limitations apply.} -procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt; - var SmallerLevel: TImageData); - - -{ Various helper & support functions } - -{ Copies Src pixel to Dest pixel. It is faster than System.Move procedure.} -procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Compares Src pixel and Dest pixel. It is faster than SysUtils.CompareMem function.} -function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Translates pixel color in SrcFormat to DstFormat.} -procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat, - DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32); -{ Clamps floating point pixel channel values to [0.0, 1.0] range.} -procedure ClampFloatPixel(var PixF: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} - -{ Adds padding bytes at the ends of scanlines. Bpp is the number of bytes per - pixel of source and WidthBytes is the number of bytes per scanlines of dest.} -procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height, - Bpp, WidthBytes: LongInt); -{ Removes padding from image with scanlines that have aligned sizes. Bpp is - the number of bytes per pixel of dest and WidthBytes is the number of bytes - per scanlines of source.} -procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height, - Bpp, WidthBytes: LongInt); - -{ Converts 1bit image data to 8bit (without scaling). Used by file - loaders for formats supporting 1bit images.} -procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height, - WidthBytes: LongInt); -{ Converts 2bit image data to 8bit (without scaling). Used by file - loaders for formats supporting 2bit images.} -procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height, - WidthBytes: LongInt); -{ Converts 4bit image data to 8bit (without scaling). Used by file - loaders for formats supporting 4bit images.} -procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height, - WidthBytes: LongInt); - -{ Helper function for image file loaders. Some 15 bit images (targas, bitmaps) - may contain 1 bit alpha but there is no indication of it. This function checks - all 16 bit(should be X1R5G5B5 or A1R5G5B5 format) pixels and some of them have - alpha bit set it returns True, otherwise False.} -function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean; -{ Helper function for image file loaders. This function checks is similar - to Has16BitImageAlpha but works with A8R8G8B8 format.} -function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean; -{ Provides indexed access to each line of pixels. Does not work with special - format images.} -function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo; - LineWidth, Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns True if Format is valid image data format identifier.} -function IsImageFormatValid(Format: TImageFormat): Boolean; - -{ Converts 16bit half floating point value to 32bit Single.} -function HalfToFloat(Half: THalfFloat): Single; -{ Converts 32bit Single to 16bit half floating point.} -function FloatToHalf(Float: Single): THalfFloat; - -{ Converts half float color value to single-precision floating point color.} -function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Converts single-precision floating point color to half float color.} -function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF} - -{ Makes image PalEntries x 1 big where each pixel has color of one pal entry.} -procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData); - -type - TPointRec = record - Pos: LongInt; - Weight: Single; - end; - TCluster = array of TPointRec; - TMappingTable = array of TCluster; - -{ Helper function for resampling.} -function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt; - Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable; -{ Helper function for resampling.} -procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt); - - -{ Pixel readers/writers for different image formats } - -{ Returns pixel of image in any ARGB format. Channel values are scaled to 16 bits.} -procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; - var Pix: TColor64Rec); -{ Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.} -procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; - const Pix: TColor64Rec); - -{ Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits - and alpha to 16 bits.} -procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; - var Gray: TColor64Rec; var Alpha: Word); -{ Sets pixel of image in any grayscale format. Gray value must be scaled to 64 bits - and alpha to 16 bits.} -procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; - const Gray: TColor64Rec; Alpha: Word); - -{ Returns pixel of image in any floating point format. Channel values are - in range <0.0, 1.0>.} -procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; - var Pix: TColorFPRec); -{ Sets pixel of image in any floating point format. Channel values must be - in range <0.0, 1.0>.} -procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; - const Pix: TColorFPRec); - -{ Returns pixel of image in any indexed format. Returned value is index to - the palette.} -procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; - var Index: LongWord); -{ Sets pixel of image in any indexed format. Index is index to the palette.} -procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; - Index: LongWord); - - -{ Pixel readers/writers for 32bit and FP colors} - -{ Function for getting pixel colors. Native pixel is read from Image and - then translated to 32 bit ARGB.} -function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; - Palette: PPalette32): TColor32Rec; -{ Procedure for setting pixel colors. Input 32 bit ARGB color is translated to - native format and then written to Image.} -procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; - Palette: PPalette32; const Color: TColor32Rec); -{ Function for getting pixel colors. Native pixel is read from Image and - then translated to FP ARGB.} -function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; - Palette: PPalette32): TColorFPRec; -{ Procedure for setting pixel colors. Input FP ARGB color is translated to - native format and then written to Image.} -procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; - Palette: PPalette32; const Color: TColorFPRec); - - -{ Image format conversion functions } - -{ Converts any ARGB format to any ARGB format.} -procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -{ Converts any ARGB format to any grayscale format.} -procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -{ Converts any ARGB format to any floating point format.} -procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -{ Converts any ARGB format to any indexed format.} -procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; DstPal: PPalette32); - -{ Converts any grayscale format to any grayscale format.} -procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -{ Converts any grayscale format to any ARGB format.} -procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -{ Converts any grayscale format to any floating point format.} -procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -{ Converts any grayscale format to any indexed format.} -procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; DstPal: PPalette32); - -{ Converts any floating point format to any floating point format.} -procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -{ Converts any floating point format to any ARGB format.} -procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -{ Converts any floating point format to any grayscale format.} -procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -{ Converts any floating point format to any indexed format.} -procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; DstPal: PPalette32); - -{ Converts any indexed format to any indexed format.} -procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32); -{ Converts any indexed format to any ARGB format.} -procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; SrcPal: PPalette32); -{ Converts any indexed format to any grayscale format.} -procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; SrcPal: PPalette32); -{ Converts any indexed format to any floating point format.} -procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; SrcPal: PPalette32); - - -{ Color constructor functions } - -{ Constructs TColor24Rec color.} -function Color24(R, G, B: Byte): TColor24Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Constructs TColor32Rec color.} -function Color32(A, R, G, B: Byte): TColor32Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Constructs TColor48Rec color.} -function Color48(R, G, B: Word): TColor48Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Constructs TColor64Rec color.} -function Color64(A, R, G, B: Word): TColor64Rec; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Constructs TColorFPRec color.} -function ColorFP(A, R, G, B: Single): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Constructs TColorHFRec color.} -function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF} - - -{ Special formats conversion functions } - -{ Converts image to/from/between special image formats (dxtc, ...).} -procedure ConvertSpecial(var Image: TImageData; SrcInfo, - DstInfo: PImageFormatInfo); - - -{ Inits all image format information. Called internally on startup.} -procedure InitImageFormats(var Infos: TImageFormatInfoArray); - -const - // Grayscale conversion channel weights - GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0); - - // Contants for converting integer colors to floating point - OneDiv8Bit: Single = 1.0 / 255.0; - OneDiv16Bit: Single = 1.0 / 65535.0; - -implementation - -{ TImageFormatInfo member functions } - -{ Returns size in bytes of image in given standard format where - Size = Width * Height * Bpp.} -function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward; -{ Checks if Width and Height are valid for given standard format.} -procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt); forward; -{ Returns size in bytes of image in given DXT format.} -function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward; -{ Checks if Width and Height are valid for given DXT format. If they are - not valid, they are changed to pass the check.} -procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt); forward; -{ Returns size in bytes of image in BTC format.} -function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward; - -{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo } - -function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward; -procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward; -function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward; -procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward; - -function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward; -procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward; -function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward; -procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward; - -function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward; -procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward; - -var - PFR3G3B2: TPixelFormatInfo; - PFX5R1G1B1: TPixelFormatInfo; - PFR5G6B5: TPixelFormatInfo; - PFA1R5G5B5: TPixelFormatInfo; - PFA4R4G4B4: TPixelFormatInfo; - PFX1R5G5B5: TPixelFormatInfo; - PFX4R4G4B4: TPixelFormatInfo; - FInfos: PImageFormatInfoArray; - -var - // Free Pascal generates hundreds of warnings here -{$WARNINGS OFF} - - // indexed formats - Index8Info: TImageFormatInfo = ( - Format: ifIndex8; - Name: 'Index8'; - BytesPerPixel: 1; - ChannelCount: 1; - PaletteEntries: 256; - HasAlphaChannel: True; - IsIndexed: True; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - // grayscale formats - Gray8Info: TImageFormatInfo = ( - Format: ifGray8; - Name: 'Gray8'; - BytesPerPixel: 1; - ChannelCount: 1; - HasGrayChannel: True; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Channel8Bit; - GetPixelFP: GetPixelFPChannel8Bit; - SetPixel32: SetPixel32Channel8Bit; - SetPixelFP: SetPixelFPChannel8Bit); - - A8Gray8Info: TImageFormatInfo = ( - Format: ifA8Gray8; - Name: 'A8Gray8'; - BytesPerPixel: 2; - ChannelCount: 2; - HasGrayChannel: True; - HasAlphaChannel: True; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Channel8Bit; - GetPixelFP: GetPixelFPChannel8Bit; - SetPixel32: SetPixel32Channel8Bit; - SetPixelFP: SetPixelFPChannel8Bit); - - Gray16Info: TImageFormatInfo = ( - Format: ifGray16; - Name: 'Gray16'; - BytesPerPixel: 2; - ChannelCount: 1; - HasGrayChannel: True; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - Gray32Info: TImageFormatInfo = ( - Format: ifGray32; - Name: 'Gray32'; - BytesPerPixel: 4; - ChannelCount: 1; - HasGrayChannel: True; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - Gray64Info: TImageFormatInfo = ( - Format: ifGray64; - Name: 'Gray64'; - BytesPerPixel: 8; - ChannelCount: 1; - HasGrayChannel: True; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - A16Gray16Info: TImageFormatInfo = ( - Format: ifA16Gray16; - Name: 'A16Gray16'; - BytesPerPixel: 4; - ChannelCount: 2; - HasGrayChannel: True; - HasAlphaChannel: True; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - // ARGB formats - X5R1G1B1Info: TImageFormatInfo = ( - Format: ifX5R1G1B1; - Name: 'X5R1G1B1'; - BytesPerPixel: 1; - ChannelCount: 3; - UsePixelFormat: True; - PixelFormat: @PFX5R1G1B1; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - R3G3B2Info: TImageFormatInfo = ( - Format: ifR3G3B2; - Name: 'R3G3B2'; - BytesPerPixel: 1; - ChannelCount: 3; - UsePixelFormat: True; - PixelFormat: @PFR3G3B2; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - R5G6B5Info: TImageFormatInfo = ( - Format: ifR5G6B5; - Name: 'R5G6B5'; - BytesPerPixel: 2; - ChannelCount: 3; - UsePixelFormat: True; - PixelFormat: @PFR5G6B5; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - A1R5G5B5Info: TImageFormatInfo = ( - Format: ifA1R5G5B5; - Name: 'A1R5G5B5'; - BytesPerPixel: 2; - ChannelCount: 4; - HasAlphaChannel: True; - UsePixelFormat: True; - PixelFormat: @PFA1R5G5B5; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - A4R4G4B4Info: TImageFormatInfo = ( - Format: ifA4R4G4B4; - Name: 'A4R4G4B4'; - BytesPerPixel: 2; - ChannelCount: 4; - HasAlphaChannel: True; - UsePixelFormat: True; - PixelFormat: @PFA4R4G4B4; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - X1R5G5B5Info: TImageFormatInfo = ( - Format: ifX1R5G5B5; - Name: 'X1R5G5B5'; - BytesPerPixel: 2; - ChannelCount: 3; - UsePixelFormat: True; - PixelFormat: @PFX1R5G5B5; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - X4R4G4B4Info: TImageFormatInfo = ( - Format: ifX4R4G4B4; - Name: 'X4R4G4B4'; - BytesPerPixel: 2; - ChannelCount: 3; - UsePixelFormat: True; - PixelFormat: @PFX4R4G4B4; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - R8G8B8Info: TImageFormatInfo = ( - Format: ifR8G8B8; - Name: 'R8G8B8'; - BytesPerPixel: 3; - ChannelCount: 3; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Channel8Bit; - GetPixelFP: GetPixelFPChannel8Bit; - SetPixel32: SetPixel32Channel8Bit; - SetPixelFP: SetPixelFPChannel8Bit); - - A8R8G8B8Info: TImageFormatInfo = ( - Format: ifA8R8G8B8; - Name: 'A8R8G8B8'; - BytesPerPixel: 4; - ChannelCount: 4; - HasAlphaChannel: True; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32ifA8R8G8B8; - GetPixelFP: GetPixelFPifA8R8G8B8; - SetPixel32: SetPixel32ifA8R8G8B8; - SetPixelFP: SetPixelFPifA8R8G8B8); - - X8R8G8B8Info: TImageFormatInfo = ( - Format: ifX8R8G8B8; - Name: 'X8R8G8B8'; - BytesPerPixel: 4; - ChannelCount: 3; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Channel8Bit; - GetPixelFP: GetPixelFPChannel8Bit; - SetPixel32: SetPixel32Channel8Bit; - SetPixelFP: SetPixelFPChannel8Bit); - - R16G16B16Info: TImageFormatInfo = ( - Format: ifR16G16B16; - Name: 'R16G16B16'; - BytesPerPixel: 6; - ChannelCount: 3; - RBSwapFormat: ifB16G16R16; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - A16R16G16B16Info: TImageFormatInfo = ( - Format: ifA16R16G16B16; - Name: 'A16R16G16B16'; - BytesPerPixel: 8; - ChannelCount: 4; - HasAlphaChannel: True; - RBSwapFormat: ifA16B16G16R16; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - B16G16R16Info: TImageFormatInfo = ( - Format: ifB16G16R16; - Name: 'B16G16R16'; - BytesPerPixel: 6; - ChannelCount: 3; - IsRBSwapped: True; - RBSwapFormat: ifR16G16B16; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - A16B16G16R16Info: TImageFormatInfo = ( - Format: ifA16B16G16R16; - Name: 'A16B16G16R16'; - BytesPerPixel: 8; - ChannelCount: 4; - HasAlphaChannel: True; - IsRBSwapped: True; - RBSwapFormat: ifA16R16G16B16; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - // floating point formats - R32FInfo: TImageFormatInfo = ( - Format: ifR32F; - Name: 'R32F'; - BytesPerPixel: 4; - ChannelCount: 1; - IsFloatingPoint: True; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPFloat32; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPFloat32); - - A32R32G32B32FInfo: TImageFormatInfo = ( - Format: ifA32R32G32B32F; - Name: 'A32R32G32B32F'; - BytesPerPixel: 16; - ChannelCount: 4; - HasAlphaChannel: True; - IsFloatingPoint: True; - RBSwapFormat: ifA32B32G32R32F; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPFloat32; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPFloat32); - - A32B32G32R32FInfo: TImageFormatInfo = ( - Format: ifA32B32G32R32F; - Name: 'A32B32G32R32F'; - BytesPerPixel: 16; - ChannelCount: 4; - HasAlphaChannel: True; - IsFloatingPoint: True; - IsRBSwapped: True; - RBSwapFormat: ifA32R32G32B32F; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPFloat32; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPFloat32); - - R16FInfo: TImageFormatInfo = ( - Format: ifR16F; - Name: 'R16F'; - BytesPerPixel: 2; - ChannelCount: 1; - IsFloatingPoint: True; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - A16R16G16B16FInfo: TImageFormatInfo = ( - Format: ifA16R16G16B16F; - Name: 'A16R16G16B16F'; - BytesPerPixel: 8; - ChannelCount: 4; - HasAlphaChannel: True; - IsFloatingPoint: True; - RBSwapFormat: ifA16B16G16R16F; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - A16B16G16R16FInfo: TImageFormatInfo = ( - Format: ifA16B16G16R16F; - Name: 'A16B16G16R16F'; - BytesPerPixel: 8; - ChannelCount: 4; - HasAlphaChannel: True; - IsFloatingPoint: True; - IsRBSwapped: True; - RBSwapFormat: ifA16R16G16B16F; - GetPixelsSize: GetStdPixelsSize; - CheckDimensions: CheckStdDimensions; - GetPixel32: GetPixel32Generic; - GetPixelFP: GetPixelFPGeneric; - SetPixel32: SetPixel32Generic; - SetPixelFP: SetPixelFPGeneric); - - // special formats - DXT1Info: TImageFormatInfo = ( - Format: ifDXT1; - Name: 'DXT1'; - ChannelCount: 4; - HasAlphaChannel: True; - IsSpecial: True; - GetPixelsSize: GetDXTPixelsSize; - CheckDimensions: CheckDXTDimensions; - SpecialNearestFormat: ifA8R8G8B8); - - DXT3Info: TImageFormatInfo = ( - Format: ifDXT3; - Name: 'DXT3'; - ChannelCount: 4; - HasAlphaChannel: True; - IsSpecial: True; - GetPixelsSize: GetDXTPixelsSize; - CheckDimensions: CheckDXTDimensions; - SpecialNearestFormat: ifA8R8G8B8); - - DXT5Info: TImageFormatInfo = ( - Format: ifDXT5; - Name: 'DXT5'; - ChannelCount: 4; - HasAlphaChannel: True; - IsSpecial: True; - GetPixelsSize: GetDXTPixelsSize; - CheckDimensions: CheckDXTDimensions; - SpecialNearestFormat: ifA8R8G8B8); - - BTCInfo: TImageFormatInfo = ( - Format: ifBTC; - Name: 'BTC'; - ChannelCount: 1; - HasAlphaChannel: False; - IsSpecial: True; - GetPixelsSize: GetBTCPixelsSize; - CheckDimensions: CheckDXTDimensions; - SpecialNearestFormat: ifGray8); - - ATI1NInfo: TImageFormatInfo = ( - Format: ifATI1N; - Name: 'ATI1N'; - ChannelCount: 1; - HasAlphaChannel: False; - IsSpecial: True; - GetPixelsSize: GetDXTPixelsSize; - CheckDimensions: CheckDXTDimensions; - SpecialNearestFormat: ifGray8); - - ATI2NInfo: TImageFormatInfo = ( - Format: ifATI2N; - Name: 'ATI2N'; - ChannelCount: 2; - HasAlphaChannel: False; - IsSpecial: True; - GetPixelsSize: GetDXTPixelsSize; - CheckDimensions: CheckDXTDimensions; - SpecialNearestFormat: ifA8R8G8B8); - -{$WARNINGS ON} - -function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward; - -procedure InitImageFormats(var Infos: TImageFormatInfoArray); -begin - FInfos := @Infos; - - Infos[ifDefault] := @A8R8G8B8Info; - // indexed formats - Infos[ifIndex8] := @Index8Info; - // grayscale formats - Infos[ifGray8] := @Gray8Info; - Infos[ifA8Gray8] := @A8Gray8Info; - Infos[ifGray16] := @Gray16Info; - Infos[ifGray32] := @Gray32Info; - Infos[ifGray64] := @Gray64Info; - Infos[ifA16Gray16] := @A16Gray16Info; - // ARGB formats - Infos[ifX5R1G1B1] := @X5R1G1B1Info; - Infos[ifR3G3B2] := @R3G3B2Info; - Infos[ifR5G6B5] := @R5G6B5Info; - Infos[ifA1R5G5B5] := @A1R5G5B5Info; - Infos[ifA4R4G4B4] := @A4R4G4B4Info; - Infos[ifX1R5G5B5] := @X1R5G5B5Info; - Infos[ifX4R4G4B4] := @X4R4G4B4Info; - Infos[ifR8G8B8] := @R8G8B8Info; - Infos[ifA8R8G8B8] := @A8R8G8B8Info; - Infos[ifX8R8G8B8] := @X8R8G8B8Info; - Infos[ifR16G16B16] := @R16G16B16Info; - Infos[ifA16R16G16B16] := @A16R16G16B16Info; - Infos[ifB16G16R16] := @B16G16R16Info; - Infos[ifA16B16G16R16] := @A16B16G16R16Info; - // floating point formats - Infos[ifR32F] := @R32FInfo; - Infos[ifA32R32G32B32F] := @A32R32G32B32FInfo; - Infos[ifA32B32G32R32F] := @A32B32G32R32FInfo; - Infos[ifR16F] := @R16FInfo; - Infos[ifA16R16G16B16F] := @A16R16G16B16FInfo; - Infos[ifA16B16G16R16F] := @A16B16G16R16FInfo; - // special formats - Infos[ifDXT1] := @DXT1Info; - Infos[ifDXT3] := @DXT3Info; - Infos[ifDXT5] := @DXT5Info; - Infos[ifBTC] := @BTCInfo; - Infos[ifATI1N] := @ATI1NInfo; - Infos[ifATI2N] := @ATI2NInfo; - - PFR3G3B2 := PixelFormat(0, 3, 3, 2); - PFX5R1G1B1 := PixelFormat(0, 1, 1, 1); - PFR5G6B5 := PixelFormat(0, 5, 6, 5); - PFA1R5G5B5 := PixelFormat(1, 5, 5, 5); - PFA4R4G4B4 := PixelFormat(4, 4, 4, 4); - PFX1R5G5B5 := PixelFormat(0, 5, 5, 5); - PFX4R4G4B4 := PixelFormat(0, 4, 4, 4); -end; - - -{ Internal unit helper functions } - -function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; -begin - Result.ABitMask := ((1 shl ABitCount) - 1) shl (RBitCount + GBitCount + - BBitCount); - Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount); - Result.GBitMask := ((1 shl GBitCount) - 1) shl (BBitCount); - Result.BBitMask := (1 shl BBitCount) - 1; - Result.ABitCount := ABitCount; - Result.RBitCount := RBitCount; - Result.GBitCount := GBitCount; - Result.BBitCount := BBitCount; - Result.AShift := RBitCount + GBitCount + BBitCount; - Result.RShift := GBitCount + BBitCount; - Result.GShift := BBitCount; - Result.BShift := 0; - Result.ARecDiv := Max(1, Pow2Int(Result.ABitCount) - 1); - Result.RRecDiv := Max(1, Pow2Int(Result.RBitCount) - 1); - Result.GRecDiv := Max(1, Pow2Int(Result.GBitCount) - 1); - Result.BRecDiv := Max(1, Pow2Int(Result.BBitCount) - 1); -end; - -function PixelFormatMask(ABitMask, RBitMask, GBitMask, BBitMask: LongWord): TPixelFormatInfo; - - function GetBitCount(B: LongWord): LongWord; - var - I: LongWord; - begin - I := 0; - while (I < 31) and (((1 shl I) and B) = 0) do - Inc(I); - Result := 0; - while ((1 shl I) and B) <> 0 do - begin - Inc(I); - Inc(Result); - end; - end; - -begin - Result := PixelFormat(GetBitCount(ABitMask), GetBitCount(RBitMask), - GetBitCount(GBitMask), GetBitCount(BBitMask)); -end; - -function PFSetARGB(const PF: TPixelFormatInfo; A, R, G, B: Byte): TColor32; -{$IFDEF USE_INLINE}inline;{$ENDIF} -begin - with PF do - Result := - (A shl ABitCount shr 8 shl AShift) or - (R shl RBitCount shr 8 shl RShift) or - (G shl GBitCount shr 8 shl GShift) or - (B shl BBitCount shr 8 shl BShift); -end; - -procedure PFGetARGB(const PF: TPixelFormatInfo; Color: LongWord; - var A, R, G, B: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF} -begin - with PF do - begin - A := (Color and ABitMask shr AShift) * 255 div ARecDiv; - R := (Color and RBitMask shr RShift) * 255 div RRecDiv; - G := (Color and GBitMask shr GShift) * 255 div GRecDiv; - B := (Color and BBitMask shl BShift) * 255 div BRecDiv; - end; -end; - -function PFSetColor(const PF: TPixelFormatInfo; ARGB: TColor32): LongWord; -{$IFDEF USE_INLINE}inline;{$ENDIF} -begin - with PF do - Result := - (Byte(ARGB shr 24) shl ABitCount shr 8 shl AShift) or - (Byte(ARGB shr 16) shl RBitCount shr 8 shl RShift) or - (Byte(ARGB shr 8) shl GBitCount shr 8 shl GShift) or - (Byte(ARGB) shl BBitCount shr 8 shl BShift); -end; - -function PFGetColor(const PF: TPixelFormatInfo; Color: LongWord): TColor32; -{$IFDEF USE_INLINE}inline;{$ENDIF} -begin - with PF, TColor32Rec(Result) do - begin - A := (Color and ABitMask shr AShift) * 255 div ARecDiv; - R := (Color and RBitMask shr RShift) * 255 div RRecDiv; - G := (Color and GBitMask shr GShift) * 255 div GRecDiv; - B := (Color and BBitMask shl BShift) * 255 div BRecDiv; - end; -end; - - -{ Color constructor functions } - - -function Color24(R, G, B: Byte): TColor24Rec; -begin - Result.R := R; - Result.G := G; - Result.B := B; -end; - -function Color32(A, R, G, B: Byte): TColor32Rec; -begin - Result.A := A; - Result.R := R; - Result.G := G; - Result.B := B; -end; - -function Color48(R, G, B: Word): TColor48Rec; -begin - Result.R := R; - Result.G := G; - Result.B := B; -end; - -function Color64(A, R, G, B: Word): TColor64Rec; -begin - Result.A := A; - Result.R := R; - Result.G := G; - Result.B := B; -end; - -function ColorFP(A, R, G, B: Single): TColorFPRec; -begin - Result.A := A; - Result.R := R; - Result.G := G; - Result.B := B; -end; - -function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; -begin - Result.A := A; - Result.R := R; - Result.G := G; - Result.B := B; -end; - - -{ Additional image manipulation functions (usually used internally by Imaging unit) } - -const - MaxPossibleColors = 4096; - HashSize = 32768; - AlphaWeight = 1024; - RedWeight = 612; - GreenWeight = 1202; - BlueWeight = 234; - -type - PColorBin = ^TColorBin; - TColorBin = record - Color: TColor32Rec; - Number: LongInt; - Next: PColorBin; - end; - - THashTable = array[0..HashSize - 1] of PColorBin; - - TColorBox = record - AMin, AMax, - RMin, RMax, - GMin, GMax, - BMin, BMax: LongInt; - Total: LongInt; - Represented: TColor32Rec; - List: PColorBin; - end; - -var - Table: THashTable; - Box: array[0..MaxPossibleColors - 1] of TColorBox; - Boxes: LongInt; - BoxesCreated: Boolean = False; - -procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte; - DstPal: PPalette32; Actions: TReduceColorsActions); - - procedure CreateHistogram (Src: PByte; SrcInfo: PImageFormatInfo; - ChannelMask: Byte); - var - A, R, G, B: Byte; - I, Addr: LongInt; - PC: PColorBin; - Col: TColor32Rec; - begin - for I := 0 to NumPixels - 1 do - begin - Col := GetPixel32Generic(Src, SrcInfo, nil); - A := Col.A and ChannelMask; - R := Col.R and ChannelMask; - G := Col.G and ChannelMask; - B := Col.B and ChannelMask; - - Addr := (A + 11 * B + 59 * R + 119 * G) mod HashSize; - PC := Table[Addr]; - - while (PC <> nil) and ((PC.Color.R <> R) or (PC.Color.G <> G) or - (PC.Color.B <> B) or (PC.Color.A <> A)) do - PC := PC.Next; - - if PC = nil then - begin - New(PC); - PC.Color.R := R; - PC.Color.G := G; - PC.Color.B := B; - PC.Color.A := A; - PC.Number := 1; - PC.Next := Table[Addr]; - Table[Addr] := PC; - end - else - Inc(PC^.Number); - Inc(Src, SrcInfo.BytesPerPixel); - end; - end; - - procedure InitBox (var Box : TColorBox); - begin - Box.AMin := 256; - Box.RMin := 256; - Box.GMin := 256; - Box.BMin := 256; - Box.AMax := -1; - Box.RMax := -1; - Box.GMax := -1; - Box.BMax := -1; - Box.Total := 0; - Box.List := nil; - end; - - procedure ChangeBox (var Box: TColorBox; const C: TColorBin); - begin - with C.Color do - begin - if A < Box.AMin then Box.AMin := A; - if A > Box.AMax then Box.AMax := A; - if B < Box.BMin then Box.BMin := B; - if B > Box.BMax then Box.BMax := B; - if G < Box.GMin then Box.GMin := G; - if G > Box.GMax then Box.GMax := G; - if R < Box.RMin then Box.RMin := R; - if R > Box.RMax then Box.RMax := R; - end; - Inc(Box.Total, C.Number); - end; - - procedure MakeColormap; - var - I, J: LongInt; - CP, Pom: PColorBin; - Cut, LargestIdx, Largest, Size, S: LongInt; - CutA, CutR, CutG, CutB: Boolean; - SumA, SumR, SumG, SumB: LongInt; - Temp: TColorBox; - begin - I := 0; - Boxes := 1; - LargestIdx := 0; - while (I < HashSize) and (Table[I] = nil) do - Inc(i); - if I < HashSize then - begin - // put all colors into Box[0] - InitBox(Box[0]); - repeat - CP := Table[I]; - while CP.Next <> nil do - begin - ChangeBox(Box[0], CP^); - CP := CP.Next; - end; - ChangeBox(Box[0], CP^); - CP.Next := Box[0].List; - Box[0].List := Table[I]; - Table[I] := nil; - repeat - Inc(I) - until (I = HashSize) or (Table[I] <> nil); - until I = HashSize; - // now all colors are in Box[0] - repeat - // cut one color box - Largest := 0; - for I := 0 to Boxes - 1 do - with Box[I] do - begin - Size := (AMax - AMin) * AlphaWeight; - S := (RMax - RMin) * RedWeight; - if S > Size then - Size := S; - S := (GMax - GMin) * GreenWeight; - if S > Size then - Size := S; - S := (BMax - BMin) * BlueWeight; - if S > Size then - Size := S; - if Size > Largest then - begin - Largest := Size; - LargestIdx := I; - end; - end; - if Largest > 0 then - begin - // cutting Box[LargestIdx] into Box[LargestIdx] and Box[Boxes] - CutR := False; - CutG := False; - CutB := False; - CutA := False; - with Box[LargestIdx] do - begin - if (AMax - AMin) * AlphaWeight = Largest then - begin - Cut := (AMax + AMin) shr 1; - CutA := True; - end - else - if (RMax - RMin) * RedWeight = Largest then - begin - Cut := (RMax + RMin) shr 1; - CutR := True; - end - else - if (GMax - GMin) * GreenWeight = Largest then - begin - Cut := (GMax + GMin) shr 1; - CutG := True; - end - else - begin - Cut := (BMax + BMin) shr 1; - CutB := True; - end; - CP := List; - end; - InitBox(Box[LargestIdx]); - InitBox(Box[Boxes]); - repeat - // distribute one color - Pom := CP.Next; - with CP.Color do - begin - if (CutA and (A <= Cut)) or (CutR and (R <= Cut)) or - (CutG and (G <= Cut)) or (CutB and (B <= Cut)) then - I := LargestIdx - else - I := Boxes; - end; - CP.Next := Box[i].List; - Box[i].List := CP; - ChangeBox(Box[i], CP^); - CP := Pom; - until CP = nil; - Inc(Boxes); - end; - until (Boxes = MaxColors) or (Largest = 0); - // compute box representation - for I := 0 to Boxes - 1 do - begin - SumR := 0; - SumG := 0; - SumB := 0; - SumA := 0; - repeat - CP := Box[I].List; - Inc(SumR, CP.Color.R * CP.Number); - Inc(SumG, CP.Color.G * CP.Number); - Inc(SumB, CP.Color.B * CP.Number); - Inc(SumA, CP.Color.A * CP.Number); - Box[I].List := CP.Next; - Dispose(CP); - until Box[I].List = nil; - with Box[I] do - begin - Represented.A := SumA div Total; - Represented.R := SumR div Total; - Represented.G := SumG div Total; - Represented.B := SumB div Total; - AMin := AMin and ChannelMask; - RMin := RMin and ChannelMask; - GMin := GMin and ChannelMask; - BMin := BMin and ChannelMask; - AMax := (AMax and ChannelMask) + (not ChannelMask); - RMax := (RMax and ChannelMask) + (not ChannelMask); - GMax := (GMax and ChannelMask) + (not ChannelMask); - BMax := (BMax and ChannelMask) + (not ChannelMask); - end; - end; - // sort color boxes - for I := 0 to Boxes - 2 do - begin - Largest := 0; - for J := I to Boxes - 1 do - if Box[J].Total > Largest then - begin - Largest := Box[J].Total; - LargestIdx := J; - end; - if LargestIdx <> I then - begin - Temp := Box[I]; - Box[I] := Box[LargestIdx]; - Box[LargestIdx] := Temp; - end; - end; - end; - end; - - procedure FillOutputPalette; - var - I: LongInt; - begin - FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF); - for I := 0 to MaxColors - 1 do - begin - if I < Boxes then - with Box[I].Represented do - begin - DstPal[I].A := A; - DstPal[I].R := R; - DstPal[I].G := G; - DstPal[I].B := B; - end - else - DstPal[I].Color := $FF000000; - end; - end; - - function MapColor(const Col: TColor32Rec) : LongInt; - var - I: LongInt; - begin - I := 0; - with Col do - while (I < Boxes) and ((Box[I].AMin > A) or (Box[I].AMax < A) or - (Box[I].RMin > R) or (Box[I].RMax < R) or (Box[I].GMin > G) or - (Box[I].GMax < G) or (Box[I].BMin > B) or (Box[I].BMax < B)) do - Inc(I); - if I = Boxes then - MapColor := 0 - else - MapColor := I; - end; - - procedure MapImage(Src, Dst: PByte; SrcInfo, DstInfo: PImageFormatInfo); - var - I: LongInt; - Col: TColor32Rec; - begin - for I := 0 to NumPixels - 1 do - begin - Col := GetPixel32Generic(Src, SrcInfo, nil); - IndexSetDstPixel(Dst, DstInfo, MapColor(Col)); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; - end; - -begin - MaxColors := ClampInt(MaxColors, 2, MaxPossibleColors); - - if (raUpdateHistogram in Actions) or (raMapImage in Actions) then - begin - Assert(not SrcInfo.IsSpecial); - Assert(not SrcInfo.IsIndexed); - end; - - if raCreateHistogram in Actions then - FillChar(Table, SizeOf(Table), 0); - - if raUpdateHistogram in Actions then - CreateHistogram(Src, SrcInfo, ChannelMask); - - if raMakeColorMap in Actions then - begin - MakeColorMap; - FillOutputPalette; - end; - - if raMapImage in Actions then - MapImage(Src, Dst, SrcInfo, DstInfo); -end; - -procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, - SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, - DstHeight: LongInt); -var - Info: TImageFormatInfo; - ScaleX, ScaleY, X, Y, Xp, Yp: LongInt; - DstPixel, SrcLine: PByte; -begin - GetImageFormatInfo(SrcImage.Format, Info); - Assert(SrcImage.Format = DstImage.Format); - Assert(not Info.IsSpecial); - // Use integers instead of floats for source image pixel coords - // Xp and Yp coords must be shifted right to get read source image coords - ScaleX := (SrcWidth shl 16) div DstWidth; - ScaleY := (SrcHeight shl 16) div DstHeight; - Yp := 0; - for Y := 0 to DstHeight - 1 do - begin - Xp := 0; - SrcLine := @PByteArray(SrcImage.Bits)[((SrcY + Yp shr 16) * SrcImage.Width + SrcX) * Info.BytesPerPixel]; - DstPixel := @PByteArray(DstImage.Bits)[((DstY + Y) * DstImage.Width + DstX) * Info.BytesPerPixel]; - for X := 0 to DstWidth - 1 do - begin - case Info.BytesPerPixel of - 1: PByte(DstPixel)^ := PByteArray(SrcLine)[Xp shr 16]; - 2: PWord(DstPixel)^ := PWordArray(SrcLine)[Xp shr 16]; - 3: PColor24Rec(DstPixel)^ := PPalette24(SrcLine)[Xp shr 16]; - 4: PColor32(DstPixel)^ := PLongWordArray(SrcLine)[Xp shr 16]; - 6: PColor48Rec(DstPixel)^ := PColor48RecArray(SrcLine)[Xp shr 16]; - 8: PColor64(DstPixel)^ := PInt64Array(SrcLine)[Xp shr 16]; - 16: PColorFPRec(DstPixel)^ := PColorFPRecArray(SrcLine)[Xp shr 16]; - end; - Inc(DstPixel, Info.BytesPerPixel); - Inc(Xp, ScaleX); - end; - Inc(Yp, ScaleY); - end; -end; - -{ Filter function for nearest filtering. Also known as box filter.} -function FilterNearest(Value: Single): Single; -begin - if (Value > -0.5) and (Value <= 0.5) then - Result := 1 - else - Result := 0; -end; - -{ Filter function for linear filtering. Also known as triangle or Bartlett filter.} -function FilterLinear(Value: Single): Single; -begin - if Value < 0.0 then - Value := -Value; - if Value < 1.0 then - Result := 1.0 - Value - else - Result := 0.0; -end; - -{ Cosine filter.} -function FilterCosine(Value: Single): Single; -begin - Result := 0; - if Abs(Value) < 1 then - Result := (Cos(Value * Pi) + 1) / 2; -end; - -{ f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1 } -function FilterHermite(Value: Single): Single; -begin - if Value < 0.0 then - Value := -Value; - if Value < 1 then - Result := (2 * Value - 3) * Sqr(Value) + 1 - else - Result := 0; -end; - -{ Quadratic filter. Also known as Bell.} -function FilterQuadratic(Value: Single): Single; -begin - if Value < 0.0 then - Value := -Value; - if Value < 0.5 then - Result := 0.75 - Sqr(Value) - else - if Value < 1.5 then - begin - Value := Value - 1.5; - Result := 0.5 * Sqr(Value); - end - else - Result := 0.0; -end; - -{ Gaussian filter.} -function FilterGaussian(Value: Single): Single; -begin - Result := Exp(-2.0 * Sqr(Value)) * Sqrt(2.0 / Pi); -end; - -{ 4th order (cubic) b-spline filter.} -function FilterSpline(Value: Single): Single; -var - Temp: Single; -begin - if Value < 0.0 then - Value := -Value; - if Value < 1.0 then - begin - Temp := Sqr(Value); - Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0; - end - else - if Value < 2.0 then - begin - Value := 2.0 - Value; - Result := Sqr(Value) * Value / 6.0; - end - else - Result := 0.0; -end; - -{ Lanczos-windowed sinc filter.} -function FilterLanczos(Value: Single): Single; - - function SinC(Value: Single): Single; - begin - if Value <> 0.0 then - begin - Value := Value * Pi; - Result := Sin(Value) / Value; - end - else - Result := 1.0; - end; - -begin - if Value < 0.0 then - Value := -Value; - if Value < 3.0 then - Result := SinC(Value) * SinC(Value / 3.0) - else - Result := 0.0; -end; - -{ Micthell cubic filter.} -function FilterMitchell(Value: Single): Single; -const - B = 1.0 / 3.0; - C = 1.0 / 3.0; -var - Temp: Single; -begin - if Value < 0.0 then - Value := -Value; - Temp := Sqr(Value); - if Value < 1.0 then - begin - Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) + - ((-18.0 + 12.0 * B + 6.0 * C) * Temp) + - (6.0 - 2.0 * B)); - Result := Value / 6.0; - end - else - if Value < 2.0 then - begin - Value := (((-B - 6.0 * C) * (Value * Temp)) + - ((6.0 * B + 30.0 * C) * Temp) + - ((-12.0 * B - 48.0 * C) * Value) + - (8.0 * B + 24.0 * C)); - Result := Value / 6.0; - end - else - Result := 0.0; -end; - -{ CatmullRom spline filter.} -function FilterCatmullRom(Value: Single): Single; -begin - if Value < 0.0 then - Value := -Value; - if Value < 1.0 then - Result := 0.5 * (2.0 + Sqr(Value) * (-5.0 + 3.0 * Value)) - else - if Value < 2.0 then - Result := 0.5 * (4.0 + Value * (-8.0 + Value * (5.0 - Value))) - else - Result := 0.0; -end; - -procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, - SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, - DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean); -begin - // Calls the other function with filter function and radius defined by Filter - StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY, - DstWidth, DstHeight, SamplingFilterFunctions[Filter], SamplingFilterRadii[Filter], - WrapEdges); -end; - -var - FullEdge: Boolean = True; - -{ The following resampling code is modified and extended code from Graphics32 - library by Alex A. Denisov.} -function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt; - Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable; -var - I, J, K, N: LongInt; - Left, Right, SrcWidth, DstWidth: LongInt; - Weight, Scale, Center, Count: Single; -begin - Result := nil; - K := 0; - SrcWidth := SrcHigh - SrcLow; - DstWidth := DstHigh - DstLow; - - // Check some special cases - if SrcWidth = 1 then - begin - SetLength(Result, DstWidth); - for I := 0 to DstWidth - 1 do - begin - SetLength(Result[I], 1); - Result[I][0].Pos := 0; - Result[I][0].Weight := 1.0; - end; - Exit; - end - else - if (SrcWidth = 0) or (DstWidth = 0) then - Exit; - - if FullEdge then - Scale := DstWidth / SrcWidth - else - Scale := (DstWidth - 1) / (SrcWidth - 1); - - SetLength(Result, DstWidth); - - // Pre-calculate filter contributions for a row or column - if Scale = 0.0 then - begin - Assert(Length(Result) = 1); - SetLength(Result[0], 1); - Result[0][0].Pos := (SrcLow + SrcHigh) div 2; - Result[0][0].Weight := 1.0; - end - else if Scale < 1.0 then - begin - // Sub-sampling - scales from bigger to smaller - Radius := Radius / Scale; - for I := 0 to DstWidth - 1 do - begin - if FullEdge then - Center := SrcLow - 0.5 + (I + 0.5) / Scale - else - Center := SrcLow + I / Scale; - Left := Floor(Center - Radius); - Right := Ceil(Center + Radius); - Count := -1.0; - for J := Left to Right do - begin - Weight := Filter((Center - J) * Scale) * Scale; - if Weight <> 0.0 then - begin - Count := Count + Weight; - K := Length(Result[I]); - SetLength(Result[I], K + 1); - Result[I][K].Pos := ClampInt(J, SrcLow, SrcHigh - 1); - Result[I][K].Weight := Weight; - end; - end; - if Length(Result[I]) = 0 then - begin - SetLength(Result[I], 1); - Result[I][0].Pos := Floor(Center); - Result[I][0].Weight := 1.0; - end - else if Count <> 0.0 then - Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count; - end; - end - else // if Scale > 1.0 then - begin - // Super-sampling - scales from smaller to bigger - Scale := 1.0 / Scale; - for I := 0 to DstWidth - 1 do - begin - if FullEdge then - Center := SrcLow - 0.5 + (I + 0.5) * Scale - else - Center := SrcLow + I * Scale; - Left := Floor(Center - Radius); - Right := Ceil(Center + Radius); - Count := -1.0; - for J := Left to Right do - begin - Weight := Filter(Center - J); - if Weight <> 0.0 then - begin - Count := Count + Weight; - K := Length(Result[I]); - SetLength(Result[I], K + 1); - - if WrapEdges then - begin - if J < 0 then - N := SrcImageWidth + J - else if J >= SrcImageWidth then - N := J - SrcImageWidth - else - N := ClampInt(J, SrcLow, SrcHigh - 1); - end - else - N := ClampInt(J, SrcLow, SrcHigh - 1); - - Result[I][K].Pos := N; - Result[I][K].Weight := Weight; - end; - end; - if Count <> 0.0 then - Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count; - end; - end; -end; - -procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt); -var - I, J: LongInt; -begin - if Length(Map) > 0 then - begin - MinPos := Map[0][0].Pos; - MaxPos := MinPos; - for I := 0 to Length(Map) - 1 do - for J := 0 to Length(Map[I]) - 1 do - begin - if MinPos > Map[I][J].Pos then - MinPos := Map[I][J].Pos; - if MaxPos < Map[I][J].Pos then - MaxPos := Map[I][J].Pos; - end; - end; -end; - -procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, - SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, - DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean); -const - Channel8BitMax: Single = 255.0; -type - TBufferItem = record - A, R, G, B: Integer; - end; -var - MapX, MapY: TMappingTable; - I, J, X, Y: LongInt; - XMinimum, XMaximum: LongInt; - LineBufferFP: array of TColorFPRec; - LineBufferInt: array of TBufferItem; - ClusterX, ClusterY: TCluster; - Weight, AccumA, AccumR, AccumG, AccumB: Single; - IWeight, IAccumA, IAccumR, IAccumG, IAccumB: Integer; - DstLine: PByte; - SrcColor: TColor32Rec; - SrcFloat: TColorFPRec; - Info: TImageFormatInfo; - BytesPerChannel: LongInt; - ChannelValueMax, InvChannelValueMax: Single; - UseOptimizedVersion: Boolean; -begin - GetImageFormatInfo(SrcImage.Format, Info); - Assert(SrcImage.Format = DstImage.Format); - Assert(not Info.IsSpecial and not Info.IsIndexed); - BytesPerChannel := Info.BytesPerPixel div Info.ChannelCount; - UseOptimizedVersion := (BytesPerChannel = 1) and not Info.UsePixelFormat; - - // Create horizontal and vertical mapping tables - MapX := BuildMappingTable(DstX, DstX + DstWidth, SrcX, SrcX + SrcWidth, - SrcImage.Width, Filter, Radius, WrapEdges); - MapY := BuildMappingTable(DstY, DstY + DstHeight, SrcY, SrcY + SrcHeight, - SrcImage.Height, Filter, Radius, WrapEdges); - - if (MapX = nil) or (MapY = nil) then - Exit; - - ClusterX := nil; - ClusterY := nil; - - try - // Find min and max X coords of pixels that will contribute to target image - FindExtremes(MapX, XMinimum, XMaximum); - - if not UseOptimizedVersion then - begin - SetLength(LineBufferFP, XMaximum - XMinimum + 1); - // Following code works for the rest of data formats - for J := 0 to DstHeight - 1 do - begin - // First for each pixel in the current line sample vertically - // and store results in LineBuffer. Then sample horizontally - // using values in LineBuffer. - ClusterY := MapY[J]; - for X := XMinimum to XMaximum do - begin - // Clear accumulators - AccumA := 0; - AccumR := 0; - AccumG := 0; - AccumB := 0; - // For each pixel in line compute weighted sum of pixels - // in source column that will contribute to this pixel - for Y := 0 to Length(ClusterY) - 1 do - begin - // Accumulate this pixel's weighted value - Weight := ClusterY[Y].Weight; - SrcFloat := Info.GetPixelFP(@PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel], @Info, nil); - AccumB := AccumB + SrcFloat.B * Weight; - AccumG := AccumG + SrcFloat.G * Weight; - AccumR := AccumR + SrcFloat.R * Weight; - AccumA := AccumA + SrcFloat.A * Weight; - end; - // Store accumulated value for this pixel in buffer - with LineBufferFP[X - XMinimum] do - begin - A := AccumA; - R := AccumR; - G := AccumG; - B := AccumB; - end; - end; - - DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX) * Info.BytesPerPixel]; - // Now compute final colors for targte pixels in the current row - // by sampling horizontally - for I := 0 to DstWidth - 1 do - begin - ClusterX := MapX[I]; - // Clear accumulator - AccumA := 0; - AccumR := 0; - AccumG := 0; - AccumB := 0; - // Compute weighted sum of values (which are already - // computed weighted sums of pixels in source columns stored in LineBuffer) - // that will contribute to the current target pixel - for X := 0 to Length(ClusterX) - 1 do - begin - Weight := ClusterX[X].Weight; - with LineBufferFP[ClusterX[X].Pos - XMinimum] do - begin - AccumB := AccumB + B * Weight; - AccumG := AccumG + G * Weight; - AccumR := AccumR + R * Weight; - AccumA := AccumA + A * Weight; - end; - end; - - // Now compute final color to be written to dest image - SrcFloat.A := AccumA; - SrcFloat.R := AccumR; - SrcFloat.G := AccumG; - SrcFloat.B := AccumB; - - Info.SetPixelFP(DstLine, @Info, nil, SrcFloat); - Inc(DstLine, Info.BytesPerPixel); - end; - end; - end - else - begin - SetLength(LineBufferInt, XMaximum - XMinimum + 1); - // Following code is optimized for images with 8 bit channels - for J := 0 to DstHeight - 1 do - begin - ClusterY := MapY[J]; - for X := XMinimum to XMaximum do - begin - IAccumA := 0; - IAccumR := 0; - IAccumG := 0; - IAccumB := 0; - for Y := 0 to Length(ClusterY) - 1 do - begin - IWeight := Round(256 * ClusterY[Y].Weight); - CopyPixel( - @PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel], - @SrcColor, Info.BytesPerPixel); - - IAccumB := IAccumB + SrcColor.B * IWeight; - IAccumG := IAccumG + SrcColor.G * IWeight; - IAccumR := IAccumR + SrcColor.R * IWeight; - IAccumA := IAccumA + SrcColor.A * IWeight; - end; - with LineBufferInt[X - XMinimum] do - begin - A := IAccumA; - R := IAccumR; - G := IAccumG; - B := IAccumB; - end; - end; - - DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX)* Info.BytesPerPixel]; - - for I := 0 to DstWidth - 1 do - begin - ClusterX := MapX[I]; - IAccumA := 0; - IAccumR := 0; - IAccumG := 0; - IAccumB := 0; - for X := 0 to Length(ClusterX) - 1 do - begin - IWeight := Round(256 * ClusterX[X].Weight); - with LineBufferInt[ClusterX[X].Pos - XMinimum] do - begin - IAccumB := IAccumB + B * IWeight; - IAccumG := IAccumG + G * IWeight; - IAccumR := IAccumR + R * IWeight; - IAccumA := IAccumA + A * IWeight; - end; - end; - - SrcColor.B := ClampInt(IAccumB, 0, $00FF0000) shr 16; - SrcColor.G := ClampInt(IAccumG, 0, $00FF0000) shr 16; - SrcColor.R := ClampInt(IAccumR, 0, $00FF0000) shr 16; - SrcColor.A := ClampInt(IAccumA, 0, $00FF0000) shr 16; - - CopyPixel(@SrcColor, DstLine, Info.BytesPerPixel); - Inc(DstLine, Info.BytesPerPixel); - end; - end; - end; - - finally - MapX := nil; - MapY := nil; - end; -end; - -procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt; - var SmallerLevel: TImageData); -var - Filter: TSamplingFilter; - Info: TImageFormatInfo; - CompatibleCopy: TImageData; -begin - Assert(TestImage(BiggerLevel)); - Filter := TSamplingFilter(GetOption(ImagingMipMapFilter)); - - // If we have special format image we must create copy to allow pixel access - GetImageFormatInfo(BiggerLevel.Format, Info); - if Info.IsSpecial then - begin - InitImage(CompatibleCopy); - CloneImage(BiggerLevel, CompatibleCopy); - ConvertImage(CompatibleCopy, ifDefault); - end - else - CompatibleCopy := BiggerLevel; - - // Create new smaller image - NewImage(Width, Height, CompatibleCopy.Format, SmallerLevel); - GetImageFormatInfo(CompatibleCopy.Format, Info); - // If input is indexed we must copy its palette - if Info.IsIndexed then - CopyPalette(CompatibleCopy.Palette, SmallerLevel.Palette, 0, 0, Info.PaletteEntries); - - if (Filter = sfNearest) or Info.IsIndexed then - begin - StretchNearest(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height, - SmallerLevel, 0, 0, Width, Height); - end - else - begin - StretchResample(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height, - SmallerLevel, 0, 0, Width, Height, Filter); - end; - - // Free copy and convert result to special format if necessary - if CompatibleCopy.Format <> BiggerLevel.Format then - begin - ConvertImage(SmallerLevel, BiggerLevel.Format); - FreeImage(CompatibleCopy); - end; -end; - - -{ Various format support functions } - -procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); -begin - case BytesPerPixel of - 1: PByte(Dest)^ := PByte(Src)^; - 2: PWord(Dest)^ := PWord(Src)^; - 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^; - 4: PLongWord(Dest)^ := PLongWord(Src)^; - 6: PColor48Rec(Dest)^ := PColor48Rec(Src)^; - 8: PInt64(Dest)^ := PInt64(Src)^; - 16: PColorFPRec(Dest)^ := PColorFPRec(Src)^; - end; -end; - -function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; -begin - case BytesPerPixel of - 1: Result := PByte(PixelA)^ = PByte(PixelB)^; - 2: Result := PWord(PixelA)^ = PWord(PixelB)^; - 3: Result := (PWord(PixelA)^ = PWord(PixelB)^) and - (PColor24Rec(PixelA).R = PColor24Rec(PixelB).R); - 4: Result := PLongWord(PixelA)^ = PLongWord(PixelB)^; - 6: Result := (PLongWord(PixelA)^ = PLongWord(PixelB)^) and - (PColor48Rec(PixelA).R = PColor48Rec(PixelB).R); - 8: Result := PInt64(PixelA)^ = PInt64(PixelB)^; - 16: Result := (PFloatHelper(PixelA).Data2 = PFloatHelper(PixelB).Data2) and - (PFloatHelper(PixelA).Data1 = PFloatHelper(PixelB).Data1); - else - Result := False; - end; -end; - -procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat, - DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32); -var - SrcInfo, DstInfo: PImageFormatInfo; - PixFP: TColorFPRec; -begin - SrcInfo := FInfos[SrcFormat]; - DstInfo := FInfos[DstFormat]; - - PixFP := GetPixelFPGeneric(SrcPixel, SrcInfo, SrcPalette); - SetPixelFPGeneric(DstPixel, DstInfo, DstPalette, PixFP); -end; - -procedure ClampFloatPixel(var PixF: TColorFPRec); -begin - if PixF.A > 1.0 then - PixF.A := 1.0; - if PixF.R > 1.0 then - PixF.R := 1.0; - if PixF.G > 1.0 then - PixF.G := 1.0; - if PixF.B > 1.0 then - PixF.B := 1.0; - - if PixF.A < 0.0 then - PixF.A := 0.0; - if PixF.R < 0.0 then - PixF.R := 0.0; - if PixF.G < 0.0 then - PixF.G := 0.0; - if PixF.B < 0.0 then - PixF.B := 0.0; -end; - -procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height, - Bpp, WidthBytes: LongInt); -var - I, W: LongInt; -begin - W := Width * Bpp; - for I := 0 to Height - 1 do - Move(PByteArray(DataIn)[I * W], PByteArray(DataOut)[I * WidthBytes], W); -end; - -procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height, - Bpp, WidthBytes: LongInt); -var - I, W: LongInt; -begin - W := Width * Bpp; - for I := 0 to Height - 1 do - Move(PByteArray(DataIn)[I * WidthBytes], PByteArray(DataOut)[I * W], W); -end; - -procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height, - WidthBytes: LongInt); -const - Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01); - Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0); -var - X, Y: LongInt; -begin - for Y := 0 to Height - 1 do - for X := 0 to Width - 1 do - PByteArray(DataOut)[Y * Width + X] := - (PByteArray(DataIn)[Y * WidthBytes + X shr 3] and - Mask1[X and 7]) shr Shift1[X and 7]; -end; - -procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height, - WidthBytes: LongInt); -const - Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03); - Shift2: array[0..3] of Byte = (6, 4, 2, 0); -var - X, Y: LongInt; -begin - for Y := 0 to Height - 1 do - for X := 0 to Width - 1 do - PByteArray(DataOut)[Y * Width + X] := - (PByteArray(DataIn)[X shr 2] and Mask2[X and 3]) shr - Shift2[X and 3]; -end; - -procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height, - WidthBytes: LongInt); -const - Mask4: array[0..1] of Byte = ($F0, $0F); - Shift4: array[0..1] of Byte = (4, 0); -var - X, Y: LongInt; -begin - for Y := 0 to Height - 1 do - for X := 0 to Width - 1 do - PByteArray(DataOut)[Y * Width + X] := - (PByteArray(DataIn)[Y * WidthBytes + X shr 1] and - Mask4[X and 1]) shr Shift4[X and 1]; -end; - -function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean; -var - I: LongInt; -begin - Result := False; - for I := 0 to NumPixels - 1 do - begin - if Data^ >= 1 shl 15 then - begin - Result := True; - Exit; - end; - Inc(Data); - end; -end; - -function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean; -var - I: LongInt; -begin - Result := False; - for I := 0 to NumPixels - 1 do - begin - if Data^ >= 1 shl 24 then - begin - Result := True; - Exit; - end; - Inc(Data); - end; -end; - -function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo; - LineWidth, Index: LongInt): Pointer; -var - LineBytes: LongInt; -begin - Assert(not FormatInfo.IsSpecial); - LineBytes := FormatInfo.GetPixelsSize(FormatInfo.Format, LineWidth, 1); - Result := @PByteArray(ImageBits)[Index * LineBytes]; -end; - -function IsImageFormatValid(Format: TImageFormat): Boolean; -begin - Result := FInfos[Format] <> nil; -end; - -const - HalfMin: Single = 5.96046448e-08; // Smallest positive half - HalfMinNorm: Single = 6.10351562e-05; // Smallest positive normalized half - HalfMax: Single = 65504.0; // Largest positive half - HalfEpsilon: Single = 0.00097656; // Smallest positive e for which half (1.0 + e) != half (1.0) - HalfNaN: THalfFloat = 65535; - HalfPosInf: THalfFloat = 31744; - HalfNegInf: THalfFloat = 64512; - - -{ - - Half/Float conversions inspired by half class from OpenEXR library. - - - Float (Pascal Single type) is an IEEE 754 single-precision - - floating point number. - - Bit layout of Single: - - 31 (msb) - | - | 30 23 - | | | - | | | 22 0 (lsb) - | | | | | - X XXXXXXXX XXXXXXXXXXXXXXXXXXXXXXX - s e m - - Bit layout of half: - - 15 (msb) - | - | 14 10 - | | | - | | | 9 0 (lsb) - | | | | | - X XXXXX XXXXXXXXXX - s e m - - S is the sign-bit, e is the exponent and m is the significand (mantissa). -} - - -function HalfToFloat(Half: THalfFloat): Single; -var - Dst, Sign, Mantissa: LongWord; - Exp: LongInt; -begin - // extract sign, exponent, and mantissa from half number - Sign := Half shr 15; - Exp := (Half and $7C00) shr 10; - Mantissa := Half and 1023; - - if (Exp > 0) and (Exp < 31) then - begin - // common normalized number - Exp := Exp + (127 - 15); - Mantissa := Mantissa shl 13; - Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa; - // Result := Power(-1, Sign) * Power(2, Exp - 15) * (1 + Mantissa / 1024); - end - else if (Exp = 0) and (Mantissa = 0) then - begin - // zero - preserve sign - Dst := Sign shl 31; - end - else if (Exp = 0) and (Mantissa <> 0) then - begin - // denormalized number - renormalize it - while (Mantissa and $00000400) = 0 do - begin - Mantissa := Mantissa shl 1; - Dec(Exp); - end; - Inc(Exp); - Mantissa := Mantissa and not $00000400; - // now assemble normalized number - Exp := Exp + (127 - 15); - Mantissa := Mantissa shl 13; - Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa; - // Result := Power(-1, Sign) * Power(2, -14) * (Mantissa / 1024); - end - else if (Exp = 31) and (Mantissa = 0) then - begin - // +/- infinity - Dst := (Sign shl 31) or $7F800000; - end - else //if (Exp = 31) and (Mantisa <> 0) then - begin - // not a number - preserve sign and mantissa - Dst := (Sign shl 31) or $7F800000 or (Mantissa shl 13); - end; - - // reinterpret LongWord as Single - Result := PSingle(@Dst)^; -end; - -function FloatToHalf(Float: Single): THalfFloat; -var - Src: LongWord; - Sign, Exp, Mantissa: LongInt; -begin - Src := PLongWord(@Float)^; - // extract sign, exponent, and mantissa from Single number - Sign := Src shr 31; - Exp := LongInt((Src and $7F800000) shr 23) - 127 + 15; - Mantissa := Src and $007FFFFF; - - if (Exp > 0) and (Exp < 30) then - begin - // simple case - round the significand and combine it with the sign and exponent - Result := (Sign shl 15) or (Exp shl 10) or ((Mantissa + $00001000) shr 13); - end - else if Src = 0 then - begin - // input float is zero - return zero - Result := 0; - end - else - begin - // difficult case - lengthy conversion - if Exp <= 0 then - begin - if Exp < -10 then - begin - // input float's value is less than HalfMin, return zero - Result := 0; - end - else - begin - // Float is a normalized Single whose magnitude is less than HalfNormMin. - // We convert it to denormalized half. - Mantissa := (Mantissa or $00800000) shr (1 - Exp); - // round to nearest - if (Mantissa and $00001000) > 0 then - Mantissa := Mantissa + $00002000; - // assemble Sign and Mantissa (Exp is zero to get denotmalized number) - Result := (Sign shl 15) or (Mantissa shr 13); - end; - end - else if Exp = 255 - 127 + 15 then - begin - if Mantissa = 0 then - begin - // input float is infinity, create infinity half with original sign - Result := (Sign shl 15) or $7C00; - end - else - begin - // input float is NaN, create half NaN with original sign and mantissa - Result := (Sign shl 15) or $7C00 or (Mantissa shr 13); - end; - end - else - begin - // Exp is > 0 so input float is normalized Single - - // round to nearest - if (Mantissa and $00001000) > 0 then - begin - Mantissa := Mantissa + $00002000; - if (Mantissa and $00800000) > 0 then - begin - Mantissa := 0; - Exp := Exp + 1; - end; - end; - - if Exp > 30 then - begin - // exponent overflow - return infinity half - Result := (Sign shl 15) or $7C00; - end - else - // assemble normalized half - Result := (Sign shl 15) or (Exp shl 10) or (Mantissa shr 13); - end; - end; -end; - -function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; -begin - Result.A := HalfToFloat(ColorHF.A); - Result.R := HalfToFloat(ColorHF.R); - Result.G := HalfToFloat(ColorHF.G); - Result.B := HalfToFloat(ColorHF.B); -end; - -function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; -begin - Result.A := FloatToHalf(ColorFP.A); - Result.R := FloatToHalf(ColorFP.R); - Result.G := FloatToHalf(ColorFP.G); - Result.B := FloatToHalf(ColorFP.B); -end; - -procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData); -var - I: Integer; - Pix: PColor32; -begin - InitImage(PalImage); - NewImage(Entries, 1, ifA8R8G8B8, PalImage); - Pix := PalImage.Bits; - for I := 0 to Entries - 1 do - begin - Pix^ := Pal[I].Color; - Inc(Pix); - end; -end; - - -{ Pixel readers/writers for different image formats } - -procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; - var Pix: TColor64Rec); -var - A, R, G, B: Byte; -begin - FillChar(Pix, SizeOf(Pix), 0); - // returns 64 bit color value with 16 bits for each channel - case SrcInfo.BytesPerPixel of - 1: - begin - PFGetARGB(SrcInfo.PixelFormat^, Src^, A, R, G, B); - Pix.A := A shl 8; - Pix.R := R shl 8; - Pix.G := G shl 8; - Pix.B := B shl 8; - end; - 2: - begin - PFGetARGB(SrcInfo.PixelFormat^, PWord(Src)^, A, R, G, B); - Pix.A := A shl 8; - Pix.R := R shl 8; - Pix.G := G shl 8; - Pix.B := B shl 8; - end; - 3: - with Pix do - begin - R := MulDiv(PColor24Rec(Src).R, 65535, 255); - G := MulDiv(PColor24Rec(Src).G, 65535, 255); - B := MulDiv(PColor24Rec(Src).B, 65535, 255); - end; - 4: - with Pix do - begin - A := MulDiv(PColor32Rec(Src).A, 65535, 255); - R := MulDiv(PColor32Rec(Src).R, 65535, 255); - G := MulDiv(PColor32Rec(Src).G, 65535, 255); - B := MulDiv(PColor32Rec(Src).B, 65535, 255); - end; - 6: - with Pix do - begin - R := PColor48Rec(Src).R; - G := PColor48Rec(Src).G; - B := PColor48Rec(Src).B; - end; - 8: Pix.Color := PColor64(Src)^; - end; - // if src has no alpha, we set it to max (otherwise we would have to - // test if dest has alpha or not in each ChannelToXXX function) - if not SrcInfo.HasAlphaChannel then - Pix.A := 65535; - - if SrcInfo.IsRBSwapped then - SwapValues(Pix.R, Pix.B); -end; - -procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; - const Pix: TColor64Rec); -var - PixW: TColor64Rec; -begin - PixW := Pix; - if DstInfo.IsRBSwapped then - SwapValues(PixW.R, PixW.B); - // Pix contains 64 bit color value with 16 bit for each channel - case DstInfo.BytesPerPixel of - 1: Dst^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8, - PixW.R shr 8, PixW.G shr 8, PixW.B shr 8); - 2: PWord(Dst)^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8, - PixW.R shr 8, PixW.G shr 8, PixW.B shr 8); - 3: - with PColor24Rec(Dst)^ do - begin - R := MulDiv(PixW.R, 255, 65535); - G := MulDiv(PixW.G, 255, 65535); - B := MulDiv(PixW.B, 255, 65535); - end; - 4: - with PColor32Rec(Dst)^ do - begin - A := MulDiv(PixW.A, 255, 65535); - R := MulDiv(PixW.R, 255, 65535); - G := MulDiv(PixW.G, 255, 65535); - B := MulDiv(PixW.B, 255, 65535); - end; - 6: - with PColor48Rec(Dst)^ do - begin - R := PixW.R; - G := PixW.G; - B := PixW.B; - end; - 8: PColor64(Dst)^ := PixW.Color; - end; -end; - -procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; - var Gray: TColor64Rec; var Alpha: Word); -begin - FillChar(Gray, SizeOf(Gray), 0); - // Source alpha is scaled to 16 bits and stored in Alpha, - // grayscale value is scaled to 64 bits and stored in Gray - case SrcInfo.BytesPerPixel of - 1: Gray.A := MulDiv(Src^, 65535, 255); - 2: - if SrcInfo.HasAlphaChannel then - with PWordRec(Src)^ do - begin - Alpha := MulDiv(High, 65535, 255); - Gray.A := MulDiv(Low, 65535, 255); - end - else - Gray.A := PWord(Src)^; - 4: - if SrcInfo.HasAlphaChannel then - with PLongWordRec(Src)^ do - begin - Alpha := High; - Gray.A := Low; - end - else - with PLongWordRec(Src)^ do - begin - Gray.A := High; - Gray.R := Low; - end; - 8: Gray.Color := PColor64(Src)^; - end; - // if src has no alpha, we set it to max (otherwise we would have to - // test if dest has alpha or not in each GrayToXXX function) - if not SrcInfo.HasAlphaChannel then - Alpha := 65535; -end; - -procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; - const Gray: TColor64Rec; Alpha: Word); -begin - // Gray contains grayscale value scaled to 64 bits, Alpha contains - // alpha value scaled to 16 bits - case DstInfo.BytesPerPixel of - 1: Dst^ := MulDiv(Gray.A, 255, 65535); - 2: - if DstInfo.HasAlphaChannel then - with PWordRec(Dst)^ do - begin - High := MulDiv(Alpha, 255, 65535); - Low := MulDiv(Gray.A, 255, 65535); - end - else - PWord(Dst)^ := Gray.A; - 4: - if DstInfo.HasAlphaChannel then - with PLongWordRec(Dst)^ do - begin - High := Alpha; - Low := Gray.A; - end - else - with PLongWordRec(Dst)^ do - begin - High := Gray.A; - Low := Gray.R; - end; - 8: PColor64(Dst)^ := Gray.Color; - end; -end; - -procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; - var Pix: TColorFPRec); -var - PixHF: TColorHFRec; -begin - if SrcInfo.BytesPerPixel in [4, 16] then - begin - // IEEE 754 single-precision channels - FillChar(Pix, SizeOf(Pix), 0); - case SrcInfo.BytesPerPixel of - 4: Pix.R := PSingle(Src)^; - 16: Pix := PColorFPRec(Src)^; - end; - end - else - begin - // half float channels - FillChar(PixHF, SizeOf(PixHF), 0); - case SrcInfo.BytesPerPixel of - 2: PixHF.R := PHalfFloat(Src)^; - 8: PixHF := PColorHFRec(Src)^; - end; - Pix := ColorHalfToFloat(PixHF); - end; - // if src has no alpha, we set it to max (otherwise we would have to - // test if dest has alpha or not in each FloatToXXX function) - if not SrcInfo.HasAlphaChannel then - Pix.A := 1.0; - if SrcInfo.IsRBSwapped then - SwapValues(Pix.R, Pix.B); -end; - -procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; - const Pix: TColorFPRec); -var - PixW: TColorFPRec; - PixHF: TColorHFRec; -begin - PixW := Pix; - if DstInfo.IsRBSwapped then - SwapValues(PixW.R, PixW.B); - if DstInfo.BytesPerPixel in [4, 16] then - begin - case DstInfo.BytesPerPixel of - 4: PSingle(Dst)^ := PixW.R; - 16: PColorFPRec(Dst)^ := PixW; - end; - end - else - begin - PixHF := ColorFloatToHalf(PixW); - case DstInfo.BytesPerPixel of - 2: PHalfFloat(Dst)^ := PixHF.R; - 8: PColorHFRec(Dst)^ := PixHF; - end; - end; -end; - -procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; - var Index: LongWord); -begin - case SrcInfo.BytesPerPixel of - 1: Index := Src^; - end; -end; - -procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; - Index: LongWord); -begin - case DstInfo.BytesPerPixel of - 1: Dst^ := Byte(Index); - 2: PWord(Dst)^ := Word(Index); - 4: PLongWord(Dst)^ := Index; - end; -end; - - -{ Pixel readers/writers for 32bit and FP colors} - -function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; -var - Pix64: TColor64Rec; - PixF: TColorFPRec; - Alpha: Word; - Index: LongWord; -begin - if Info.Format = ifA8R8G8B8 then - begin - Result := PColor32Rec(Bits)^ - end - else if Info.Format = ifR8G8B8 then - begin - PColor24Rec(@Result)^ := PColor24Rec(Bits)^; - Result.A := $FF; - end - else if Info.IsFloatingPoint then - begin - FloatGetSrcPixel(Bits, Info, PixF); - Result.A := ClampToByte(Round(PixF.A * 255.0)); - Result.R := ClampToByte(Round(PixF.R * 255.0)); - Result.G := ClampToByte(Round(PixF.G * 255.0)); - Result.B := ClampToByte(Round(PixF.B * 255.0)); - end - else if Info.HasGrayChannel then - begin - GrayGetSrcPixel(Bits, Info, Pix64, Alpha); - Result.A := MulDiv(Alpha, 255, 65535); - Result.R := MulDiv(Pix64.A, 255, 65535); - Result.G := MulDiv(Pix64.A, 255, 65535); - Result.B := MulDiv(Pix64.A, 255, 65535); - end - else if Info.IsIndexed then - begin - IndexGetSrcPixel(Bits, Info, Index); - Result := Palette[Index]; - end - else - begin - ChannelGetSrcPixel(Bits, Info, Pix64); - Result.A := MulDiv(Pix64.A, 255, 65535); - Result.R := MulDiv(Pix64.R, 255, 65535); - Result.G := MulDiv(Pix64.G, 255, 65535); - Result.B := MulDiv(Pix64.B, 255, 65535); - end; -end; - -procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); -var - Pix64: TColor64Rec; - PixF: TColorFPRec; - Alpha: Word; - Index: LongWord; -begin - if Info.Format = ifA8R8G8B8 then - begin - PColor32Rec(Bits)^ := Color - end - else if Info.Format = ifR8G8B8 then - begin - PColor24Rec(Bits)^ := Color.Color24Rec; - end - else if Info.IsFloatingPoint then - begin - PixF.A := Color.A * OneDiv8Bit; - PixF.R := Color.R * OneDiv8Bit; - PixF.G := Color.G * OneDiv8Bit; - PixF.B := Color.B * OneDiv8Bit; - FloatSetDstPixel(Bits, Info, PixF); - end - else if Info.HasGrayChannel then - begin - Alpha := MulDiv(Color.A, 65535, 255); - Pix64.Color := 0; - Pix64.A := MulDiv(Round(GrayConv.R * Color.R + GrayConv.G * Color.G + - GrayConv.B * Color.B), 65535, 255); - GraySetDstPixel(Bits, Info, Pix64, Alpha); - end - else if Info.IsIndexed then - begin - Index := FindColor(Palette, Info.PaletteEntries, Color.Color); - IndexSetDstPixel(Bits, Info, Index); - end - else - begin - Pix64.A := MulDiv(Color.A, 65535, 255); - Pix64.R := MulDiv(Color.R, 65535, 255); - Pix64.G := MulDiv(Color.G, 65535, 255); - Pix64.B := MulDiv(Color.B, 65535, 255); - ChannelSetDstPixel(Bits, Info, Pix64); - end; -end; - -function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; -var - Pix32: TColor32Rec; - Pix64: TColor64Rec; - Alpha: Word; - Index: LongWord; -begin - if Info.IsFloatingPoint then - begin - FloatGetSrcPixel(Bits, Info, Result); - end - else if Info.HasGrayChannel then - begin - GrayGetSrcPixel(Bits, Info, Pix64, Alpha); - Result.A := Alpha * OneDiv16Bit; - Result.R := Pix64.A * OneDiv16Bit; - Result.G := Pix64.A * OneDiv16Bit; - Result.B := Pix64.A * OneDiv16Bit; - end - else if Info.IsIndexed then - begin - IndexGetSrcPixel(Bits, Info, Index); - Pix32 := Palette[Index]; - Result.A := Pix32.A * OneDiv8Bit; - Result.R := Pix32.R * OneDiv8Bit; - Result.G := Pix32.G * OneDiv8Bit; - Result.B := Pix32.B * OneDiv8Bit; - end - else - begin - ChannelGetSrcPixel(Bits, Info, Pix64); - Result.A := Pix64.A * OneDiv16Bit; - Result.R := Pix64.R * OneDiv16Bit; - Result.G := Pix64.G * OneDiv16Bit; - Result.B := Pix64.B * OneDiv16Bit; - end; -end; - -procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); -var - Pix32: TColor32Rec; - Pix64: TColor64Rec; - Alpha: Word; - Index: LongWord; -begin - if Info.IsFloatingPoint then - begin - FloatSetDstPixel(Bits, Info, Color); - end - else if Info.HasGrayChannel then - begin - Alpha := ClampToWord(Round(Color.A * 65535.0)); - Pix64.Color := 0; - Pix64.A := ClampToWord(Round((GrayConv.R * Color.R + GrayConv.G * Color.G + - GrayConv.B * Color.B) * 65535.0)); - GraySetDstPixel(Bits, Info, Pix64, Alpha); - end - else if Info.IsIndexed then - begin - Pix32.A := ClampToByte(Round(Color.A * 255.0)); - Pix32.R := ClampToByte(Round(Color.R * 255.0)); - Pix32.G := ClampToByte(Round(Color.G * 255.0)); - Pix32.B := ClampToByte(Round(Color.B * 255.0)); - Index := FindColor(Palette, Info.PaletteEntries, Pix32.Color); - IndexSetDstPixel(Bits, Info, Index); - end - else - begin - Pix64.A := ClampToWord(Round(Color.A * 65535.0)); - Pix64.R := ClampToWord(Round(Color.R * 65535.0)); - Pix64.G := ClampToWord(Round(Color.G * 65535.0)); - Pix64.B := ClampToWord(Round(Color.B * 65535.0)); - ChannelSetDstPixel(Bits, Info, Pix64); - end; -end; - - -{ Image format conversion functions } - -procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -var - I: LongInt; - Pix64: TColor64Rec; -begin - // two most common conversions (RGB->ARGB and ARGB->RGB for 24/32 bit - // images) are made separately from general ARGB conversion to - // make them faster - if (SrcInfo.BytesPerPixel = 3) and (DstInfo.BytesPerPixel = 4) then - for I := 0 to NumPixels - 1 do - begin - PColor24Rec(Dst)^ := PColor24Rec(Src)^; - if DstInfo.HasAlphaChannel then - PColor32Rec(Dst).A := 255; - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end - else - if (SrcInfo.BytesPerPixel = 4) and (DstInfo.BytesPerPixel = 3) then - for I := 0 to NumPixels - 1 do - begin - PColor24Rec(Dst)^ := PColor24Rec(Src)^; - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end - else - for I := 0 to NumPixels - 1 do - begin - // general ARGB conversion - ChannelGetSrcPixel(Src, SrcInfo, Pix64); - ChannelSetDstPixel(Dst, DstInfo, Pix64); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -var - I: LongInt; - Pix64: TColor64Rec; - Alpha: Word; -begin - // two most common conversions (R8G8B8->Gray8 nad A8R8G8B8->Gray8) - // are made separately from general conversions to make them faster - if (SrcInfo.BytesPerPixel in [3, 4]) and (DstInfo.Format = ifGray8) then - for I := 0 to NumPixels - 1 do - begin - Dst^ := Round(GrayConv.R * PColor24Rec(Src).R + GrayConv.G * PColor24Rec(Src).G + - GrayConv.B * PColor24Rec(Src).B); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end - else - for I := 0 to NumPixels - 1 do - begin - ChannelGetSrcPixel(Src, SrcInfo, Pix64); - - // alpha is saved from source pixel to Alpha, - // Gray value is computed and set to highest word of Pix64 so - // Pix64.Color contains grayscale value scaled to 64 bits - Alpha := Pix64.A; - with GrayConv do - Pix64.A := Round(R * Pix64.R + G * Pix64.G + B * Pix64.B); - - GraySetDstPixel(Dst, DstInfo, Pix64, Alpha); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -var - I: LongInt; - Pix64: TColor64Rec; - PixF: TColorFPRec; -begin - for I := 0 to NumPixels - 1 do - begin - ChannelGetSrcPixel(Src, SrcInfo, Pix64); - - // floating point channel values are scaled to 1.0 - PixF.A := Pix64.A * OneDiv16Bit; - PixF.R := Pix64.R * OneDiv16Bit; - PixF.G := Pix64.G * OneDiv16Bit; - PixF.B := Pix64.B * OneDiv16Bit; - - FloatSetDstPixel(Dst, DstInfo, PixF); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; DstPal: PPalette32); -begin - ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries, - GetOption(ImagingColorReductionMask), DstPal); -end; - -procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -var - I: LongInt; - Gray: TColor64Rec; - Alpha: Word; -begin - // two most common conversions (Gray8->Gray16 nad Gray16->Gray8) - // are made separately from general conversions to make them faster - if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifGray16) then - begin - for I := 0 to NumPixels - 1 do - PWordArray(Dst)[I] := PByteArray(Src)[I] shl 8; - end - else - if (DstInfo.Format = ifGray8) and (SrcInfo.Format = ifGray16) then - begin - for I := 0 to NumPixels - 1 do - PByteArray(Dst)[I] := PWordArray(Src)[I] shr 8; - end - else - for I := 0 to NumPixels - 1 do - begin - // general grayscale conversion - GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha); - GraySetDstPixel(Dst, DstInfo, Gray, Alpha); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -var - I: LongInt; - Pix64: TColor64Rec; - Alpha: Word; -begin - // two most common conversions (Gray8->R8G8B8 nad Gray8->A8R8G8B8) - // are made separately from general conversions to make them faster - if (DstInfo.BytesPerPixel in [3, 4]) and (SrcInfo.Format = ifGray8) then - for I := 0 to NumPixels - 1 do - begin - PColor24Rec(Dst).R := Src^; - PColor24Rec(Dst).G := Src^; - PColor24Rec(Dst).B := Src^; - if DstInfo.HasAlphaChannel then - PColor32Rec(Dst).A := $FF; - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end - else - for I := 0 to NumPixels - 1 do - begin - GrayGetSrcPixel(Src, SrcInfo, Pix64, Alpha); - - // most significant word of grayscale value is used for - // each channel and alpha channel is set to Alpha - Pix64.R := Pix64.A; - Pix64.G := Pix64.A; - Pix64.B := Pix64.A; - Pix64.A := Alpha; - - ChannelSetDstPixel(Dst, DstInfo, Pix64); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -var - I: LongInt; - Gray: TColor64Rec; - PixF: TColorFPRec; - Alpha: Word; -begin - for I := 0 to NumPixels - 1 do - begin - GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha); - // most significant word of grayscale value is used for - // each channel and alpha channel is set to Alpha - // then all is scaled to 0..1 - PixF.R := Gray.A * OneDiv16Bit; - PixF.G := Gray.A * OneDiv16Bit; - PixF.B := Gray.A * OneDiv16Bit; - PixF.A := Alpha * OneDiv16Bit; - - FloatSetDstPixel(Dst, DstInfo, PixF); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; DstPal: PPalette32); -var - I: LongInt; - Idx: LongWord; - Gray: TColor64Rec; - Alpha, Shift: Word; -begin - FillGrayscalePalette(DstPal, DstInfo.PaletteEntries); - Shift := Log2Int(DstInfo.PaletteEntries); - // most common conversion (Gray8->Index8) - // is made separately from general conversions to make it faster - if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifIndex8) then - for I := 0 to NumPixels - 1 do - begin - Dst^ := Src^; - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end - else - for I := 0 to NumPixels - 1 do - begin - // gray value is read from src and index to precomputed - // grayscale palette is computed and written to dst - // (we assume here that there will be no more than 65536 palette - // entries in dst format, gray value is shifted so the highest - // gray value match the highest possible index in palette) - GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha); - Idx := Gray.A shr (16 - Shift); - IndexSetDstPixel(Dst, DstInfo, Idx); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -var - I: LongInt; - PixF: TColorFPRec; -begin - for I := 0 to NumPixels - 1 do - begin - // general floating point conversion - FloatGetSrcPixel(Src, SrcInfo, PixF); - FloatSetDstPixel(Dst, DstInfo, PixF); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -var - I: LongInt; - Pix64: TColor64Rec; - PixF: TColorFPRec; -begin - for I := 0 to NumPixels - 1 do - begin - FloatGetSrcPixel(Src, SrcInfo, PixF); - ClampFloatPixel(PixF); - - // floating point channel values are scaled to 1.0 - Pix64.A := ClampToWord(Round(PixF.A * 65535)); - Pix64.R := ClampToWord(Round(PixF.R * 65535)); - Pix64.G := ClampToWord(Round(PixF.G * 65535)); - Pix64.B := ClampToWord(Round(PixF.B * 65535)); - - ChannelSetDstPixel(Dst, DstInfo, Pix64); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo); -var - I: LongInt; - PixF: TColorFPRec; - Gray: TColor64Rec; - Alpha: Word; -begin - for I := 0 to NumPixels - 1 do - begin - FloatGetSrcPixel(Src, SrcInfo, PixF); - ClampFloatPixel(PixF); - - // alpha is saved from source pixel to Alpha, - // Gray value is computed and set to highest word of Pix64 so - // Pix64.Color contains grayscale value scaled to 64 bits - Alpha := ClampToWord(Round(PixF.A * 65535.0)); - Gray.A := ClampToWord(Round((GrayConv.R * PixF.R + GrayConv.G * PixF.G + - GrayConv.B * PixF.B) * 65535.0)); - - GraySetDstPixel(Dst, DstInfo, Gray, Alpha); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; DstPal: PPalette32); -begin - ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries, - GetOption(ImagingColorReductionMask), DstPal); -end; - -procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32); -var - I: LongInt; -begin - // there is only one indexed format now, so it is just a copy - for I := 0 to NumPixels - 1 do - begin - Dst^ := Src^; - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; - for I := 0 to SrcInfo.PaletteEntries - 1 do - DstPal[I] := SrcPal[I]; -end; - -procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; SrcPal: PPalette32); -var - I: LongInt; - Pix64: TColor64Rec; - Idx: LongWord; -begin - // two most common conversions (Index8->R8G8B8 nad Index8->A8R8G8B8) - // are made separately from general conversions to make them faster - if (SrcInfo.Format = ifIndex8) and (DstInfo.Format in [ifR8G8B8, ifA8R8G8B8]) then - for I := 0 to NumPixels - 1 do - begin - with PColor24Rec(Dst)^ do - begin - R := SrcPal[Src^].R; - G := SrcPal[Src^].G; - B := SrcPal[Src^].B; - end; - if DstInfo.Format = ifA8R8G8B8 then - PColor32Rec(Dst).A := SrcPal[Src^].A; - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end - else - for I := 0 to NumPixels - 1 do - begin - // index to palette is read from source and color - // is retrieved from palette entry. Color is then - // scaled to 16bits and written to dest - IndexGetSrcPixel(Src, SrcInfo, Idx); - with Pix64 do - begin - A := SrcPal[Idx].A shl 8; - R := SrcPal[Idx].R shl 8; - G := SrcPal[Idx].G shl 8; - B := SrcPal[Idx].B shl 8; - end; - ChannelSetDstPixel(Dst, DstInfo, Pix64); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; SrcPal: PPalette32); -var - I: LongInt; - Gray: TColor64Rec; - Alpha: Word; - Idx: LongWord; -begin - // most common conversion (Index8->Gray8) - // is made separately from general conversions to make it faster - if (SrcInfo.Format = ifIndex8) and (DstInfo.Format = ifGray8) then - begin - for I := 0 to NumPixels - 1 do - begin - Dst^ := Round(GrayConv.R * SrcPal[Src^].R + GrayConv.G * SrcPal[Src^].G + - GrayConv.B * SrcPal[Src^].B); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end - end - else - for I := 0 to NumPixels - 1 do - begin - // index to palette is read from source and color - // is retrieved from palette entry. Color is then - // transformed to grayscale and assigned to the highest - // byte of Gray value - IndexGetSrcPixel(Src, SrcInfo, Idx); - Alpha := SrcPal[Idx].A shl 8; - Gray.A := MulDiv(Round(GrayConv.R * SrcPal[Idx].R + GrayConv.G * SrcPal[Idx].G + - GrayConv.B * SrcPal[Idx].B), 65535, 255); - GraySetDstPixel(Dst, DstInfo, Gray, Alpha); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - -procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, - DstInfo: PImageFormatInfo; SrcPal: PPalette32); -var - I: LongInt; - Idx: LongWord; - PixF: TColorFPRec; -begin - for I := 0 to NumPixels - 1 do - begin - // index to palette is read from source and color - // is retrieved from palette entry. Color is then - // scaled to 0..1 and written to dest - IndexGetSrcPixel(Src, SrcInfo, Idx); - with PixF do - begin - A := SrcPal[Idx].A * OneDiv8Bit; - R := SrcPal[Idx].R * OneDiv8Bit; - G := SrcPal[Idx].G * OneDiv8Bit; - B := SrcPal[Idx].B * OneDiv8Bit; - end; - FloatSetDstPixel(Dst, DstInfo, PixF); - Inc(Src, SrcInfo.BytesPerPixel); - Inc(Dst, DstInfo.BytesPerPixel); - end; -end; - - -{ Special formats conversion functions } - -type - // DXT RGB color block - TDXTColorBlock = packed record - Color0, Color1: Word; - Mask: LongWord; - end; - PDXTColorBlock = ^TDXTColorBlock; - - // DXT explicit alpha for a block - TDXTAlphaBlockExp = packed record - Alphas: array[0..3] of Word; - end; - PDXTAlphaBlockExp = ^TDXTAlphaBlockExp; - - // DXT interpolated alpha for a block - TDXTAlphaBlockInt = packed record - Alphas: array[0..7] of Byte; - end; - PDXTAlphaBlockInt = ^TDXTAlphaBlockInt; - - TPixelInfo = record - Color: Word; - Alpha: Byte; - Orig: TColor32Rec; - end; - - TPixelBlock = array[0..15] of TPixelInfo; - -function DecodeCol(Color: Word): TColor32Rec; -{$IFDEF USE_INLINE} inline; {$ENDIF} -begin - Result.A := $FF; -{ Result.R := ((Color and $F800) shr 11) shl 3; - Result.G := ((Color and $07E0) shr 5) shl 2; - Result.B := (Color and $001F) shl 3;} - // this color expansion is slower but gives better results - Result.R := (Color shr 11) * 255 div 31; - Result.G := ((Color shr 5) and $3F) * 255 div 63; - Result.B := (Color and $1F) * 255 div 31; -end; - -procedure DecodeDXT1(SrcBits, DestBits: PByte; Width, Height: LongInt); -var - Sel, X, Y, I, J, K: LongInt; - Block: TDXTColorBlock; - Colors: array[0..3] of TColor32Rec; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - Block := PDXTColorBlock(SrcBits)^; - Inc(SrcBits, SizeOf(Block)); - // we read and decode endpoint colors - Colors[0] := DecodeCol(Block.Color0); - Colors[1] := DecodeCol(Block.Color1); - // and interpolate between them - if Block.Color0 > Block.Color1 then - begin - // interpolation for block without alpha - Colors[2].A := $FF; - Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3; - Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3; - Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3; - Colors[3].A := $FF; - Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3; - Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3; - Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3; - end - else - begin - // interpolation for block with alpha - Colors[2].A := $FF; - Colors[2].R := (Colors[0].R + Colors[1].R) shr 1; - Colors[2].G := (Colors[0].G + Colors[1].G) shr 1; - Colors[2].B := (Colors[0].B + Colors[1].B) shr 1; - Colors[3].A := 0; - Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3; - Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3; - Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3; - end; - - // we distribute the dxt block colors across the 4x4 block of the - // destination image accroding to the dxt block mask - K := 0; - for J := 0 to 3 do - for I := 0 to 3 do - begin - Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1); - if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then - PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] := - Colors[Sel]; - Inc(K); - end; - end; -end; - -procedure DecodeDXT3(SrcBits, DestBits: PByte; Width, Height: LongInt); -var - Sel, X, Y, I, J, K: LongInt; - Block: TDXTColorBlock; - AlphaBlock: TDXTAlphaBlockExp; - Colors: array[0..3] of TColor32Rec; - AWord: Word; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - AlphaBlock := PDXTAlphaBlockExp(SrcBits)^; - Inc(SrcBits, SizeOf(AlphaBlock)); - Block := PDXTColorBlock(SrcBits)^; - Inc(SrcBits, SizeOf(Block)); - // we read and decode endpoint colors - Colors[0] := DecodeCol(Block.Color0); - Colors[1] := DecodeCol(Block.Color1); - // and interpolate between them - Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3; - Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3; - Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3; - Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3; - Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3; - Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3; - - // we distribute the dxt block colors and alphas - // across the 4x4 block of the destination image - // accroding to the dxt block mask and alpha block - K := 0; - for J := 0 to 3 do - begin - AWord := AlphaBlock.Alphas[J]; - for I := 0 to 3 do - begin - Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1); - if (X shl 2 + I < Width) and (Y shl 2 + J < Height) then - begin - Colors[Sel].A := AWord and $0F; - Colors[Sel].A := Colors[Sel].A or (Colors[Sel].A shl 4); - PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] := - Colors[Sel]; - end; - Inc(K); - AWord := AWord shr 4; - end; - end; - end; -end; - -procedure GetInterpolatedAlphas(var AlphaBlock: TDXTAlphaBlockInt); -begin - with AlphaBlock do - if Alphas[0] > Alphas[1] then - begin - // Interpolation of six alphas - Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7; - Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7; - Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7; - Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7; - Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7; - Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7; - end - else - begin - // Interpolation of four alphas, two alphas are set directly - Alphas[2] := (4 * Alphas[0] + 1 * Alphas[1] + 2) div 5; - Alphas[3] := (3 * Alphas[0] + 2 * Alphas[1] + 2) div 5; - Alphas[4] := (2 * Alphas[0] + 3 * Alphas[1] + 2) div 5; - Alphas[5] := (1 * Alphas[0] + 4 * Alphas[1] + 2) div 5; - Alphas[6] := 0; - Alphas[7] := $FF; - end; -end; - -procedure DecodeDXT5(SrcBits, DestBits: PByte; Width, Height: LongInt); -var - Sel, X, Y, I, J, K: LongInt; - Block: TDXTColorBlock; - AlphaBlock: TDXTAlphaBlockInt; - Colors: array[0..3] of TColor32Rec; - AMask: array[0..1] of LongWord; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - AlphaBlock := PDXTAlphaBlockInt(SrcBits)^; - Inc(SrcBits, SizeOf(AlphaBlock)); - Block := PDXTColorBlock(SrcBits)^; - Inc(SrcBits, SizeOf(Block)); - // we read and decode endpoint colors - Colors[0] := DecodeCol(Block.Color0); - Colors[1] := DecodeCol(Block.Color1); - // and interpolate between them - Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3; - Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3; - Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3; - Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3; - Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3; - Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3; - // 6 bit alpha mask is copied into two long words for - // easier usage - AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF; - AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF; - // alpha interpolation between two endpoint alphas - GetInterpolatedAlphas(AlphaBlock); - - // we distribute the dxt block colors and alphas - // across the 4x4 block of the destination image - // accroding to the dxt block mask and alpha block mask - K := 0; - for J := 0 to 3 do - for I := 0 to 3 do - begin - Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1); - if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then - begin - Colors[Sel].A := AlphaBlock.Alphas[AMask[J shr 1] and 7]; - PPalette32(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := - Colors[Sel]; - end; - Inc(K); - AMask[J shr 1] := AMask[J shr 1] shr 3; - end; - end; -end; - -procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos, - Width, Height: LongInt); -var - X, Y, I: LongInt; - Src: PColor32Rec; -begin - I := 0; - // 4x4 pixel block is filled with information about every - // pixel in the block: alpha, original color, 565 color - for Y := 0 to 3 do - for X := 0 to 3 do - begin - Src := @PPalette32(SrcBits)[(YPos shl 2 + Y) * Width + XPos shl 2 + X]; - Block[I].Color := ((Src.R shr 3) shl 11) or ((Src.G shr 2) shl 5) or - (Src.B shr 3); - Block[I].Alpha := Src.A; - Block[I].Orig := Src^; - Inc(I); - end; -end; - -function ColorDistance(const C1, C2: TColor32Rec): LongInt; -{$IFDEF USE_INLINE} inline;{$ENDIF} -begin - Result := (C1.R - C2.R) * (C1.R - C2.R) + - (C1.G - C2.G) * (C1.G - C2.G) + (C1.B - C2.B) * (C1.B - C2.B); -end; - -procedure GetEndpoints(const Block: TPixelBlock; var Ep0, Ep1: Word); -var - I, J, Farthest, Dist: LongInt; - Colors: array[0..15] of TColor32Rec; -begin - // we choose two colors from the pixel block which has the - // largest distance between them - for I := 0 to 15 do - Colors[I] := Block[I].Orig; - Farthest := -1; - for I := 0 to 15 do - for J := I + 1 to 15 do - begin - Dist := ColorDistance(Colors[I], Colors[J]); - if Dist > Farthest then - begin - Farthest := Dist; - Ep0 := Block[I].Color; - Ep1 := Block[J].Color; - end; - end; -end; - -procedure GetAlphaEndpoints(const Block: TPixelBlock; var Min, Max: Byte); -var - I: LongInt; -begin - Min := 255; - Max := 0; - // we choose the lowest and the highest alpha values - for I := 0 to 15 do - begin - if Block[I].Alpha < Min then - Min := Block[I].Alpha; - if Block[I].Alpha > Max then - Max := Block[I].Alpha; - end; -end; - -procedure FixEndpoints(var Ep0, Ep1: Word; HasAlpha: Boolean); -var - Temp: Word; -begin - // if dxt block has alpha information, Ep0 must be smaller - // than Ep1, if the block has no alpha Ep1 must be smaller - if HasAlpha then - begin - if Ep0 > Ep1 then - begin - Temp := Ep0; - Ep0 := Ep1; - Ep1 := Temp; - end; - end - else - if Ep0 < Ep1 then - begin - Temp := Ep0; - Ep0 := Ep1; - Ep1 := Temp; - end; -end; - -function GetColorMask(Ep0, Ep1: Word; NumCols: LongInt; - const Block: TPixelBlock): LongWord; -var - I, J, Closest, Dist: LongInt; - Colors: array[0..3] of TColor32Rec; - Mask: array[0..15] of Byte; -begin - // we decode endpoint colors - Colors[0] := DecodeCol(Ep0); - Colors[1] := DecodeCol(Ep1); - // and interpolate colors between (3 for DXT1 with alpha, 4 for the others) - if NumCols = 3 then - begin - Colors[2].R := (Colors[0].R + Colors[1].R) shr 1; - Colors[2].G := (Colors[0].G + Colors[1].G) shr 1; - Colors[2].B := (Colors[0].B + Colors[1].B) shr 1; - Colors[3].R := (Colors[0].R + Colors[1].R) shr 1; - Colors[3].G := (Colors[0].G + Colors[1].G) shr 1; - Colors[3].B := (Colors[0].B + Colors[1].B) shr 1; - end - else - begin - Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3; - Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3; - Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3; - Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3; - Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3; - Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3; - end; - - for I := 0 to 15 do - begin - // this is only for DXT1 with alpha - if (Block[I].Alpha < 128) and (NumCols = 3) then - begin - Mask[I] := 3; - Continue; - end; - // for each of the 16 input pixels the nearest color in the - // 4 dxt colors is found - Closest := MaxInt; - for J := 0 to NumCols - 1 do - begin - Dist := ColorDistance(Block[I].Orig, Colors[J]); - if Dist < Closest then - begin - Closest := Dist; - Mask[I] := J; - end; - end; - end; - - Result := 0; - for I := 0 to 15 do - Result := Result or (Mask[I] shl (I shl 1)); -end; - -procedure GetAlphaMask(Ep0, Ep1: Byte; var Block: TPixelBlock; Mask: PByteArray); -var - Alphas: array[0..7] of Byte; - M: array[0..15] of Byte; - I, J, Closest, Dist: LongInt; -begin - Alphas[0] := Ep0; - Alphas[1] := Ep1; - // interpolation between two given alpha endpoints - // (I use 6 interpolated values mode) - Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7; - Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7; - Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7; - Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7; - Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7; - Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7; - - // the closest interpolated values for each of the input alpha - // is found - for I := 0 to 15 do - begin - Closest := MaxInt; - for J := 0 to 7 do - begin - Dist := Abs(Alphas[J] - Block[I].Alpha); - if Dist < Closest then - begin - Closest := Dist; - M[I] := J; - end; - end; - end; - - Mask[0] := M[0] or (M[1] shl 3) or ((M[2] and 3) shl 6); - Mask[1] := ((M[2] and 4) shr 2) or (M[3] shl 1) or (M[4] shl 4) or - ((M[5] and 1) shl 7); - Mask[2] := ((M[5] and 6) shr 1) or (M[6] shl 2) or (M[7] shl 5); - Mask[3] := M[8] or (M[9] shl 3) or ((M[10] and 3) shl 6); - Mask[4] := ((M[10] and 4) shr 2) or (M[11] shl 1) or (M[12] shl 4) or - ((M[13] and 1) shl 7); - Mask[5] := ((M[13] and 6) shr 1) or (M[14] shl 2) or (M[15] shl 5); -end; - - -procedure EncodeDXT1(SrcBits: PByte; DestBits: PByte; Width, Height: LongInt); -var - X, Y, I: LongInt; - HasAlpha: Boolean; - Block: TDXTColorBlock; - Pixels: TPixelBlock; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - GetBlock(Pixels, SrcBits, X, Y, Width, Height); - HasAlpha := False; - for I := 0 to 15 do - if Pixels[I].Alpha < 128 then - begin - HasAlpha := True; - Break; - end; - GetEndpoints(Pixels, Block.Color0, Block.Color1); - FixEndpoints(Block.Color0, Block.Color1, HasAlpha); - if HasAlpha then - Block.Mask := GetColorMask(Block.Color0, Block.Color1, 3, Pixels) - else - Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels); - PDXTColorBlock(DestBits)^ := Block; - Inc(DestBits, SizeOf(Block)); - end; -end; - -procedure EncodeDXT3(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt); -var - X, Y, I: LongInt; - Block: TDXTColorBlock; - AlphaBlock: TDXTAlphaBlockExp; - Pixels: TPixelBlock; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - GetBlock(Pixels, SrcBits, X, Y, Width, Height); - for I := 0 to 7 do - PByteArray(@AlphaBlock.Alphas)[I] := - (Pixels[I shl 1].Alpha shr 4) or ((Pixels[I shl 1 + 1].Alpha shr 4) shl 4); - GetEndpoints(Pixels, Block.Color0, Block.Color1); - FixEndpoints(Block.Color0, Block.Color1, False); - Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels); - PDXTAlphaBlockExp(DestBits)^ := AlphaBlock; - Inc(DestBits, SizeOf(AlphaBlock)); - PDXTColorBlock(DestBits)^ := Block; - Inc(DestBits, SizeOf(Block)); - end; -end; - -procedure EncodeDXT5(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt); -var - X, Y: LongInt; - Block: TDXTColorBlock; - AlphaBlock: TDXTAlphaBlockInt; - Pixels: TPixelBlock; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - GetBlock(Pixels, SrcBits, X, Y, Width, Height); - GetEndpoints(Pixels, Block.Color0, Block.Color1); - FixEndpoints(Block.Color0, Block.Color1, False); - Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels); - GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); - GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, - PByteArray(@AlphaBlock.Alphas[2])); - PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; - Inc(DestBits, SizeOf(AlphaBlock)); - PDXTColorBlock(DestBits)^ := Block; - Inc(DestBits, SizeOf(Block)); - end; -end; - -type - TBTCBlock = packed record - MLower, MUpper: Byte; - BitField: Word; - end; - PBTCBlock = ^TBTCBlock; - -procedure EncodeBTC(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer); -var - X, Y, I, J: Integer; - Block: TBTCBlock; - M, MLower, MUpper, K: Integer; - Pixels: array[0..15] of Byte; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - M := 0; - MLower := 0; - MUpper := 0; - FillChar(Block, SizeOf(Block), 0); - K := 0; - - // Store 4x4 pixels and compute average, lower, and upper intensity levels - for I := 0 to 3 do - for J := 0 to 3 do - begin - Pixels[K] := PByteArray(SrcBits)[(Y shl 2 + I) * Width + X shl 2 + J]; - Inc(M, Pixels[K]); - Inc(K); - end; - - M := M div 16; - K := 0; - - // Now compute upper and lower levels, number of upper pixels, - // and update bit field (1 when pixel is above avg. level M) - for I := 0 to 15 do - begin - if Pixels[I] > M then - begin - Inc(MUpper, Pixels[I]); - Inc(K); - Block.BitField := Block.BitField or (1 shl I); - end - else - Inc(MLower, Pixels[I]); - end; - - // Scale levels and save them to block - if K > 0 then - Block.MUpper := ClampToByte(MUpper div K) - else - Block.MUpper := 0; - Block.MLower := ClampToByte(MLower div (16 - K)); - - // Finally save block to dest data - PBTCBlock(DestBits)^ := Block; - Inc(DestBits, SizeOf(Block)); - end; -end; - -procedure GetOneChannelBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos, - Width, Height, BytesPP, ChannelIdx: Integer); -var - X, Y, I: Integer; - Src: PByte; -begin - I := 0; - // 4x4 pixel block is filled with information about every pixel in the block, - // but only one channel value is stored in Alpha field - for Y := 0 to 3 do - for X := 0 to 3 do - begin - Src := @PByteArray(SrcBits)[(YPos * 4 + Y) * Width * BytesPP + - (XPos * 4 + X) * BytesPP + ChannelIdx]; - Block[I].Alpha := Src^; - Inc(I); - end; -end; - -procedure EncodeATI1N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer); -var - X, Y: Integer; - AlphaBlock: TDXTAlphaBlockInt; - Pixels: TPixelBlock; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - // Encode one channel - GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 1, 0); - GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); - GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, - PByteArray(@AlphaBlock.Alphas[2])); - PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; - Inc(DestBits, SizeOf(AlphaBlock)); - end; -end; - -procedure EncodeATI2N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer); -var - X, Y: Integer; - AlphaBlock: TDXTAlphaBlockInt; - Pixels: TPixelBlock; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - // Encode Red/X channel - GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelRed); - GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); - GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, - PByteArray(@AlphaBlock.Alphas[2])); - PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; - Inc(DestBits, SizeOf(AlphaBlock)); - // Encode Green/Y channel - GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelGreen); - GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); - GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, - PByteArray(@AlphaBlock.Alphas[2])); - PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; - Inc(DestBits, SizeOf(AlphaBlock)); - end; -end; - -procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: Integer); -var - X, Y, I, J, K: Integer; - Block: TBTCBlock; - Dest: PByte; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - Block := PBTCBlock(SrcBits)^; - Inc(SrcBits, SizeOf(Block)); - K := 0; - - // Just write MUpper when there is '1' in bit field and MLower - // when there is '0' - for I := 0 to 3 do - for J := 0 to 3 do - begin - Dest := @PByteArray(DestBits)[(Y shl 2 + I) * Width + X shl 2 + J]; - if Block.BitField and (1 shl K) <> 0 then - Dest^ := Block.MUpper - else - Dest^ := Block.MLower; - Inc(K); - end; - end; -end; - -procedure DecodeATI1N(SrcBits, DestBits: PByte; Width, Height: Integer); -var - X, Y, I, J: Integer; - AlphaBlock: TDXTAlphaBlockInt; - AMask: array[0..1] of LongWord; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - AlphaBlock := PDXTAlphaBlockInt(SrcBits)^; - Inc(SrcBits, SizeOf(AlphaBlock)); - // 6 bit alpha mask is copied into two long words for - // easier usage - AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF; - AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF; - // alpha interpolation between two endpoint alphas - GetInterpolatedAlphas(AlphaBlock); - - // we distribute the dxt block alphas - // across the 4x4 block of the destination image - for J := 0 to 3 do - for I := 0 to 3 do - begin - PByteArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := - AlphaBlock.Alphas[AMask[J shr 1] and 7]; - AMask[J shr 1] := AMask[J shr 1] shr 3; - end; - end; -end; - -procedure DecodeATI2N(SrcBits, DestBits: PByte; Width, Height: Integer); -var - X, Y, I, J: Integer; - Color: TColor32Rec; - AlphaBlock1, AlphaBlock2: TDXTAlphaBlockInt; - AMask1: array[0..1] of LongWord; - AMask2: array[0..1] of LongWord; -begin - for Y := 0 to Height div 4 - 1 do - for X := 0 to Width div 4 - 1 do - begin - // Read the first alpha block and get masks - AlphaBlock1 := PDXTAlphaBlockInt(SrcBits)^; - Inc(SrcBits, SizeOf(AlphaBlock1)); - AMask1[0] := PLongWord(@AlphaBlock1.Alphas[2])^ and $00FFFFFF; - AMask1[1] := PLongWord(@AlphaBlock1.Alphas[5])^ and $00FFFFFF; - // Read the secind alpha block and get masks - AlphaBlock2 := PDXTAlphaBlockInt(SrcBits)^; - Inc(SrcBits, SizeOf(AlphaBlock2)); - AMask2[0] := PLongWord(@AlphaBlock2.Alphas[2])^ and $00FFFFFF; - AMask2[1] := PLongWord(@AlphaBlock2.Alphas[5])^ and $00FFFFFF; - // alpha interpolation between two endpoint alphas - GetInterpolatedAlphas(AlphaBlock1); - GetInterpolatedAlphas(AlphaBlock2); - - Color.A := $FF; - Color.B := 0; - - // Distribute alpha block values across 4x4 pixel block, - // first alpha block represents Red channel, second is Green. - for J := 0 to 3 do - for I := 0 to 3 do - begin - Color.R := AlphaBlock1.Alphas[AMask1[J shr 1] and 7]; - Color.G := AlphaBlock2.Alphas[AMask2[J shr 1] and 7]; - PColor32RecArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := Color; - AMask1[J shr 1] := AMask1[J shr 1] shr 3; - AMask2[J shr 1] := AMask2[J shr 1] shr 3; - end; - end; -end; - -procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer; - SpecialFormat: TImageFormat); -begin - case SpecialFormat of - ifDXT1: DecodeDXT1(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); - ifDXT3: DecodeDXT3(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); - ifDXT5: DecodeDXT5(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); - ifBTC: DecodeBTC (SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); - ifATI1N: DecodeATI1N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); - ifATI2N: DecodeATI2N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); - end; -end; - -procedure UnSpecialToSpecial(SrcBits: Pointer; const DestImage: TImageData; - SpecialFormat: TImageFormat); -begin - case SpecialFormat of - ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); - ifDXT3: EncodeDXT3(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); - ifDXT5: EncodeDXT5(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); - ifBTC: EncodeBTC (SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); - ifATI1N: EncodeATI1N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); - ifATI2N: EncodeATI2N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); - end; -end; - -procedure ConvertSpecial(var Image: TImageData; - SrcInfo, DstInfo: PImageFormatInfo); -var - WorkImage: TImageData; - - procedure CheckSize(var Img: TImageData; Info: PImageFormatInfo); - var - Width, Height: Integer; - begin - Width := Img.Width; - Height := Img.Height; - DstInfo.CheckDimensions(Info.Format, Width, Height); - ResizeImage(Img, Width, Height, rfNearest); - end; - -begin - if SrcInfo.IsSpecial and DstInfo.IsSpecial then - begin - // Convert source to nearest 'normal' format - InitImage(WorkImage); - NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage); - SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format); - FreeImage(Image); - // Make sure output of SpecialToUnSpecial is the same as input of - // UnSpecialToSpecial - if SrcInfo.SpecialNearestFormat <> DstInfo.SpecialNearestFormat then - ConvertImage(WorkImage, DstInfo.SpecialNearestFormat); - // Convert work image to dest special format - CheckSize(WorkImage, DstInfo); - NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image); - UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format); - FreeImage(WorkImage); - end - else if SrcInfo.IsSpecial and not DstInfo.IsSpecial then - begin - // Convert source to nearest 'normal' format - InitImage(WorkImage); - NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage); - SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format); - FreeImage(Image); - // Now convert to dest format - ConvertImage(WorkImage, DstInfo.Format); - Image := WorkImage; - end - else if not SrcInfo.IsSpecial and DstInfo.IsSpecial then - begin - // Convert source to nearest format - WorkImage := Image; - ConvertImage(WorkImage, DstInfo.SpecialNearestFormat); - // Now convert from nearest to dest - CheckSize(WorkImage, DstInfo); - InitImage(Image); - NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image); - UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format); - FreeImage(WorkImage); - end; -end; - -function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; -begin - if FInfos[Format] <> nil then - Result := Width * Height * FInfos[Format].BytesPerPixel - else - Result := 0; -end; - -procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt); -begin -end; - -function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; -begin - // DXT can be used only for images with dimensions that are - // multiples of four - CheckDXTDimensions(Format, Width, Height); - Result := Width * Height; - if Format in [ifDXT1, ifATI1N] then - Result := Result div 2; -end; - -procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt); -begin - // DXT image dimensions must be multiples of four - Width := (Width + 3) and not 3; // div 4 * 4; - Height := (Height + 3) and not 3; // div 4 * 4; -end; - -function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; -begin - // BTC can be used only for images with dimensions that are - // multiples of four - CheckDXTDimensions(Format, Width, Height); - Result := Width * Height div 4; // 2bits/pixel -end; - -{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo } - -function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; -begin - Result.Color := PLongWord(Bits)^; -end; - -procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); -begin - PLongWord(Bits)^ := Color.Color; -end; - -function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; -begin - Result.A := PColor32Rec(Bits).A * OneDiv8Bit; - Result.R := PColor32Rec(Bits).R * OneDiv8Bit; - Result.G := PColor32Rec(Bits).G * OneDiv8Bit; - Result.B := PColor32Rec(Bits).B * OneDiv8Bit; -end; - -procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); -begin - PColor32Rec(Bits).A := ClampToByte(Round(Color.A * 255.0)); - PColor32Rec(Bits).R := ClampToByte(Round(Color.R * 255.0)); - PColor32Rec(Bits).G := ClampToByte(Round(Color.G * 255.0)); - PColor32Rec(Bits).B := ClampToByte(Round(Color.B * 255.0)); -end; - -function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; -begin - case Info.Format of - ifR8G8B8, ifX8R8G8B8: - begin - Result.A := $FF; - PColor24Rec(@Result)^ := PColor24Rec(Bits)^; - end; - ifGray8, ifA8Gray8: - begin - if Info.HasAlphaChannel then - Result.A := PWordRec(Bits).High - else - Result.A := $FF; - Result.R := PWordRec(Bits).Low; - Result.G := PWordRec(Bits).Low; - Result.B := PWordRec(Bits).Low; - end; - end; -end; - -procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); -begin - case Info.Format of - ifR8G8B8, ifX8R8G8B8: - begin - PColor24Rec(Bits)^ := PColor24Rec(@Color)^; - end; - ifGray8, ifA8Gray8: - begin - if Info.HasAlphaChannel then - PWordRec(Bits).High := Color.A; - PWordRec(Bits).Low := Round(GrayConv.R * Color.R + GrayConv.G * Color.G + - GrayConv.B * Color.B); - end; - end; -end; - -function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; -begin - case Info.Format of - ifR8G8B8, ifX8R8G8B8: - begin - Result.A := 1.0; - Result.R := PColor24Rec(Bits).R * OneDiv8Bit; - Result.G := PColor24Rec(Bits).G * OneDiv8Bit; - Result.B := PColor24Rec(Bits).B * OneDiv8Bit; - end; - ifGray8, ifA8Gray8: - begin - if Info.HasAlphaChannel then - Result.A := PWordRec(Bits).High * OneDiv8Bit - else - Result.A := 1.0; - Result.R := PWordRec(Bits).Low * OneDiv8Bit; - Result.G := PWordRec(Bits).Low * OneDiv8Bit; - Result.B := PWordRec(Bits).Low * OneDiv8Bit; - end; - end; -end; - -procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); -begin - case Info.Format of - ifR8G8B8, ifX8R8G8B8: - begin - PColor24Rec(Bits).R := ClampToByte(Round(Color.R * 255.0)); - PColor24Rec(Bits).G := ClampToByte(Round(Color.G * 255.0)); - PColor24Rec(Bits).B := ClampToByte(Round(Color.B * 255.0)); - end; - ifGray8, ifA8Gray8: - begin - if Info.HasAlphaChannel then - PWordRec(Bits).High := ClampToByte(Round(Color.A * 255.0)); - PWordRec(Bits).Low := ClampToByte(Round((GrayConv.R * Color.R + GrayConv.G * Color.G + - GrayConv.B * Color.B) * 255.0)); - end; - end; -end; - -function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; -begin - case Info.Format of - ifA32R32G32B32F: - begin - Result := PColorFPRec(Bits)^; - end; - ifA32B32G32R32F: - begin - Result := PColorFPRec(Bits)^; - SwapValues(Result.R, Result.B); - end; - ifR32F: - begin - Result.A := 1.0; - Result.R := PSingle(Bits)^; - Result.G := 0.0; - Result.B := 0.0; - end; - end; -end; - -procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); -begin - case Info.Format of - ifA32R32G32B32F: - begin - PColorFPRec(Bits)^ := Color; - end; - ifA32B32G32R32F: - begin - PColorFPRec(Bits)^ := Color; - SwapValues(PColorFPRec(Bits).R, PColorFPRec(Bits).B); - end; - ifR32F: - begin - PSingle(Bits)^ := Color.R; - end; - end; -end; - -initialization - // Initialize default sampling filter function pointers and radii - SamplingFilterFunctions[sfNearest] := FilterNearest; - SamplingFilterFunctions[sfLinear] := FilterLinear; - SamplingFilterFunctions[sfCosine] := FilterCosine; - SamplingFilterFunctions[sfHermite] := FilterHermite; - SamplingFilterFunctions[sfQuadratic] := FilterQuadratic; - SamplingFilterFunctions[sfGaussian] := FilterGaussian; - SamplingFilterFunctions[sfSpline] := FilterSpline; - SamplingFilterFunctions[sfLanczos] := FilterLanczos; - SamplingFilterFunctions[sfMitchell] := FilterMitchell; - SamplingFilterFunctions[sfCatmullRom] := FilterCatmullRom; - SamplingFilterRadii[sfNearest] := 1.0; - SamplingFilterRadii[sfLinear] := 1.0; - SamplingFilterRadii[sfCosine] := 1.0; - SamplingFilterRadii[sfHermite] := 1.0; - SamplingFilterRadii[sfQuadratic] := 1.5; - SamplingFilterRadii[sfGaussian] := 1.25; - SamplingFilterRadii[sfSpline] := 2.0; - SamplingFilterRadii[sfLanczos] := 3.0; - SamplingFilterRadii[sfMitchell] := 2.0; - SamplingFilterRadii[sfCatmullRom] := 2.0; - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.26.3 Changes/Bug Fixes ----------------------------------- - - Filtered resampling ~10% faster now. - - Fixed DXT3 alpha encoding. - - ifIndex8 format now has HasAlphaChannel=True. - - -- 0.25.0 Changes/Bug Fixes ----------------------------------- - - Made some resampling stuff public so that it can be used in canvas class. - - Added some color constructors. - - Added VisualizePalette helper function. - - Fixed ConvertSpecial, not very readable before and error when - converting special->special. - - -- 0.24.3 Changes/Bug Fixes ----------------------------------- - - Some refactorings a changes to DXT based formats. - - Added ifATI1N and ifATI2N image data formats support structures and functions. - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Added ifBTC image format support structures and functions. - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - FillMipMapLevel now works well with indexed and special formats too. - - Moved Convert1To8 and Convert4To8 functions from ImagingBitmaps here - and created new Convert2To8 function. They are now used by more than one - file format loader. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - StretchResample now uses pixel get/set functions stored in - TImageFormatInfo so it is much faster for formats that override - them with optimized ones - - added pixel set/get functions optimized for various image formats - (to be stored in TImageFormatInfo) - - bug in ConvertSpecial caused problems when converting DXTC images - to bitmaps in ImagingCoponents - - bug in StretchRect caused that it didn't work with ifR32F and - ifR16F formats - - removed leftover code in FillMipMapLevel which disabled - filtered resizing of images witch ChannelSize <> 8bits - - added half float converting functions and support for half based - image formats where needed - - added TranslatePixel and IsImageFormatValid functions - - fixed possible range overflows when converting from FP to integer images - - added pixel set/get functions: GetPixel32Generic, GetPixelFPGeneric, - SetPixel32Generic, SetPixelFPGeneric - - fixed occasional range overflows in StretchResample - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - added StretchNearest, StretchResample and some sampling functions - - added ChannelCount values to TImageFormatInfo constants - - added resolution validity check to GetDXTPixelsSize - - -- 0.15 Changes/Bug Fixes ----------------------------------- - - added RBSwapFormat values to some TImageFromatInfo definitions - - fixed bug in ConvertSpecial (causing DXT images to convert only to 32bit) - - added CopyPixel, ComparePixels helper functions - - -- 0.13 Changes/Bug Fixes ----------------------------------- - - replaced pixel format conversions for colors not to be - darkened when converting from low bit counts - - ReduceColorsMedianCut was updated to support creating one - optimal palette for more images and it is somewhat faster - now too - - there was ugly bug in DXTC dimensions checking -} - -end. - +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit manages information about all image data formats and contains + low level format conversion, manipulation, and other related functions.} +unit ImagingFormats; + +{$I ImagingOptions.inc} + +interface + +uses + ImagingTypes, Imaging, ImagingUtility; + +type + TImageFormatInfoArray = array[TImageFormat] of PImageFormatInfo; + PImageFormatInfoArray = ^TImageFormatInfoArray; + + +{ Additional image manipulation functions (usually used internally by Imaging unit) } + +type + { Color reduction operations.} + TReduceColorsAction = (raCreateHistogram, raUpdateHistogram, raMakeColorMap, + raMapImage); + TReduceColorsActions = set of TReduceColorsAction; +const + AllReduceColorsActions = [raCreateHistogram, raUpdateHistogram, + raMakeColorMap, raMapImage]; +{ Reduces the number of colors of source. Src is bits of source image + (ARGB or floating point) and Dst is in some indexed format. MaxColors + is the number of colors to which reduce and DstPal is palette to which + the resulting colors are written and it must be allocated to at least + MaxColors entries. ChannelMask is 'anded' with every pixel's channel value + when creating color histogram. If $FF is used all 8bits of color channels + are used which can be slow for large images with many colors so you can + use lower masks to speed it up.} +procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte; + DstPal: PPalette32; Actions: TReduceColorsActions = AllReduceColorsActions); +{ Stretches rectangle in source image to rectangle in destination image + using nearest neighbor filtering. It is fast but results look blocky + because there is no interpolation used. SrcImage and DstImage must be + in the same data format. Works for all data formats except special formats.} +procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, + SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, + DstHeight: LongInt); +type + { Built-in sampling filters.} + TSamplingFilter = (sfNearest, sfLinear, sfCosine, sfHermite, sfQuadratic, + sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom); + { Type of custom sampling function} + TFilterFunction = function(Value: Single): Single; +const + { Default resampling filter used for bicubic resizing.} + DefaultCubicFilter = sfCatmullRom; +var + { Built-in filter functions.} + SamplingFilterFunctions: array[TSamplingFilter] of TFilterFunction; + { Default radii of built-in filter functions.} + SamplingFilterRadii: array[TSamplingFilter] of Single; + +{ Stretches rectangle in source image to rectangle in destination image + with resampling. One of built-in resampling filters defined by + Filter is used. Set WrapEdges to True for seamlessly tileable images. + SrcImage and DstImage must be in the same data format. + Works for all data formats except special and indexed formats.} +procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, + SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, + DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean = False); overload; +{ Stretches rectangle in source image to rectangle in destination image + with resampling. You can use custom sampling function and filter radius. + Set WrapEdges to True for seamlessly tileable images. SrcImage and DstImage + must be in the same data format. + Works for all data formats except special and indexed formats.} +procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, + SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, + DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; + WrapEdges: Boolean = False); overload; +{ Helper for functions that create mipmap levels. BiggerLevel is + valid image and SmallerLevel is empty zeroed image. SmallerLevel is created + with Width and Height dimensions and it is filled with pixels of BiggerLevel + using resampling filter specified by ImagingMipMapFilter option. + Uses StretchNearest and StretchResample internally so the same image data format + limitations apply.} +procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt; + var SmallerLevel: TImageData); + + +{ Various helper & support functions } + +{ Copies Src pixel to Dest pixel. It is faster than System.Move procedure.} +procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Compares Src pixel and Dest pixel. It is faster than SysUtils.CompareMem function.} +function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Translates pixel color in SrcFormat to DstFormat.} +procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat, + DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32); +{ Clamps floating point pixel channel values to [0.0, 1.0] range.} +procedure ClampFloatPixel(var PixF: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Helper function that converts pixel in any format to 32bit ARGB pixel. + For common formats it's faster than calling GetPixel32 etc.} +procedure ConvertToPixel32(SrcPix: PByte; DestPix: PColor32Rec; + const SrcInfo: TImageFormatInfo; SrcPalette: PPalette32 = nil); {$IFDEF USE_INLINE}inline;{$ENDIF} + +{ Adds padding bytes at the ends of scanlines. Bpp is the number of bytes per + pixel of source and WidthBytes is the number of bytes per scanlines of dest.} +procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height, + Bpp, WidthBytes: LongInt); +{ Removes padding from image with scanlines that have aligned sizes. Bpp is + the number of bytes per pixel of dest and WidthBytes is the number of bytes + per scanlines of source.} +procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height, + Bpp, WidthBytes: LongInt); + +{ Converts 1bit image data to 8bit. Used mostly by file loaders for formats + supporting 1bit images. Scaling of pixel values to 8bits is optional + (indexed formats don't need this).} +procedure Convert1To8(DataIn, DataOut: PByte; Width, Height, + WidthBytes: LongInt; ScaleTo8Bits: Boolean); +{ Converts 2bit image data to 8bit. Used mostly by file loaders for formats + supporting 2bit images. Scaling of pixel values to 8bits is optional + (indexed formats don't need this).} +procedure Convert2To8(DataIn, DataOut: PByte; Width, Height, + WidthBytes: LongInt; ScaleTo8Bits: Boolean); +{ Converts 4bit image data to 8bit. Used mostly by file loaders for formats + supporting 4bit images. Scaling of pixel values to 8bits is optional + (indexed formats don't need this).} +procedure Convert4To8(DataIn, DataOut: PByte; Width, Height, + WidthBytes: LongInt; ScaleTo8Bits: Boolean); + +{ Helper function for image file loaders. Some 15 bit images (targas, bitmaps) + may contain 1 bit alpha but there is no indication of it. This function checks + all 16 bit(should be X1R5G5B5 or A1R5G5B5 format) pixels and some of them have + alpha bit set it returns True, otherwise False.} +function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean; +{ Helper function for image file loaders. This function checks is similar + to Has16BitImageAlpha but works with A8R8G8B8/X8R8G8B8 format.} +function Has32BitImageAlpha(NumPixels: LongInt; Data: PUInt32): Boolean; +{ Checks if there is any relevant alpha data (any entry has alpha <> 255) + in the given palette.} +function PaletteHasAlpha(Palette: PPalette32; PaletteEntries: Integer): Boolean; +{ Checks if given palette has only grayscale entries.} +function PaletteIsGrayScale(Palette: PPalette32; PaletteEntries: Integer): Boolean; + +{ Provides indexed access to each line of pixels. Does not work with special + format images.} +function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo; + LineWidth, Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns True if Format is valid image data format identifier.} +function IsImageFormatValid(Format: TImageFormat): Boolean; + +{ Converts 16bit half floating point value to 32bit Single.} +function HalfToFloat(Half: THalfFloat): Single; +{ Converts 32bit Single to 16bit half floating point.} +function FloatToHalf(Float: Single): THalfFloat; + +{ Converts half float color value to single-precision floating point color.} +function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Converts single-precision floating point color to half float color.} +function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF} + +{ Converts ARGB color to grayscale. } +function Color32ToGray(Color32: TColor32): Byte; {$IFDEF USE_INLINE}inline;{$ENDIF} + +{ Makes image PalEntries x 1 big where each pixel has color of one pal entry.} +procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData); + +type + TPointRec = record + Pos: LongInt; + Weight: Single; + end; + TCluster = array of TPointRec; + TMappingTable = array of TCluster; + +{ Helper function for resampling.} +function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt; + Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable; +{ Helper function for resampling.} +procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt); + + +{ Pixel readers/writers for different image formats } + +{ Returns pixel of image in any ARGB format. Channel values are scaled to 16 bits.} +procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; + var Pix: TColor64Rec); +{ Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.} +procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; + const Pix: TColor64Rec); + +{ Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits + and alpha to 16 bits.} +procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; + var Gray: TColor64Rec; var Alpha: Word); +{ Sets pixel of image in any grayscale format. Gray value must be scaled to 64 bits + and alpha to 16 bits.} +procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; + const Gray: TColor64Rec; Alpha: Word); + +{ Returns pixel of image in any floating point format. Channel values are + in range <0.0, 1.0>.} +procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; + var Pix: TColorFPRec); +{ Sets pixel of image in any floating point format. Channel values must be + in range <0.0, 1.0>.} +procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; + const Pix: TColorFPRec); + +{ Returns pixel of image in any indexed format. Returned value is index to + the palette.} +procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; + var Index: UInt32); +{ Sets pixel of image in any indexed format. Index is index to the palette.} +procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; + Index: UInt32); + + +{ Pixel readers/writers for 32bit and FP colors} + +{ Function for getting pixel colors. Native pixel is read from Image and + then translated to 32 bit ARGB.} +function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; + Palette: PPalette32): TColor32Rec; +{ Procedure for setting pixel colors. Input 32 bit ARGB color is translated to + native format and then written to Image.} +procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; + Palette: PPalette32; const Color: TColor32Rec); +{ Function for getting pixel colors. Native pixel is read from Image and + then translated to FP ARGB.} +function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; + Palette: PPalette32): TColorFPRec; +{ Procedure for setting pixel colors. Input FP ARGB color is translated to + native format and then written to Image.} +procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; + Palette: PPalette32; const Color: TColorFPRec); + + +{ Image format conversion functions } + +{ Converts any ARGB format to any ARGB format.} +procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +{ Converts any ARGB format to any grayscale format.} +procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +{ Converts any ARGB format to any floating point format.} +procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +{ Converts any ARGB format to any indexed format.} +procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; DstPal: PPalette32); + +{ Converts any grayscale format to any grayscale format.} +procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +{ Converts any grayscale format to any ARGB format.} +procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +{ Converts any grayscale format to any floating point format.} +procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +{ Converts any grayscale format to any indexed format.} +procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; DstPal: PPalette32); + +{ Converts any floating point format to any floating point format.} +procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +{ Converts any floating point format to any ARGB format.} +procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +{ Converts any floating point format to any grayscale format.} +procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +{ Converts any floating point format to any indexed format.} +procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; DstPal: PPalette32); + +{ Converts any indexed format to any indexed format.} +procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32); +{ Converts any indexed format to any ARGB format.} +procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; SrcPal: PPalette32); +{ Converts any indexed format to any grayscale format.} +procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; SrcPal: PPalette32); +{ Converts any indexed format to any floating point format.} +procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; SrcPal: PPalette32); + +{ Special formats conversion functions } + +{ Converts image to/from/between special image formats (dxtc, ...).} +procedure ConvertSpecial(var Image: TImageData; SrcInfo, + DstInfo: PImageFormatInfo); + + +{ Inits all image format information. Called internally on startup.} +procedure InitImageFormats(var Infos: TImageFormatInfoArray); + +const + // Grayscale conversion channel weights + GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0); + + // Constants for converting integer colors to floating point + OneDiv8Bit: Single = 1.0 / 255.0; + OneDiv16Bit: Single = 1.0 / 65535.0; + +implementation + +{ TImageFormatInfo member functions } + +{ Returns size in bytes of image in given standard format where + Size = Width * Height * Bpp.} +function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward; +{ Checks if Width and Height are valid for given standard format.} +procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt); forward; +{ Returns size in bytes of image in given DXT format.} +function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward; +{ Checks if Width and Height are valid for given DXT format. If they are + not valid, they are changed to pass the check.} +procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt); forward; +{ Returns size in bytes of image in BTC format.} +function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward; +{ Returns size in bytes of image in binary format (1bit image).} +function GetBinaryPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward; + +function GetBCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward; +procedure CheckBCDimensions(Format: TImageFormat; var Width, Height: LongInt); forward; + + +{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo } + +function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward; +procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward; +function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward; +procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward; + +function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward; +procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward; +function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward; +procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward; + +function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward; +procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward; + +var + PFR3G3B2: TPixelFormatInfo; + PFX5R1G1B1: TPixelFormatInfo; + PFR5G6B5: TPixelFormatInfo; + PFA1R5G5B5: TPixelFormatInfo; + PFA4R4G4B4: TPixelFormatInfo; + PFX1R5G5B5: TPixelFormatInfo; + PFX4R4G4B4: TPixelFormatInfo; + FInfos: PImageFormatInfoArray; + +var + // Free Pascal generates hundreds of warnings here +{$WARNINGS OFF} + + // indexed formats + Index8Info: TImageFormatInfo = ( + Format: ifIndex8; + Name: 'Index8'; + BytesPerPixel: 1; + ChannelCount: 1; + PaletteEntries: 256; + HasAlphaChannel: True; + IsIndexed: True; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + // grayscale formats + Gray8Info: TImageFormatInfo = ( + Format: ifGray8; + Name: 'Gray8'; + BytesPerPixel: 1; + ChannelCount: 1; + HasGrayChannel: True; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Channel8Bit; + GetPixelFP: GetPixelFPChannel8Bit; + SetPixel32: SetPixel32Channel8Bit; + SetPixelFP: SetPixelFPChannel8Bit); + + A8Gray8Info: TImageFormatInfo = ( + Format: ifA8Gray8; + Name: 'A8Gray8'; + BytesPerPixel: 2; + ChannelCount: 2; + HasGrayChannel: True; + HasAlphaChannel: True; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Channel8Bit; + GetPixelFP: GetPixelFPChannel8Bit; + SetPixel32: SetPixel32Channel8Bit; + SetPixelFP: SetPixelFPChannel8Bit); + + Gray16Info: TImageFormatInfo = ( + Format: ifGray16; + Name: 'Gray16'; + BytesPerPixel: 2; + ChannelCount: 1; + HasGrayChannel: True; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + Gray32Info: TImageFormatInfo = ( + Format: ifGray32; + Name: 'Gray32'; + BytesPerPixel: 4; + ChannelCount: 1; + HasGrayChannel: True; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + Gray64Info: TImageFormatInfo = ( + Format: ifGray64; + Name: 'Gray64'; + BytesPerPixel: 8; + ChannelCount: 1; + HasGrayChannel: True; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + A16Gray16Info: TImageFormatInfo = ( + Format: ifA16Gray16; + Name: 'A16Gray16'; + BytesPerPixel: 4; + ChannelCount: 2; + HasGrayChannel: True; + HasAlphaChannel: True; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + // ARGB formats + X5R1G1B1Info: TImageFormatInfo = ( + Format: ifX5R1G1B1; + Name: 'X5R1G1B1'; + BytesPerPixel: 1; + ChannelCount: 3; + UsePixelFormat: True; + PixelFormat: @PFX5R1G1B1; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + R3G3B2Info: TImageFormatInfo = ( + Format: ifR3G3B2; + Name: 'R3G3B2'; + BytesPerPixel: 1; + ChannelCount: 3; + UsePixelFormat: True; + PixelFormat: @PFR3G3B2; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + R5G6B5Info: TImageFormatInfo = ( + Format: ifR5G6B5; + Name: 'R5G6B5'; + BytesPerPixel: 2; + ChannelCount: 3; + UsePixelFormat: True; + PixelFormat: @PFR5G6B5; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + A1R5G5B5Info: TImageFormatInfo = ( + Format: ifA1R5G5B5; + Name: 'A1R5G5B5'; + BytesPerPixel: 2; + ChannelCount: 4; + HasAlphaChannel: True; + UsePixelFormat: True; + PixelFormat: @PFA1R5G5B5; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + A4R4G4B4Info: TImageFormatInfo = ( + Format: ifA4R4G4B4; + Name: 'A4R4G4B4'; + BytesPerPixel: 2; + ChannelCount: 4; + HasAlphaChannel: True; + UsePixelFormat: True; + PixelFormat: @PFA4R4G4B4; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + X1R5G5B5Info: TImageFormatInfo = ( + Format: ifX1R5G5B5; + Name: 'X1R5G5B5'; + BytesPerPixel: 2; + ChannelCount: 3; + UsePixelFormat: True; + PixelFormat: @PFX1R5G5B5; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + X4R4G4B4Info: TImageFormatInfo = ( + Format: ifX4R4G4B4; + Name: 'X4R4G4B4'; + BytesPerPixel: 2; + ChannelCount: 3; + UsePixelFormat: True; + PixelFormat: @PFX4R4G4B4; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + R8G8B8Info: TImageFormatInfo = ( + Format: ifR8G8B8; + Name: 'R8G8B8'; + BytesPerPixel: 3; + ChannelCount: 3; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Channel8Bit; + GetPixelFP: GetPixelFPChannel8Bit; + SetPixel32: SetPixel32Channel8Bit; + SetPixelFP: SetPixelFPChannel8Bit); + + A8R8G8B8Info: TImageFormatInfo = ( + Format: ifA8R8G8B8; + Name: 'A8R8G8B8'; + BytesPerPixel: 4; + ChannelCount: 4; + HasAlphaChannel: True; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32ifA8R8G8B8; + GetPixelFP: GetPixelFPifA8R8G8B8; + SetPixel32: SetPixel32ifA8R8G8B8; + SetPixelFP: SetPixelFPifA8R8G8B8); + + X8R8G8B8Info: TImageFormatInfo = ( + Format: ifX8R8G8B8; + Name: 'X8R8G8B8'; + BytesPerPixel: 4; + ChannelCount: 3; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Channel8Bit; + GetPixelFP: GetPixelFPChannel8Bit; + SetPixel32: SetPixel32Channel8Bit; + SetPixelFP: SetPixelFPChannel8Bit); + + R16G16B16Info: TImageFormatInfo = ( + Format: ifR16G16B16; + Name: 'R16G16B16'; + BytesPerPixel: 6; + ChannelCount: 3; + RBSwapFormat: ifB16G16R16; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + A16R16G16B16Info: TImageFormatInfo = ( + Format: ifA16R16G16B16; + Name: 'A16R16G16B16'; + BytesPerPixel: 8; + ChannelCount: 4; + HasAlphaChannel: True; + RBSwapFormat: ifA16B16G16R16; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + B16G16R16Info: TImageFormatInfo = ( + Format: ifB16G16R16; + Name: 'B16G16R16'; + BytesPerPixel: 6; + ChannelCount: 3; + IsRBSwapped: True; + RBSwapFormat: ifR16G16B16; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + A16B16G16R16Info: TImageFormatInfo = ( + Format: ifA16B16G16R16; + Name: 'A16B16G16R16'; + BytesPerPixel: 8; + ChannelCount: 4; + HasAlphaChannel: True; + IsRBSwapped: True; + RBSwapFormat: ifA16R16G16B16; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + // floating point formats + R32FInfo: TImageFormatInfo = ( + Format: ifR32F; + Name: 'R32F'; + BytesPerPixel: 4; + ChannelCount: 1; + IsFloatingPoint: True; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPFloat32; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPFloat32); + + A32R32G32B32FInfo: TImageFormatInfo = ( + Format: ifA32R32G32B32F; + Name: 'A32R32G32B32F'; + BytesPerPixel: 16; + ChannelCount: 4; + HasAlphaChannel: True; + IsFloatingPoint: True; + RBSwapFormat: ifA32B32G32R32F; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPFloat32; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPFloat32); + + A32B32G32R32FInfo: TImageFormatInfo = ( + Format: ifA32B32G32R32F; + Name: 'A32B32G32R32F'; + BytesPerPixel: 16; + ChannelCount: 4; + HasAlphaChannel: True; + IsFloatingPoint: True; + IsRBSwapped: True; + RBSwapFormat: ifA32R32G32B32F; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPFloat32; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPFloat32); + + R16FInfo: TImageFormatInfo = ( + Format: ifR16F; + Name: 'R16F'; + BytesPerPixel: 2; + ChannelCount: 1; + IsFloatingPoint: True; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + A16R16G16B16FInfo: TImageFormatInfo = ( + Format: ifA16R16G16B16F; + Name: 'A16R16G16B16F'; + BytesPerPixel: 8; + ChannelCount: 4; + HasAlphaChannel: True; + IsFloatingPoint: True; + RBSwapFormat: ifA16B16G16R16F; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + A16B16G16R16FInfo: TImageFormatInfo = ( + Format: ifA16B16G16R16F; + Name: 'A16B16G16R16F'; + BytesPerPixel: 8; + ChannelCount: 4; + HasAlphaChannel: True; + IsFloatingPoint: True; + IsRBSwapped: True; + RBSwapFormat: ifA16R16G16B16F; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPGeneric; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPGeneric); + + R32G32B32FInfo: TImageFormatInfo = ( + Format: ifR32G32B32F; + Name: 'R32G32B32F'; + BytesPerPixel: 12; + ChannelCount: 3; + IsFloatingPoint: True; + RBSwapFormat: ifB32G32R32F; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPFloat32; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPFloat32); + + B32G32R32FInfo: TImageFormatInfo = ( + Format: ifB32G32R32F; + Name: 'B32G32R32F'; + BytesPerPixel: 12; + ChannelCount: 3; + IsFloatingPoint: True; + IsRBSwapped: True; + RBSwapFormat: ifR32G32B32F; + GetPixelsSize: GetStdPixelsSize; + CheckDimensions: CheckStdDimensions; + GetPixel32: GetPixel32Generic; + GetPixelFP: GetPixelFPFloat32; + SetPixel32: SetPixel32Generic; + SetPixelFP: SetPixelFPFloat32); + + // special formats + DXT1Info: TImageFormatInfo = ( + Format: ifDXT1; + Name: 'DXT1'; + ChannelCount: 4; + HasAlphaChannel: True; + IsSpecial: True; + GetPixelsSize: GetDXTPixelsSize; + CheckDimensions: CheckDXTDimensions; + SpecialNearestFormat: ifA8R8G8B8); + + DXT3Info: TImageFormatInfo = ( + Format: ifDXT3; + Name: 'DXT3'; + ChannelCount: 4; + HasAlphaChannel: True; + IsSpecial: True; + GetPixelsSize: GetDXTPixelsSize; + CheckDimensions: CheckDXTDimensions; + SpecialNearestFormat: ifA8R8G8B8); + + DXT5Info: TImageFormatInfo = ( + Format: ifDXT5; + Name: 'DXT5'; + ChannelCount: 4; + HasAlphaChannel: True; + IsSpecial: True; + GetPixelsSize: GetDXTPixelsSize; + CheckDimensions: CheckDXTDimensions; + SpecialNearestFormat: ifA8R8G8B8); + + BTCInfo: TImageFormatInfo = ( + Format: ifBTC; + Name: 'BTC'; + ChannelCount: 1; + HasAlphaChannel: False; + IsSpecial: True; + GetPixelsSize: GetBTCPixelsSize; + CheckDimensions: CheckDXTDimensions; + SpecialNearestFormat: ifGray8); + + ATI1NInfo: TImageFormatInfo = ( + Format: ifATI1N; + Name: 'ATI1N'; + ChannelCount: 1; + HasAlphaChannel: False; + IsSpecial: True; + GetPixelsSize: GetDXTPixelsSize; + CheckDimensions: CheckDXTDimensions; + SpecialNearestFormat: ifGray8); + + ATI2NInfo: TImageFormatInfo = ( + Format: ifATI2N; + Name: 'ATI2N'; + ChannelCount: 2; + HasAlphaChannel: False; + IsSpecial: True; + GetPixelsSize: GetDXTPixelsSize; + CheckDimensions: CheckDXTDimensions; + SpecialNearestFormat: ifA8R8G8B8); + + BinaryInfo: TImageFormatInfo = ( + Format: ifBinary; + Name: 'Binary'; + ChannelCount: 1; + HasAlphaChannel: False; + IsSpecial: True; + GetPixelsSize: GetBinaryPixelsSize; + CheckDimensions: CheckStdDimensions; + SpecialNearestFormat: ifGray8); + + { Passtrough formats } + + {ETC1Info: TImageFormatInfo = ( + Format: ifETC1; + Name: 'ETC1'; + ChannelCount: 3; + HasAlphaChannel: False; + IsSpecial: True; + IsPassthrough: True; + GetPixelsSize: GetBCPixelsSize; + CheckDimensions: CheckBCDimensions; + SpecialNearestFormat: ifR8G8B8); + + ETC2RGBInfo: TImageFormatInfo = ( + Format: ifETC2RGB; + Name: 'ETC2RGB'; + ChannelCount: 3; + HasAlphaChannel: False; + IsSpecial: True; + IsPassthrough: True; + GetPixelsSize: GetBCPixelsSize; + CheckDimensions: CheckBCDimensions; + SpecialNearestFormat: ifR8G8B8); + + ETC2RGBAInfo: TImageFormatInfo = ( + Format: ifETC2RGBA; + Name: 'ETC2RGBA'; + ChannelCount: 4; + HasAlphaChannel: True; + IsSpecial: True; + IsPassthrough: True; + GetPixelsSize: GetBCPixelsSize; + CheckDimensions: CheckBCDimensions; + SpecialNearestFormat: ifA8R8G8B8); + + ETC2PAInfo: TImageFormatInfo = ( + Format: ifETC2PA; + Name: 'ETC2PA'; + ChannelCount: 4; + HasAlphaChannel: True; + IsSpecial: True; + IsPassthrough: True; + GetPixelsSize: GetBCPixelsSize; + CheckDimensions: CheckBCDimensions; + SpecialNearestFormat: ifA8R8G8B8); + + DXBC6Info: TImageFormatInfo = ( + Format: ifDXBC6; + Name: 'DXBC6'; + ChannelCount: 4; + HasAlphaChannel: True; + IsSpecial: True; + IsPassthrough: True; + GetPixelsSize: GetBCPixelsSize; + CheckDimensions: CheckBCDimensions; + SpecialNearestFormat: ifA8R8G8B8); + + DXBC7Info: TImageFormatInfo = ( + Format: ifDXBC6; + Name: 'DXBC7'; + ChannelCount: 4; + HasAlphaChannel: True; + IsSpecial: True; + IsPassthrough: True; + GetPixelsSize: GetBCPixelsSize; + CheckDimensions: CheckBCDimensions; + SpecialNearestFormat: ifA8R8G8B8); + + PVRTCInfo: TImageFormatInfo = ( + Format: ifPVRTC; + Name: 'PVRTC'; + ChannelCount: 4; + HasAlphaChannel: True; + IsSpecial: True; + IsPassthrough: True; + GetPixelsSize: GetBCPixelsSize; + CheckDimensions: CheckBCDimensions; + SpecialNearestFormat: ifA8R8G8B8);} + +{$WARNINGS ON} + +function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward; + +procedure InitImageFormats(var Infos: TImageFormatInfoArray); +begin + FInfos := @Infos; + + Infos[ifDefault] := @A8R8G8B8Info; + // indexed formats + Infos[ifIndex8] := @Index8Info; + // grayscale formats + Infos[ifGray8] := @Gray8Info; + Infos[ifA8Gray8] := @A8Gray8Info; + Infos[ifGray16] := @Gray16Info; + Infos[ifGray32] := @Gray32Info; + Infos[ifGray64] := @Gray64Info; + Infos[ifA16Gray16] := @A16Gray16Info; + // ARGB formats + Infos[ifX5R1G1B1] := @X5R1G1B1Info; + Infos[ifR3G3B2] := @R3G3B2Info; + Infos[ifR5G6B5] := @R5G6B5Info; + Infos[ifA1R5G5B5] := @A1R5G5B5Info; + Infos[ifA4R4G4B4] := @A4R4G4B4Info; + Infos[ifX1R5G5B5] := @X1R5G5B5Info; + Infos[ifX4R4G4B4] := @X4R4G4B4Info; + Infos[ifR8G8B8] := @R8G8B8Info; + Infos[ifA8R8G8B8] := @A8R8G8B8Info; + Infos[ifX8R8G8B8] := @X8R8G8B8Info; + Infos[ifR16G16B16] := @R16G16B16Info; + Infos[ifA16R16G16B16] := @A16R16G16B16Info; + Infos[ifB16G16R16] := @B16G16R16Info; + Infos[ifA16B16G16R16] := @A16B16G16R16Info; + // floating point formats + Infos[ifR32F] := @R32FInfo; + Infos[ifA32R32G32B32F] := @A32R32G32B32FInfo; + Infos[ifA32B32G32R32F] := @A32B32G32R32FInfo; + Infos[ifR16F] := @R16FInfo; + Infos[ifA16R16G16B16F] := @A16R16G16B16FInfo; + Infos[ifA16B16G16R16F] := @A16B16G16R16FInfo; + Infos[ifR32G32B32F] := @R32G32B32FInfo; + Infos[ifB32G32R32F] := @B32G32R32FInfo; + // special formats + Infos[ifDXT1] := @DXT1Info; + Infos[ifDXT3] := @DXT3Info; + Infos[ifDXT5] := @DXT5Info; + Infos[ifBTC] := @BTCInfo; + Infos[ifATI1N] := @ATI1NInfo; + Infos[ifATI2N] := @ATI2NInfo; + Infos[ifBinary] := @BinaryInfo; + + PFR3G3B2 := PixelFormat(0, 3, 3, 2); + PFX5R1G1B1 := PixelFormat(0, 1, 1, 1); + PFR5G6B5 := PixelFormat(0, 5, 6, 5); + PFA1R5G5B5 := PixelFormat(1, 5, 5, 5); + PFA4R4G4B4 := PixelFormat(4, 4, 4, 4); + PFX1R5G5B5 := PixelFormat(0, 5, 5, 5); + PFX4R4G4B4 := PixelFormat(0, 4, 4, 4); +end; + + +{ Internal unit helper functions } + +function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; +begin + Result.ABitMask := ((1 shl ABitCount) - 1) shl (RBitCount + GBitCount + + BBitCount); + Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount); + Result.GBitMask := ((1 shl GBitCount) - 1) shl (BBitCount); + Result.BBitMask := (1 shl BBitCount) - 1; + Result.ABitCount := ABitCount; + Result.RBitCount := RBitCount; + Result.GBitCount := GBitCount; + Result.BBitCount := BBitCount; + Result.AShift := RBitCount + GBitCount + BBitCount; + Result.RShift := GBitCount + BBitCount; + Result.GShift := BBitCount; + Result.BShift := 0; + Result.ARecDiv := Max(1, Pow2Int(Result.ABitCount) - 1); + Result.RRecDiv := Max(1, Pow2Int(Result.RBitCount) - 1); + Result.GRecDiv := Max(1, Pow2Int(Result.GBitCount) - 1); + Result.BRecDiv := Max(1, Pow2Int(Result.BBitCount) - 1); +end; + +function PixelFormatMask(ABitMask, RBitMask, GBitMask, BBitMask: UInt32): TPixelFormatInfo; + + function GetBitCount(B: UInt32): UInt32; + var + I: UInt32; + begin + I := 0; + while (I < 31) and (((1 shl I) and B) = 0) do + Inc(I); + Result := 0; + while ((1 shl I) and B) <> 0 do + begin + Inc(I); + Inc(Result); + end; + end; + +begin + Result := PixelFormat(GetBitCount(ABitMask), GetBitCount(RBitMask), + GetBitCount(GBitMask), GetBitCount(BBitMask)); +end; + +function PFSetARGB(const PF: TPixelFormatInfo; A, R, G, B: Byte): TColor32; +{$IFDEF USE_INLINE}inline;{$ENDIF} +begin + with PF do + Result := + (A shl ABitCount shr 8 shl AShift) or + (R shl RBitCount shr 8 shl RShift) or + (G shl GBitCount shr 8 shl GShift) or + (B shl BBitCount shr 8 shl BShift); +end; + +procedure PFGetARGB(const PF: TPixelFormatInfo; Color: UInt32; + var A, R, G, B: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF} +begin + with PF do + begin + A := (Color and ABitMask shr AShift) * 255 div ARecDiv; + R := (Color and RBitMask shr RShift) * 255 div RRecDiv; + G := (Color and GBitMask shr GShift) * 255 div GRecDiv; + B := (Color and BBitMask shl BShift) * 255 div BRecDiv; + end; +end; + +function PFSetColor(const PF: TPixelFormatInfo; ARGB: TColor32): UInt32; +{$IFDEF USE_INLINE}inline;{$ENDIF} +begin + with PF do + Result := + (Byte(ARGB shr 24) shl ABitCount shr 8 shl AShift) or + (Byte(ARGB shr 16) shl RBitCount shr 8 shl RShift) or + (Byte(ARGB shr 8) shl GBitCount shr 8 shl GShift) or + (Byte(ARGB) shl BBitCount shr 8 shl BShift); +end; + +function PFGetColor(const PF: TPixelFormatInfo; Color: UInt32): TColor32; +{$IFDEF USE_INLINE}inline;{$ENDIF} +begin + with PF, TColor32Rec(Result) do + begin + A := (Color and ABitMask shr AShift) * 255 div ARecDiv; + R := (Color and RBitMask shr RShift) * 255 div RRecDiv; + G := (Color and GBitMask shr GShift) * 255 div GRecDiv; + B := (Color and BBitMask shl BShift) * 255 div BRecDiv; + end; +end; + +{ Additional image manipulation functions (usually used internally by Imaging unit) } + +const + MaxPossibleColors = 4096; + HashSize = 32768; + AlphaWeight = 1024; + RedWeight = 612; + GreenWeight = 1202; + BlueWeight = 234; + +type + PColorBin = ^TColorBin; + TColorBin = record + Color: TColor32Rec; + Number: LongInt; + Next: PColorBin; + end; + + THashTable = array[0..HashSize - 1] of PColorBin; + + TColorBox = record + AMin, AMax, + RMin, RMax, + GMin, GMax, + BMin, BMax: LongInt; + Total: LongInt; + Represented: TColor32Rec; + List: PColorBin; + end; + +var + Table: THashTable; + Box: array[0..MaxPossibleColors - 1] of TColorBox; + Boxes: LongInt; + +procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte; + DstPal: PPalette32; Actions: TReduceColorsActions); + + procedure CreateHistogram (Src: PByte; SrcInfo: PImageFormatInfo; + ChannelMask: Byte); + var + A, R, G, B: Byte; + I, Addr: LongInt; + PC: PColorBin; + Col: TColor32Rec; + begin + for I := 0 to NumPixels - 1 do + begin + Col := GetPixel32Generic(Src, SrcInfo, nil); + A := Col.A and ChannelMask; + R := Col.R and ChannelMask; + G := Col.G and ChannelMask; + B := Col.B and ChannelMask; + + Addr := (A + 11 * B + 59 * R + 119 * G) mod HashSize; + PC := Table[Addr]; + + while (PC <> nil) and ((PC.Color.R <> R) or (PC.Color.G <> G) or + (PC.Color.B <> B) or (PC.Color.A <> A)) do + PC := PC.Next; + + if PC = nil then + begin + New(PC); + PC.Color.R := R; + PC.Color.G := G; + PC.Color.B := B; + PC.Color.A := A; + PC.Number := 1; + PC.Next := Table[Addr]; + Table[Addr] := PC; + end + else + Inc(PC^.Number); + Inc(Src, SrcInfo.BytesPerPixel); + end; + end; + + procedure InitBox (var Box : TColorBox); + begin + Box.AMin := 256; + Box.RMin := 256; + Box.GMin := 256; + Box.BMin := 256; + Box.AMax := -1; + Box.RMax := -1; + Box.GMax := -1; + Box.BMax := -1; + Box.Total := 0; + Box.List := nil; + end; + + procedure ChangeBox (var Box: TColorBox; const C: TColorBin); + begin + with C.Color do + begin + if A < Box.AMin then Box.AMin := A; + if A > Box.AMax then Box.AMax := A; + if B < Box.BMin then Box.BMin := B; + if B > Box.BMax then Box.BMax := B; + if G < Box.GMin then Box.GMin := G; + if G > Box.GMax then Box.GMax := G; + if R < Box.RMin then Box.RMin := R; + if R > Box.RMax then Box.RMax := R; + end; + Inc(Box.Total, C.Number); + end; + + procedure MakeColorMap; + var + I, J: LongInt; + CP, Pom: PColorBin; + Cut, LargestIdx, Largest, Size, S: LongInt; + CutA, CutR, CutG, CutB: Boolean; + SumA, SumR, SumG, SumB: LongInt; + Temp: TColorBox; + begin + I := 0; + Boxes := 1; + LargestIdx := 0; + while (I < HashSize) and (Table[I] = nil) do + Inc(i); + if I < HashSize then + begin + // put all colors into Box[0] + InitBox(Box[0]); + repeat + CP := Table[I]; + while CP.Next <> nil do + begin + ChangeBox(Box[0], CP^); + CP := CP.Next; + end; + ChangeBox(Box[0], CP^); + CP.Next := Box[0].List; + Box[0].List := Table[I]; + Table[I] := nil; + repeat + Inc(I) + until (I = HashSize) or (Table[I] <> nil); + until I = HashSize; + // now all colors are in Box[0] + repeat + // cut one color box + Largest := 0; + for I := 0 to Boxes - 1 do + with Box[I] do + begin + Size := (AMax - AMin) * AlphaWeight; + S := (RMax - RMin) * RedWeight; + if S > Size then + Size := S; + S := (GMax - GMin) * GreenWeight; + if S > Size then + Size := S; + S := (BMax - BMin) * BlueWeight; + if S > Size then + Size := S; + if Size > Largest then + begin + Largest := Size; + LargestIdx := I; + end; + end; + if Largest > 0 then + begin + // cutting Box[LargestIdx] into Box[LargestIdx] and Box[Boxes] + CutR := False; + CutG := False; + CutB := False; + CutA := False; + with Box[LargestIdx] do + begin + if (AMax - AMin) * AlphaWeight = Largest then + begin + Cut := (AMax + AMin) shr 1; + CutA := True; + end + else + if (RMax - RMin) * RedWeight = Largest then + begin + Cut := (RMax + RMin) shr 1; + CutR := True; + end + else + if (GMax - GMin) * GreenWeight = Largest then + begin + Cut := (GMax + GMin) shr 1; + CutG := True; + end + else + begin + Cut := (BMax + BMin) shr 1; + CutB := True; + end; + CP := List; + end; + InitBox(Box[LargestIdx]); + InitBox(Box[Boxes]); + repeat + // distribute one color + Pom := CP.Next; + with CP.Color do + begin + if (CutA and (A <= Cut)) or (CutR and (R <= Cut)) or + (CutG and (G <= Cut)) or (CutB and (B <= Cut)) then + I := LargestIdx + else + I := Boxes; + end; + CP.Next := Box[i].List; + Box[i].List := CP; + ChangeBox(Box[i], CP^); + CP := Pom; + until CP = nil; + Inc(Boxes); + end; + until (Boxes = MaxColors) or (Largest = 0); + // compute box representation + for I := 0 to Boxes - 1 do + begin + SumR := 0; + SumG := 0; + SumB := 0; + SumA := 0; + repeat + CP := Box[I].List; + Inc(SumR, CP.Color.R * CP.Number); + Inc(SumG, CP.Color.G * CP.Number); + Inc(SumB, CP.Color.B * CP.Number); + Inc(SumA, CP.Color.A * CP.Number); + Box[I].List := CP.Next; + Dispose(CP); + until Box[I].List = nil; + with Box[I] do + begin + Represented.A := SumA div Total; + Represented.R := SumR div Total; + Represented.G := SumG div Total; + Represented.B := SumB div Total; + AMin := AMin and ChannelMask; + RMin := RMin and ChannelMask; + GMin := GMin and ChannelMask; + BMin := BMin and ChannelMask; + AMax := (AMax and ChannelMask) + (not ChannelMask); + RMax := (RMax and ChannelMask) + (not ChannelMask); + GMax := (GMax and ChannelMask) + (not ChannelMask); + BMax := (BMax and ChannelMask) + (not ChannelMask); + end; + end; + // sort color boxes + for I := 0 to Boxes - 2 do + begin + Largest := 0; + for J := I to Boxes - 1 do + if Box[J].Total > Largest then + begin + Largest := Box[J].Total; + LargestIdx := J; + end; + if LargestIdx <> I then + begin + Temp := Box[I]; + Box[I] := Box[LargestIdx]; + Box[LargestIdx] := Temp; + end; + end; + end; + end; + + procedure FillOutputPalette; + var + I: LongInt; + begin + FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF); + for I := 0 to MaxColors - 1 do + begin + if I < Boxes then + with Box[I].Represented do + begin + DstPal[I].A := A; + DstPal[I].R := R; + DstPal[I].G := G; + DstPal[I].B := B; + end + else + DstPal[I].Color := $FF000000; + end; + end; + + function MapColor(const Col: TColor32Rec) : LongInt; + var + I: LongInt; + begin + I := 0; + with Col do + while (I < Boxes) and ((Box[I].AMin > A) or (Box[I].AMax < A) or + (Box[I].RMin > R) or (Box[I].RMax < R) or (Box[I].GMin > G) or + (Box[I].GMax < G) or (Box[I].BMin > B) or (Box[I].BMax < B)) do + Inc(I); + if I = Boxes then + MapColor := 0 + else + MapColor := I; + end; + + procedure MapImage(Src, Dst: PByte; SrcInfo, DstInfo: PImageFormatInfo); + var + I: LongInt; + Col: TColor32Rec; + begin + for I := 0 to NumPixels - 1 do + begin + Col := GetPixel32Generic(Src, SrcInfo, nil); + IndexSetDstPixel(Dst, DstInfo, MapColor(Col)); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; + end; + +begin + MaxColors := ClampInt(MaxColors, 2, MaxPossibleColors); + + if (raUpdateHistogram in Actions) or (raMapImage in Actions) then + begin + Assert(not SrcInfo.IsSpecial); + Assert(not SrcInfo.IsIndexed); + end; + + if raCreateHistogram in Actions then + FillChar(Table, SizeOf(Table), 0); + + if raUpdateHistogram in Actions then + CreateHistogram(Src, SrcInfo, ChannelMask); + + if raMakeColorMap in Actions then + begin + MakeColorMap; + FillOutputPalette; + end; + + if raMapImage in Actions then + MapImage(Src, Dst, SrcInfo, DstInfo); +end; + +procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, + SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, + DstHeight: LongInt); +var + Info: TImageFormatInfo; + ScaleX, ScaleY, X, Y, Xp, Yp: LongInt; + DstPixel, SrcLine: PByte; +begin + GetImageFormatInfo(SrcImage.Format, Info); + Assert(SrcImage.Format = DstImage.Format); + Assert(not Info.IsSpecial); + // Use integers instead of floats for source image pixel coords + // Xp and Yp coords must be shifted right to get read source image coords + ScaleX := (SrcWidth shl 16) div DstWidth; + ScaleY := (SrcHeight shl 16) div DstHeight; + Yp := 0; + for Y := 0 to DstHeight - 1 do + begin + Xp := 0; + SrcLine := @PByteArray(SrcImage.Bits)[((SrcY + Yp shr 16) * SrcImage.Width + SrcX) * Info.BytesPerPixel]; + DstPixel := @PByteArray(DstImage.Bits)[((DstY + Y) * DstImage.Width + DstX) * Info.BytesPerPixel]; + for X := 0 to DstWidth - 1 do + begin + case Info.BytesPerPixel of + 1: PByte(DstPixel)^ := PByteArray(SrcLine)[Xp shr 16]; + 2: PWord(DstPixel)^ := PWordArray(SrcLine)[Xp shr 16]; + 3: PColor24Rec(DstPixel)^ := PPalette24(SrcLine)[Xp shr 16]; + 4: PColor32(DstPixel)^ := PUInt32Array(SrcLine)[Xp shr 16]; + 6: PColor48Rec(DstPixel)^ := PColor48RecArray(SrcLine)[Xp shr 16]; + 8: PColor64(DstPixel)^ := PInt64Array(SrcLine)[Xp shr 16]; + 16: PColorFPRec(DstPixel)^ := PColorFPRecArray(SrcLine)[Xp shr 16]; + end; + Inc(DstPixel, Info.BytesPerPixel); + Inc(Xp, ScaleX); + end; + Inc(Yp, ScaleY); + end; +end; + +{ Filter function for nearest filtering. Also known as box filter.} +function FilterNearest(Value: Single): Single; +begin + if (Value > -0.5) and (Value <= 0.5) then + Result := 1 + else + Result := 0; +end; + +{ Filter function for linear filtering. Also known as triangle or Bartlett filter.} +function FilterLinear(Value: Single): Single; +begin + if Value < 0.0 then + Value := -Value; + if Value < 1.0 then + Result := 1.0 - Value + else + Result := 0.0; +end; + +{ Cosine filter.} +function FilterCosine(Value: Single): Single; +begin + Result := 0; + if Abs(Value) < 1 then + Result := (Cos(Value * Pi) + 1) / 2; +end; + +{ f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1 } +function FilterHermite(Value: Single): Single; +begin + if Value < 0.0 then + Value := -Value; + if Value < 1 then + Result := (2 * Value - 3) * Sqr(Value) + 1 + else + Result := 0; +end; + +{ Quadratic filter. Also known as Bell.} +function FilterQuadratic(Value: Single): Single; +begin + if Value < 0.0 then + Value := -Value; + if Value < 0.5 then + Result := 0.75 - Sqr(Value) + else + if Value < 1.5 then + begin + Value := Value - 1.5; + Result := 0.5 * Sqr(Value); + end + else + Result := 0.0; +end; + +{ Gaussian filter.} +function FilterGaussian(Value: Single): Single; +begin + Result := Exp(-2.0 * Sqr(Value)) * Sqrt(2.0 / Pi); +end; + +{ 4th order (cubic) b-spline filter.} +function FilterSpline(Value: Single): Single; +var + Temp: Single; +begin + if Value < 0.0 then + Value := -Value; + if Value < 1.0 then + begin + Temp := Sqr(Value); + Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0; + end + else + if Value < 2.0 then + begin + Value := 2.0 - Value; + Result := Sqr(Value) * Value / 6.0; + end + else + Result := 0.0; +end; + +{ Lanczos-windowed sinc filter.} +function FilterLanczos(Value: Single): Single; + + function SinC(Value: Single): Single; + begin + if Value <> 0.0 then + begin + Value := Value * Pi; + Result := Sin(Value) / Value; + end + else + Result := 1.0; + end; + +begin + if Value < 0.0 then + Value := -Value; + if Value < 3.0 then + Result := SinC(Value) * SinC(Value / 3.0) + else + Result := 0.0; +end; + +{ Mitchell cubic filter.} +function FilterMitchell(Value: Single): Single; +const + B = 1.0 / 3.0; + C = 1.0 / 3.0; +var + Temp: Single; +begin + if Value < 0.0 then + Value := -Value; + Temp := Sqr(Value); + if Value < 1.0 then + begin + Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) + + ((-18.0 + 12.0 * B + 6.0 * C) * Temp) + + (6.0 - 2.0 * B)); + Result := Value / 6.0; + end + else + if Value < 2.0 then + begin + Value := (((-B - 6.0 * C) * (Value * Temp)) + + ((6.0 * B + 30.0 * C) * Temp) + + ((-12.0 * B - 48.0 * C) * Value) + + (8.0 * B + 24.0 * C)); + Result := Value / 6.0; + end + else + Result := 0.0; +end; + +{ CatmullRom spline filter.} +function FilterCatmullRom(Value: Single): Single; +begin + if Value < 0.0 then + Value := -Value; + if Value < 1.0 then + Result := 0.5 * (2.0 + Sqr(Value) * (-5.0 + 3.0 * Value)) + else + if Value < 2.0 then + Result := 0.5 * (4.0 + Value * (-8.0 + Value * (5.0 - Value))) + else + Result := 0.0; +end; + +procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, + SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, + DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean); +begin + // Calls the other function with filter function and radius defined by Filter + StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY, + DstWidth, DstHeight, SamplingFilterFunctions[Filter], SamplingFilterRadii[Filter], + WrapEdges); +end; + +var + FullEdge: Boolean = True; + +{ The following resampling code is modified and extended code from Graphics32 + library by Alex A. Denisov.} +function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt; + Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable; +var + I, J, K, N: LongInt; + Left, Right, SrcWidth, DstWidth: LongInt; + Weight, Scale, Center: Single; +begin + Result := nil; + SrcWidth := SrcHigh - SrcLow; + DstWidth := DstHigh - DstLow; + + // Check some special cases + if SrcWidth = 1 then + begin + SetLength(Result, DstWidth); + for I := 0 to DstWidth - 1 do + begin + SetLength(Result[I], 1); + Result[I][0].Pos := 0; + Result[I][0].Weight := 1.0; + end; + Exit; + end + else + if (SrcWidth = 0) or (DstWidth = 0) then + Exit; + + if FullEdge then + Scale := DstWidth / SrcWidth + else + Scale := (DstWidth - 1) / (SrcWidth - 1); + + SetLength(Result, DstWidth); + + // Pre-calculate filter contributions for a row or column + if Scale = 0.0 then + begin + Assert(Length(Result) = 1); + SetLength(Result[0], 1); + Result[0][0].Pos := (SrcLow + SrcHigh) div 2; + Result[0][0].Weight := 1.0; + end + else if Scale < 1.0 then + begin + // Sub-sampling - scales from bigger to smaller + Radius := Radius / Scale; + for I := 0 to DstWidth - 1 do + begin + if FullEdge then + Center := SrcLow - 0.5 + (I + 0.5) / Scale + else + Center := SrcLow + I / Scale; + Left := Floor(Center - Radius); + Right := Ceil(Center + Radius); + for J := Left to Right do + begin + Weight := Filter((Center - J) * Scale) * Scale; + if Weight <> 0.0 then + begin + K := Length(Result[I]); + SetLength(Result[I], K + 1); + Result[I][K].Pos := ClampInt(J, SrcLow, SrcHigh - 1); + Result[I][K].Weight := Weight; + end; + end; + if Length(Result[I]) = 0 then + begin + SetLength(Result[I], 1); + Result[I][0].Pos := Floor(Center); + Result[I][0].Weight := 1.0; + end; + end; + end + else // if Scale > 1.0 then + begin + // Super-sampling - scales from smaller to bigger + Scale := 1.0 / Scale; + for I := 0 to DstWidth - 1 do + begin + if FullEdge then + Center := SrcLow - 0.5 + (I + 0.5) * Scale + else + Center := SrcLow + I * Scale; + Left := Floor(Center - Radius); + Right := Ceil(Center + Radius); + for J := Left to Right do + begin + Weight := Filter(Center - J); + if Weight <> 0.0 then + begin + K := Length(Result[I]); + SetLength(Result[I], K + 1); + + if WrapEdges then + begin + if J < 0 then + N := SrcImageWidth + J + else if J >= SrcImageWidth then + N := J - SrcImageWidth + else + N := ClampInt(J, SrcLow, SrcHigh - 1); + end + else + N := ClampInt(J, SrcLow, SrcHigh - 1); + + Result[I][K].Pos := N; + Result[I][K].Weight := Weight; + end; + end; + end; + end; +end; + +procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt); +var + I, J: LongInt; +begin + if Length(Map) > 0 then + begin + MinPos := Map[0][0].Pos; + MaxPos := MinPos; + for I := 0 to Length(Map) - 1 do + for J := 0 to Length(Map[I]) - 1 do + begin + if MinPos > Map[I][J].Pos then + MinPos := Map[I][J].Pos; + if MaxPos < Map[I][J].Pos then + MaxPos := Map[I][J].Pos; + end; + end; +end; + +procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, + SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, + DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean); +var + MapX, MapY: TMappingTable; + I, J, X, Y: LongInt; + XMinimum, XMaximum: LongInt; + LineBufferFP: array of TColorFPRec; + ClusterX, ClusterY: TCluster; + Weight, AccumA, AccumR, AccumG, AccumB: Single; + DstLine: PByte; + SrcFloat: TColorFPRec; + Info: TImageFormatInfo; + BytesPerChannel: Integer; +begin + GetImageFormatInfo(SrcImage.Format, Info); + Assert(SrcImage.Format = DstImage.Format); + Assert(not Info.IsSpecial and not Info.IsIndexed); + BytesPerChannel := Info.BytesPerPixel div Info.ChannelCount; + + // Create horizontal and vertical mapping tables + MapX := BuildMappingTable(DstX, DstX + DstWidth, SrcX, SrcX + SrcWidth, + SrcImage.Width, Filter, Radius, WrapEdges); + MapY := BuildMappingTable(DstY, DstY + DstHeight, SrcY, SrcY + SrcHeight, + SrcImage.Height, Filter, Radius, WrapEdges); + + if (MapX = nil) or (MapY = nil) then + Exit; + + try + // Find min and max X coords of pixels that will contribute to target image + FindExtremes(MapX, XMinimum, XMaximum); + SetLength(LineBufferFP, XMaximum - XMinimum + 1); + + for J := 0 to DstHeight - 1 do + begin + // First for each pixel in the current line sample vertically + // and store results in LineBuffer. Then sample horizontally + // using values in LineBuffer. + ClusterY := MapY[J]; + for X := XMinimum to XMaximum do + begin + // Clear accumulators + AccumA := 0; + AccumR := 0; + AccumG := 0; + AccumB := 0; + // For each pixel in line compute weighted sum of pixels + // in source column that will contribute to this pixel + for Y := 0 to Length(ClusterY) - 1 do + begin + // Accumulate this pixel's weighted value + Weight := ClusterY[Y].Weight; + SrcFloat := Info.GetPixelFP(@PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel], @Info, nil); + AccumA := AccumA + SrcFloat.A * Weight; + AccumR := AccumR + SrcFloat.R * Weight; + AccumG := AccumG + SrcFloat.G * Weight; + AccumB := AccumB + SrcFloat.B * Weight; + end; + // Store accumulated value for this pixel in buffer + with LineBufferFP[X - XMinimum] do + begin + A := AccumA; + R := AccumR; + G := AccumG; + B := AccumB; + end; + end; + + DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX) * Info.BytesPerPixel]; + // Now compute final colors for target pixels in the current row + // by sampling horizontally + for I := 0 to DstWidth - 1 do + begin + ClusterX := MapX[I]; + // Clear accumulator + AccumA := 0; + AccumR := 0; + AccumG := 0; + AccumB := 0; + // Compute weighted sum of values (which are already + // computed weighted sums of pixels in source columns stored in LineBuffer) + // that will contribute to the current target pixel + for X := 0 to Length(ClusterX) - 1 do + begin + Weight := ClusterX[X].Weight; + with LineBufferFP[ClusterX[X].Pos - XMinimum] do + begin + AccumA := AccumA + A * Weight; + AccumR := AccumR + R * Weight; + AccumG := AccumG + G * Weight; + AccumB := AccumB + B * Weight; + end; + end; + + // Now compute final color to be written to dest image + SrcFloat.A := AccumA; + SrcFloat.R := AccumR; + SrcFloat.G := AccumG; + SrcFloat.B := AccumB; + + Info.SetPixelFP(DstLine, @Info, nil, SrcFloat); + Inc(DstLine, Info.BytesPerPixel); + end; + end; + + finally + MapX := nil; + MapY := nil; + end; +end; + +procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt; + var SmallerLevel: TImageData); +var + Filter: TSamplingFilter; + Info: TImageFormatInfo; + CompatibleCopy: TImageData; +begin + Assert(TestImage(BiggerLevel)); + Filter := TSamplingFilter(GetOption(ImagingMipMapFilter)); + + // If we have special format image we must create copy to allow pixel access + GetImageFormatInfo(BiggerLevel.Format, Info); + if Info.IsSpecial then + begin + InitImage(CompatibleCopy); + CloneImage(BiggerLevel, CompatibleCopy); + ConvertImage(CompatibleCopy, ifDefault); + end + else + CompatibleCopy := BiggerLevel; + + // Create new smaller image + NewImage(Width, Height, CompatibleCopy.Format, SmallerLevel); + GetImageFormatInfo(CompatibleCopy.Format, Info); + // If input is indexed we must copy its palette + if Info.IsIndexed then + CopyPalette(CompatibleCopy.Palette, SmallerLevel.Palette, 0, 0, Info.PaletteEntries); + + if (Filter = sfNearest) or Info.IsIndexed then + begin + StretchNearest(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height, + SmallerLevel, 0, 0, Width, Height); + end + else + begin + StretchResample(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height, + SmallerLevel, 0, 0, Width, Height, Filter); + end; + + // Free copy and convert result to special format if necessary + if CompatibleCopy.Format <> BiggerLevel.Format then + begin + ConvertImage(SmallerLevel, BiggerLevel.Format); + FreeImage(CompatibleCopy); + end; +end; + + +{ Various format support functions } + +procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); +begin + case BytesPerPixel of + 1: PByte(Dest)^ := PByte(Src)^; + 2: PWord(Dest)^ := PWord(Src)^; + 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^; + 4: PUInt32(Dest)^ := PUInt32(Src)^; + 6: PColor48Rec(Dest)^ := PColor48Rec(Src)^; + 8: PInt64(Dest)^ := PInt64(Src)^; + 12: PColor96FPRec(Dest)^ := PColor96FPRec(Src)^; + 16: PColorFPRec(Dest)^ := PColorFPRec(Src)^; + end; +end; + +function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; +begin + case BytesPerPixel of + 1: Result := PByte(PixelA)^ = PByte(PixelB)^; + 2: Result := PWord(PixelA)^ = PWord(PixelB)^; + 3: Result := (PWord(PixelA)^ = PWord(PixelB)^) and (PColor24Rec(PixelA).R = PColor24Rec(PixelB).R); + 4: Result := PUInt32(PixelA)^ = PUInt32(PixelB)^; + 6: Result := (PUInt32(PixelA)^ = PUInt32(PixelB)^) and (PColor48Rec(PixelA).R = PColor48Rec(PixelB).R); + 8: Result := PInt64(PixelA)^ = PInt64(PixelB)^; + 12: Result := (PFloatHelper(PixelA).Data = PFloatHelper(PixelB).Data) and + (PFloatHelper(PixelA).Data32 = PFloatHelper(PixelB).Data32); + 16: Result := (PFloatHelper(PixelA).Data = PFloatHelper(PixelB).Data) and + (PFloatHelper(PixelA).Data64 = PFloatHelper(PixelB).Data64); + else + Result := False; + end; +end; + +procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat, + DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32); +var + SrcInfo, DstInfo: PImageFormatInfo; + PixFP: TColorFPRec; +begin + SrcInfo := FInfos[SrcFormat]; + DstInfo := FInfos[DstFormat]; + + PixFP := GetPixelFPGeneric(SrcPixel, SrcInfo, SrcPalette); + SetPixelFPGeneric(DstPixel, DstInfo, DstPalette, PixFP); +end; + +procedure ClampFloatPixel(var PixF: TColorFPRec); +begin + if PixF.A > 1.0 then + PixF.A := 1.0; + if PixF.R > 1.0 then + PixF.R := 1.0; + if PixF.G > 1.0 then + PixF.G := 1.0; + if PixF.B > 1.0 then + PixF.B := 1.0; + + if PixF.A < 0.0 then + PixF.A := 0.0; + if PixF.R < 0.0 then + PixF.R := 0.0; + if PixF.G < 0.0 then + PixF.G := 0.0; + if PixF.B < 0.0 then + PixF.B := 0.0; +end; + +procedure ConvertToPixel32(SrcPix: PByte; DestPix: PColor32Rec; + const SrcInfo: TImageFormatInfo; SrcPalette: PPalette32); +begin + case SrcInfo.Format of + ifIndex8: + begin + DestPix^ := SrcPalette[SrcPix^]; + end; + ifGray8: + begin + DestPix.R := SrcPix^; + DestPix.G := SrcPix^; + DestPix.B := SrcPix^; + DestPix.A := 255; + end; + ifA8Gray8: + begin + DestPix.R := SrcPix^; + DestPix.G := SrcPix^; + DestPix.B := SrcPix^; + DestPix.A := PWordRec(SrcPix).High; + end; + ifGray16: + begin + DestPix.R := PWord(SrcPix)^ shr 8; + DestPix.G := DestPix.R; + DestPix.B := DestPix.R; + DestPix.A := 255; + end; + ifR8G8B8: + begin + DestPix.Color24Rec := PColor24Rec(SrcPix)^; + DestPix.A := 255; + end; + ifA8R8G8B8: + begin + DestPix^ := PColor32Rec(SrcPix)^; + end; + ifR16G16B16: + begin + DestPix.R := PColor48Rec(SrcPix).R shr 8; + DestPix.G := PColor48Rec(SrcPix).G shr 8; + DestPix.B := PColor48Rec(SrcPix).B shr 8; + DestPix.A := 255; + end; + ifA16R16G16B16: + begin + DestPix.R := PColor64Rec(SrcPix).R shr 8; + DestPix.G := PColor64Rec(SrcPix).G shr 8; + DestPix.B := PColor64Rec(SrcPix).B shr 8; + DestPix.A := PColor64Rec(SrcPix).A shr 8; + end; + else + DestPix^ := SrcInfo.GetPixel32(SrcPix, @SrcInfo, SrcPalette); + end; +end; + +procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height, + Bpp, WidthBytes: LongInt); +var + I, W: LongInt; +begin + W := Width * Bpp; + for I := 0 to Height - 1 do + Move(PByteArray(DataIn)[I * W], PByteArray(DataOut)[I * WidthBytes], W); +end; + +procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height, + Bpp, WidthBytes: LongInt); +var + I, W: LongInt; +begin + W := Width * Bpp; + for I := 0 to Height - 1 do + Move(PByteArray(DataIn)[I * WidthBytes], PByteArray(DataOut)[I * W], W); +end; + +procedure Convert1To8(DataIn, DataOut: PByte; Width, Height, + WidthBytes: LongInt; ScaleTo8Bits: Boolean); +const + Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01); + Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0); + Scaling: Byte = 255; +var + X, Y: LongInt; + InArray: PByteArray absolute DataIn; +begin + for Y := 0 to Height - 1 do + for X := 0 to Width - 1 do + begin + DataOut^ := (InArray[Y * WidthBytes + X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]; + if ScaleTo8Bits then + DataOut^ := DataOut^ * Scaling; + Inc(DataOut); + end; +end; + +procedure Convert2To8(DataIn, DataOut: PByte; Width, Height, + WidthBytes: LongInt; ScaleTo8Bits: Boolean); +const + Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03); + Shift2: array[0..3] of Byte = (6, 4, 2, 0); + Scaling: Byte = 85; +var + X, Y: LongInt; + InArray: PByteArray absolute DataIn; +begin + for Y := 0 to Height - 1 do + for X := 0 to Width - 1 do + begin + DataOut^ := (InArray[Y * WidthBytes + X shr 2] and Mask2[X and 3]) shr Shift2[X and 3]; + if ScaleTo8Bits then + DataOut^ := DataOut^ * Scaling; + Inc(DataOut); + end; +end; + +procedure Convert4To8(DataIn, DataOut: PByte; Width, Height, + WidthBytes: LongInt; ScaleTo8Bits: Boolean); +const + Mask4: array[0..1] of Byte = ($F0, $0F); + Shift4: array[0..1] of Byte = (4, 0); + Scaling: Byte = 17; +var + X, Y: LongInt; + InArray: PByteArray absolute DataIn; +begin + for Y := 0 to Height - 1 do + for X := 0 to Width - 1 do + begin + DataOut^ := (InArray[Y * WidthBytes + X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]; + if ScaleTo8Bits then + DataOut^ := DataOut^ * Scaling; + Inc(DataOut); + end; +end; + +function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean; +var + I: LongInt; +begin + Result := False; + for I := 0 to NumPixels - 1 do + begin + if Data^ >= 1 shl 15 then + begin + Result := True; + Exit; + end; + Inc(Data); + end; +end; + +function Has32BitImageAlpha(NumPixels: LongInt; Data: PUInt32): Boolean; +var + I: LongInt; +begin + Result := False; + for I := 0 to NumPixels - 1 do + begin + if Data^ >= 1 shl 24 then + begin + Result := True; + Exit; + end; + Inc(Data); + end; +end; + +function PaletteHasAlpha(Palette: PPalette32; PaletteEntries: Integer): Boolean; +var + I: Integer; +begin + for I := 0 to PaletteEntries - 1 do + begin + if Palette[I].A <> 255 then + begin + Result := True; + Exit; + end; + end; + Result := False; +end; + +function PaletteIsGrayScale(Palette: PPalette32; PaletteEntries: Integer): Boolean; +var + I: Integer; +begin + for I := 0 to PaletteEntries - 1 do + begin + if (Palette[I].R <> Palette[I].G) or (Palette[I].R <> Palette[I].B) then + begin + Result := False; + Exit; + end; + end; + Result := True; +end; + +function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo; + LineWidth, Index: LongInt): Pointer; +var + LineBytes: LongInt; +begin + Assert(not FormatInfo.IsSpecial); + LineBytes := FormatInfo.GetPixelsSize(FormatInfo.Format, LineWidth, 1); + Result := @PByteArray(ImageBits)[Index * LineBytes]; +end; + +function IsImageFormatValid(Format: TImageFormat): Boolean; +begin + Result := FInfos[Format] <> nil; +end; + +const + HalfMin: Single = 5.96046448e-08; // Smallest positive half + HalfMinNorm: Single = 6.10351562e-05; // Smallest positive normalized half + HalfMax: Single = 65504.0; // Largest positive half + HalfEpsilon: Single = 0.00097656; // Smallest positive e for which half (1.0 + e) != half (1.0) + HalfNaN: THalfFloat = 65535; + HalfPosInf: THalfFloat = 31744; + HalfNegInf: THalfFloat = 64512; + + +{ + Half/Float conversions inspired by half class from OpenEXR library. + + Float (Pascal Single type) is an IEEE 754 single-precision + floating point number. + + Bit layout of Single: + + 31 (msb) + | + | 30 23 + | | | + | | | 22 0 (lsb) + | | | | | + X XXXXXXXX XXXXXXXXXXXXXXXXXXXXXXX + s e m + + Bit layout of half: + + 15 (msb) + | + | 14 10 + | | | + | | | 9 0 (lsb) + | | | | | + X XXXXX XXXXXXXXXX + s e m + + S is the sign-bit, e is the exponent and m is the significand (mantissa). +} + +function HalfToFloat(Half: THalfFloat): Single; +var + Dst, Sign, Mantissa: UInt32; + Exp: Int32; +begin + // Extract sign, exponent, and mantissa from half number + Sign := Half shr 15; + Exp := (Half and $7C00) shr 10; + Mantissa := Half and 1023; + + if (Exp > 0) and (Exp < 31) then + begin + // Common normalized number + Exp := Exp + (127 - 15); + Mantissa := Mantissa shl 13; + Dst := (Sign shl 31) or (UInt32(Exp) shl 23) or Mantissa; + // Result := Power(-1, Sign) * Power(2, Exp - 15) * (1 + Mantissa / 1024); + end + else if (Exp = 0) and (Mantissa = 0) then + begin + // Zero - preserve sign + Dst := Sign shl 31; + end + else if (Exp = 0) and (Mantissa <> 0) then + begin + // Denormalized number - renormalize it + while (Mantissa and $00000400) = 0 do + begin + Mantissa := Mantissa shl 1; + Dec(Exp); + end; + Inc(Exp); + Mantissa := Mantissa and not $00000400; + // Now assemble normalized number + Exp := Exp + (127 - 15); + Mantissa := Mantissa shl 13; + Dst := (Sign shl 31) or (UInt32(Exp) shl 23) or Mantissa; + // Result := Power(-1, Sign) * Power(2, -14) * (Mantissa / 1024); + end + else if (Exp = 31) and (Mantissa = 0) then + begin + // +/- infinity + Dst := (Sign shl 31) or $7F800000; + end + else //if (Exp = 31) and (Mantisa <> 0) then + begin + // Not a number - preserve sign and mantissa + Dst := (Sign shl 31) or $7F800000 or (Mantissa shl 13); + end; + + // Reinterpret LongWord as Single + Result := PSingle(@Dst)^; +end; + +function FloatToHalf(Float: Single): THalfFloat; +var + Src: UInt32; + Sign, Exp, Mantissa: Int32; +begin + Src := PUInt32(@Float)^; + // Extract sign, exponent, and mantissa from Single number + Sign := Src shr 31; + Exp := Int32((Src and $7F800000) shr 23) - 127 + 15; + Mantissa := Src and $007FFFFF; + + if (Exp > 0) and (Exp < 30) then + begin + // Simple case - round the significand and combine it with the sign and exponent + Result := (Sign shl 15) or (Exp shl 10) or ((Mantissa + $00001000) shr 13); + end + else if Src = 0 then + begin + // Input float is zero - return zero + Result := 0; + end + else + begin + // Difficult case - lengthy conversion + if Exp <= 0 then + begin + if Exp < -10 then + begin + // Input float's value is less than HalfMin, return zero + Result := 0; + end + else + begin + // Float is a normalized Single whose magnitude is less than HalfNormMin. + // We convert it to denormalized half. + Mantissa := (Mantissa or $00800000) shr (1 - Exp); + // Round to nearest + if (Mantissa and $00001000) > 0 then + Mantissa := Mantissa + $00002000; + // Assemble Sign and Mantissa (Exp is zero to get denormalized number) + Result := (Sign shl 15) or (Mantissa shr 13); + end; + end + else if Exp = 255 - 127 + 15 then + begin + if Mantissa = 0 then + begin + // Input float is infinity, create infinity half with original sign + Result := (Sign shl 15) or $7C00; + end + else + begin + // Input float is NaN, create half NaN with original sign and mantissa + Result := (Sign shl 15) or $7C00 or (Mantissa shr 13); + end; + end + else + begin + // Exp is > 0 so input float is normalized Single + + // Round to nearest + if (Mantissa and $00001000) > 0 then + begin + Mantissa := Mantissa + $00002000; + if (Mantissa and $00800000) > 0 then + begin + Mantissa := 0; + Exp := Exp + 1; + end; + end; + + if Exp > 30 then + begin + // Exponent overflow - return infinity half + Result := (Sign shl 15) or $7C00; + end + else + // Assemble normalized half + Result := (Sign shl 15) or (Exp shl 10) or (Mantissa shr 13); + end; + end; +end; + +function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; +begin + Result.A := HalfToFloat(ColorHF.A); + Result.R := HalfToFloat(ColorHF.R); + Result.G := HalfToFloat(ColorHF.G); + Result.B := HalfToFloat(ColorHF.B); +end; + +function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; +begin + Result.A := FloatToHalf(ColorFP.A); + Result.R := FloatToHalf(ColorFP.R); + Result.G := FloatToHalf(ColorFP.G); + Result.B := FloatToHalf(ColorFP.B); +end; + +function Color32ToGray(Color32: TColor32): Byte; +begin + Result := Round(GrayConv.R * TColor32Rec(Color32).R + + GrayConv.G * TColor32Rec(Color32).G + + GrayConv.B * TColor32Rec(Color32).B); +end; + +procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData); +var + I: Integer; + Pix: PColor32; +begin + InitImage(PalImage); + NewImage(Entries, 1, ifA8R8G8B8, PalImage); + Pix := PalImage.Bits; + for I := 0 to Entries - 1 do + begin + Pix^ := Pal[I].Color; + Inc(Pix); + end; +end; + + +{ Pixel readers/writers for different image formats } + +procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; + var Pix: TColor64Rec); +var + A, R, G, B: Byte; +begin + FillChar(Pix, SizeOf(Pix), 0); + // returns 64 bit color value with 16 bits for each channel + case SrcInfo.BytesPerPixel of + 1: + begin + PFGetARGB(SrcInfo.PixelFormat^, Src^, A, R, G, B); + Pix.A := A shl 8; + Pix.R := R shl 8; + Pix.G := G shl 8; + Pix.B := B shl 8; + end; + 2: + begin + PFGetARGB(SrcInfo.PixelFormat^, PWord(Src)^, A, R, G, B); + Pix.A := A shl 8; + Pix.R := R shl 8; + Pix.G := G shl 8; + Pix.B := B shl 8; + end; + 3: + with Pix do + begin + R := MulDiv(PColor24Rec(Src).R, 65535, 255); + G := MulDiv(PColor24Rec(Src).G, 65535, 255); + B := MulDiv(PColor24Rec(Src).B, 65535, 255); + end; + 4: + with Pix do + begin + A := MulDiv(PColor32Rec(Src).A, 65535, 255); + R := MulDiv(PColor32Rec(Src).R, 65535, 255); + G := MulDiv(PColor32Rec(Src).G, 65535, 255); + B := MulDiv(PColor32Rec(Src).B, 65535, 255); + end; + 6: + with Pix do + begin + R := PColor48Rec(Src).R; + G := PColor48Rec(Src).G; + B := PColor48Rec(Src).B; + end; + 8: Pix.Color := PColor64(Src)^; + end; + // if src has no alpha, we set it to max (otherwise we would have to + // test if dest has alpha or not in each ChannelToXXX function) + if not SrcInfo.HasAlphaChannel then + Pix.A := 65535; + + if SrcInfo.IsRBSwapped then + SwapValues(Pix.R, Pix.B); +end; + +procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; + const Pix: TColor64Rec); +var + PixW: TColor64Rec; +begin + PixW := Pix; + if DstInfo.IsRBSwapped then + SwapValues(PixW.R, PixW.B); + // Pix contains 64 bit color value with 16 bit for each channel + case DstInfo.BytesPerPixel of + 1: Dst^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8, + PixW.R shr 8, PixW.G shr 8, PixW.B shr 8); + 2: PWord(Dst)^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8, + PixW.R shr 8, PixW.G shr 8, PixW.B shr 8); + 3: + with PColor24Rec(Dst)^ do + begin + R := MulDiv(PixW.R, 255, 65535); + G := MulDiv(PixW.G, 255, 65535); + B := MulDiv(PixW.B, 255, 65535); + end; + 4: + with PColor32Rec(Dst)^ do + begin + A := MulDiv(PixW.A, 255, 65535); + R := MulDiv(PixW.R, 255, 65535); + G := MulDiv(PixW.G, 255, 65535); + B := MulDiv(PixW.B, 255, 65535); + end; + 6: + with PColor48Rec(Dst)^ do + begin + R := PixW.R; + G := PixW.G; + B := PixW.B; + end; + 8: PColor64(Dst)^ := PixW.Color; + end; +end; + +procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; + var Gray: TColor64Rec; var Alpha: Word); +begin + FillChar(Gray, SizeOf(Gray), 0); + // Source alpha is scaled to 16 bits and stored in Alpha, + // grayscale value is scaled to 64 bits and stored in Gray + case SrcInfo.BytesPerPixel of + 1: Gray.A := MulDiv(Src^, 65535, 255); + 2: + if SrcInfo.HasAlphaChannel then + with PWordRec(Src)^ do + begin + Alpha := MulDiv(High, 65535, 255); + Gray.A := MulDiv(Low, 65535, 255); + end + else + Gray.A := PWord(Src)^; + 4: + if SrcInfo.HasAlphaChannel then + with PUInt32Rec(Src)^ do + begin + Alpha := High; + Gray.A := Low; + end + else + with PUInt32Rec(Src)^ do + begin + Gray.A := High; + Gray.R := Low; + end; + 8: Gray.Color := PColor64(Src)^; + end; + // if src has no alpha, we set it to max (otherwise we would have to + // test if dest has alpha or not in each GrayToXXX function) + if not SrcInfo.HasAlphaChannel then + Alpha := 65535; +end; + +procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; + const Gray: TColor64Rec; Alpha: Word); +begin + // Gray contains grayscale value scaled to 64 bits, Alpha contains + // alpha value scaled to 16 bits + case DstInfo.BytesPerPixel of + 1: Dst^ := MulDiv(Gray.A, 255, 65535); + 2: + if DstInfo.HasAlphaChannel then + with PWordRec(Dst)^ do + begin + High := MulDiv(Alpha, 255, 65535); + Low := MulDiv(Gray.A, 255, 65535); + end + else + PWord(Dst)^ := Gray.A; + 4: + if DstInfo.HasAlphaChannel then + with PUInt32Rec(Dst)^ do + begin + High := Alpha; + Low := Gray.A; + end + else + with PUInt32Rec(Dst)^ do + begin + High := Gray.A; + Low := Gray.R; + end; + 8: PColor64(Dst)^ := Gray.Color; + end; +end; + +procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; + var Pix: TColorFPRec); +var + PixHF: TColorHFRec; +begin + Assert(SrcInfo.BytesPerPixel in [2, 4, 8, 12, 16]); + + if SrcInfo.BytesPerPixel in [4, 12, 16] then + begin + // IEEE 754 single-precision channels + FillChar(Pix, SizeOf(Pix), 0); + case SrcInfo.BytesPerPixel of + 4: Pix.R := PSingle(Src)^; + 12: Pix.Color96Rec := PColor96FPRec(Src)^; + 16: Pix := PColorFPRec(Src)^; + end; + end + else + begin + // Half float channels + FillChar(PixHF, SizeOf(PixHF), 0); + case SrcInfo.BytesPerPixel of + 2: PixHF.R := PHalfFloat(Src)^; + 8: PixHF := PColorHFRec(Src)^; + end; + Pix := ColorHalfToFloat(PixHF); + end; + + // If src has no alpha, we set it to max (otherwise we would have to + // test if dest has alpha or not in each FloatToXXX function) + if not SrcInfo.HasAlphaChannel then + Pix.A := 1.0; + if SrcInfo.IsRBSwapped then + SwapValues(Pix.R, Pix.B); +end; + +procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; + const Pix: TColorFPRec); +var + PixW: TColorFPRec; + PixHF: TColorHFRec; +begin + Assert(DstInfo.BytesPerPixel in [2, 4, 8, 12, 16]); + + PixW := Pix; + if DstInfo.IsRBSwapped then + SwapValues(PixW.R, PixW.B); + + if DstInfo.BytesPerPixel in [4, 12, 16] then + begin + case DstInfo.BytesPerPixel of + 4: PSingle(Dst)^ := PixW.R; + 12: PColor96FPRec(Dst)^:= PixW.Color96Rec; + 16: PColorFPRec(Dst)^ := PixW; + end; + end + else + begin + PixHF := ColorFloatToHalf(PixW); + case DstInfo.BytesPerPixel of + 2: PHalfFloat(Dst)^ := PixHF.R; + 8: PColorHFRec(Dst)^ := PixHF; + end; + end; +end; + +procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; + var Index: UInt32); +begin + case SrcInfo.BytesPerPixel of + 1: Index := Src^; + end; +end; + +procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; + Index: UInt32); +begin + case DstInfo.BytesPerPixel of + 1: Dst^ := Byte(Index); + 2: PWord(Dst)^ := Word(Index); + 4: PUInt32(Dst)^ := Index; + end; +end; + + +{ Pixel readers/writers for 32bit and FP colors} + +function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; +var + Pix64: TColor64Rec; + PixF: TColorFPRec; + Alpha: Word; + Index: UInt32; +begin + if Info.Format = ifA8R8G8B8 then + begin + Result := PColor32Rec(Bits)^ + end + else if Info.Format = ifR8G8B8 then + begin + PColor24Rec(@Result)^ := PColor24Rec(Bits)^; + Result.A := $FF; + end + else if Info.IsFloatingPoint then + begin + FloatGetSrcPixel(Bits, Info, PixF); + Result.A := ClampToByte(Round(PixF.A * 255.0)); + Result.R := ClampToByte(Round(PixF.R * 255.0)); + Result.G := ClampToByte(Round(PixF.G * 255.0)); + Result.B := ClampToByte(Round(PixF.B * 255.0)); + end + else if Info.HasGrayChannel then + begin + GrayGetSrcPixel(Bits, Info, Pix64, Alpha); + Result.A := MulDiv(Alpha, 255, 65535); + Result.R := MulDiv(Pix64.A, 255, 65535); + Result.G := MulDiv(Pix64.A, 255, 65535); + Result.B := MulDiv(Pix64.A, 255, 65535); + end + else if Info.IsIndexed then + begin + IndexGetSrcPixel(Bits, Info, Index); + Result := Palette[Index]; + end + else + begin + ChannelGetSrcPixel(Bits, Info, Pix64); + Result.A := MulDiv(Pix64.A, 255, 65535); + Result.R := MulDiv(Pix64.R, 255, 65535); + Result.G := MulDiv(Pix64.G, 255, 65535); + Result.B := MulDiv(Pix64.B, 255, 65535); + end; +end; + +procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); +var + Pix64: TColor64Rec; + PixF: TColorFPRec; + Alpha: Word; + Index: UInt32; +begin + if Info.Format = ifA8R8G8B8 then + begin + PColor32Rec(Bits)^ := Color + end + else if Info.Format = ifR8G8B8 then + begin + PColor24Rec(Bits)^ := Color.Color24Rec; + end + else if Info.IsFloatingPoint then + begin + PixF.A := Color.A * OneDiv8Bit; + PixF.R := Color.R * OneDiv8Bit; + PixF.G := Color.G * OneDiv8Bit; + PixF.B := Color.B * OneDiv8Bit; + FloatSetDstPixel(Bits, Info, PixF); + end + else if Info.HasGrayChannel then + begin + Alpha := MulDiv(Color.A, 65535, 255); + Pix64.Color := 0; + Pix64.A := MulDiv(Round(GrayConv.R * Color.R + GrayConv.G * Color.G + + GrayConv.B * Color.B), 65535, 255); + GraySetDstPixel(Bits, Info, Pix64, Alpha); + end + else if Info.IsIndexed then + begin + Index := FindColor(Palette, Info.PaletteEntries, Color.Color); + IndexSetDstPixel(Bits, Info, Index); + end + else + begin + Pix64.A := MulDiv(Color.A, 65535, 255); + Pix64.R := MulDiv(Color.R, 65535, 255); + Pix64.G := MulDiv(Color.G, 65535, 255); + Pix64.B := MulDiv(Color.B, 65535, 255); + ChannelSetDstPixel(Bits, Info, Pix64); + end; +end; + +function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; +var + Pix32: TColor32Rec; + Pix64: TColor64Rec; + Alpha: Word; + Index: UInt32; +begin + if Info.IsFloatingPoint then + begin + FloatGetSrcPixel(Bits, Info, Result); + end + else if Info.HasGrayChannel then + begin + GrayGetSrcPixel(Bits, Info, Pix64, Alpha); + Result.A := Alpha * OneDiv16Bit; + Result.R := Pix64.A * OneDiv16Bit; + Result.G := Pix64.A * OneDiv16Bit; + Result.B := Pix64.A * OneDiv16Bit; + end + else if Info.IsIndexed then + begin + IndexGetSrcPixel(Bits, Info, Index); + Pix32 := Palette[Index]; + Result.A := Pix32.A * OneDiv8Bit; + Result.R := Pix32.R * OneDiv8Bit; + Result.G := Pix32.G * OneDiv8Bit; + Result.B := Pix32.B * OneDiv8Bit; + end + else + begin + ChannelGetSrcPixel(Bits, Info, Pix64); + Result.A := Pix64.A * OneDiv16Bit; + Result.R := Pix64.R * OneDiv16Bit; + Result.G := Pix64.G * OneDiv16Bit; + Result.B := Pix64.B * OneDiv16Bit; + end; +end; + +procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); +var + Pix32: TColor32Rec; + Pix64: TColor64Rec; + Alpha: Word; + Index: UInt32; +begin + if Info.IsFloatingPoint then + begin + FloatSetDstPixel(Bits, Info, Color); + end + else if Info.HasGrayChannel then + begin + Alpha := ClampToWord(Round(Color.A * 65535.0)); + Pix64.Color := 0; + Pix64.A := ClampToWord(Round((GrayConv.R * Color.R + GrayConv.G * Color.G + + GrayConv.B * Color.B) * 65535.0)); + GraySetDstPixel(Bits, Info, Pix64, Alpha); + end + else if Info.IsIndexed then + begin + Pix32.A := ClampToByte(Round(Color.A * 255.0)); + Pix32.R := ClampToByte(Round(Color.R * 255.0)); + Pix32.G := ClampToByte(Round(Color.G * 255.0)); + Pix32.B := ClampToByte(Round(Color.B * 255.0)); + Index := FindColor(Palette, Info.PaletteEntries, Pix32.Color); + IndexSetDstPixel(Bits, Info, Index); + end + else + begin + Pix64.A := ClampToWord(Round(Color.A * 65535.0)); + Pix64.R := ClampToWord(Round(Color.R * 65535.0)); + Pix64.G := ClampToWord(Round(Color.G * 65535.0)); + Pix64.B := ClampToWord(Round(Color.B * 65535.0)); + ChannelSetDstPixel(Bits, Info, Pix64); + end; +end; + + +{ Image format conversion functions } + +procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +var + I: LongInt; + Pix64: TColor64Rec; +begin + // two most common conversions (RGB->ARGB and ARGB->RGB for 24/32 bit + // images) are made separately from general ARGB conversion to + // make them faster + if (SrcInfo.BytesPerPixel = 3) and (DstInfo.BytesPerPixel = 4) then + for I := 0 to NumPixels - 1 do + begin + PColor24Rec(Dst)^ := PColor24Rec(Src)^; + if DstInfo.HasAlphaChannel then + PColor32Rec(Dst).A := 255; + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end + else + if (SrcInfo.BytesPerPixel = 4) and (DstInfo.BytesPerPixel = 3) then + for I := 0 to NumPixels - 1 do + begin + PColor24Rec(Dst)^ := PColor24Rec(Src)^; + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end + else + for I := 0 to NumPixels - 1 do + begin + // general ARGB conversion + ChannelGetSrcPixel(Src, SrcInfo, Pix64); + ChannelSetDstPixel(Dst, DstInfo, Pix64); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +var + I: LongInt; + Pix64: TColor64Rec; + Alpha: Word; +begin + // two most common conversions (R8G8B8->Gray8 nad A8R8G8B8->Gray8) + // are made separately from general conversions to make them faster + if (SrcInfo.BytesPerPixel in [3, 4]) and (DstInfo.Format = ifGray8) then + for I := 0 to NumPixels - 1 do + begin + Dst^ := Round(GrayConv.R * PColor24Rec(Src).R + GrayConv.G * PColor24Rec(Src).G + + GrayConv.B * PColor24Rec(Src).B); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end + else + for I := 0 to NumPixels - 1 do + begin + ChannelGetSrcPixel(Src, SrcInfo, Pix64); + + // alpha is saved from source pixel to Alpha, + // Gray value is computed and set to highest word of Pix64 so + // Pix64.Color contains grayscale value scaled to 64 bits + Alpha := Pix64.A; + with GrayConv do + Pix64.A := Round(R * Pix64.R + G * Pix64.G + B * Pix64.B); + + GraySetDstPixel(Dst, DstInfo, Pix64, Alpha); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +var + I: LongInt; + Pix64: TColor64Rec; + PixF: TColorFPRec; +begin + for I := 0 to NumPixels - 1 do + begin + ChannelGetSrcPixel(Src, SrcInfo, Pix64); + + // floating point channel values are scaled to 1.0 + PixF.A := Pix64.A * OneDiv16Bit; + PixF.R := Pix64.R * OneDiv16Bit; + PixF.G := Pix64.G * OneDiv16Bit; + PixF.B := Pix64.B * OneDiv16Bit; + + FloatSetDstPixel(Dst, DstInfo, PixF); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; DstPal: PPalette32); +begin + ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries, + GetOption(ImagingColorReductionMask), DstPal); +end; + +procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +var + I: LongInt; + Gray: TColor64Rec; + Alpha: Word; +begin + // two most common conversions (Gray8->Gray16 nad Gray16->Gray8) + // are made separately from general conversions to make them faster + if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifGray16) then + begin + for I := 0 to NumPixels - 1 do + PWordArray(Dst)[I] := PByteArray(Src)[I] shl 8; + end + else + begin + if (DstInfo.Format = ifGray8) and (SrcInfo.Format = ifGray16) then + begin + for I := 0 to NumPixels - 1 do + PByteArray(Dst)[I] := PWordArray(Src)[I] shr 8; + end + else + for I := 0 to NumPixels - 1 do + begin + // general grayscale conversion + GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha); + GraySetDstPixel(Dst, DstInfo, Gray, Alpha); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; + end; +end; + +procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +var + I: LongInt; + Pix64: TColor64Rec; + Alpha: Word; +begin + // two most common conversions (Gray8->R8G8B8 nad Gray8->A8R8G8B8) + // are made separately from general conversions to make them faster + if (DstInfo.BytesPerPixel in [3, 4]) and (SrcInfo.Format = ifGray8) then + for I := 0 to NumPixels - 1 do + begin + PColor24Rec(Dst).R := Src^; + PColor24Rec(Dst).G := Src^; + PColor24Rec(Dst).B := Src^; + if DstInfo.HasAlphaChannel then + PColor32Rec(Dst).A := $FF; + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end + else + for I := 0 to NumPixels - 1 do + begin + GrayGetSrcPixel(Src, SrcInfo, Pix64, Alpha); + + // most significant word of grayscale value is used for + // each channel and alpha channel is set to Alpha + Pix64.R := Pix64.A; + Pix64.G := Pix64.A; + Pix64.B := Pix64.A; + Pix64.A := Alpha; + + ChannelSetDstPixel(Dst, DstInfo, Pix64); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +var + I: LongInt; + Gray: TColor64Rec; + PixF: TColorFPRec; + Alpha: Word; +begin + for I := 0 to NumPixels - 1 do + begin + GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha); + // most significant word of grayscale value is used for + // each channel and alpha channel is set to Alpha + // then all is scaled to 0..1 + PixF.R := Gray.A * OneDiv16Bit; + PixF.G := Gray.A * OneDiv16Bit; + PixF.B := Gray.A * OneDiv16Bit; + PixF.A := Alpha * OneDiv16Bit; + + FloatSetDstPixel(Dst, DstInfo, PixF); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; DstPal: PPalette32); +var + I: LongInt; + Idx: UInt32; + Gray: TColor64Rec; + Alpha, Shift: Word; +begin + FillGrayscalePalette(DstPal, DstInfo.PaletteEntries); + Shift := Log2Int(DstInfo.PaletteEntries); + // most common conversion (Gray8->Index8) + // is made separately from general conversions to make it faster + if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifIndex8) then + for I := 0 to NumPixels - 1 do + begin + Dst^ := Src^; + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end + else + for I := 0 to NumPixels - 1 do + begin + // gray value is read from src and index to precomputed + // grayscale palette is computed and written to dst + // (we assume here that there will be no more than 65536 palette + // entries in dst format, gray value is shifted so the highest + // gray value match the highest possible index in palette) + GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha); + Idx := Gray.A shr (16 - Shift); + IndexSetDstPixel(Dst, DstInfo, Idx); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +var + I: LongInt; + PixF: TColorFPRec; +begin + for I := 0 to NumPixels - 1 do + begin + // general floating point conversion + FloatGetSrcPixel(Src, SrcInfo, PixF); + FloatSetDstPixel(Dst, DstInfo, PixF); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +var + I: LongInt; + Pix64: TColor64Rec; + PixF: TColorFPRec; +begin + for I := 0 to NumPixels - 1 do + begin + FloatGetSrcPixel(Src, SrcInfo, PixF); + ClampFloatPixel(PixF); + + // floating point channel values are scaled to 1.0 + Pix64.A := ClampToWord(Round(PixF.A * 65535)); + Pix64.R := ClampToWord(Round(PixF.R * 65535)); + Pix64.G := ClampToWord(Round(PixF.G * 65535)); + Pix64.B := ClampToWord(Round(PixF.B * 65535)); + + ChannelSetDstPixel(Dst, DstInfo, Pix64); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo); +var + I: LongInt; + PixF: TColorFPRec; + Gray: TColor64Rec; + Alpha: Word; +begin + for I := 0 to NumPixels - 1 do + begin + FloatGetSrcPixel(Src, SrcInfo, PixF); + ClampFloatPixel(PixF); + + // alpha is saved from source pixel to Alpha, + // Gray value is computed and set to highest word of Pix64 so + // Pix64.Color contains grayscale value scaled to 64 bits + Alpha := ClampToWord(Round(PixF.A * 65535.0)); + Gray.A := ClampToWord(Round((GrayConv.R * PixF.R + GrayConv.G * PixF.G + + GrayConv.B * PixF.B) * 65535.0)); + + GraySetDstPixel(Dst, DstInfo, Gray, Alpha); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; DstPal: PPalette32); +begin + ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries, + GetOption(ImagingColorReductionMask), DstPal); +end; + +procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32); +var + I: LongInt; +begin + // there is only one indexed format now, so it is just a copy + for I := 0 to NumPixels - 1 do + begin + Dst^ := Src^; + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; + for I := 0 to SrcInfo.PaletteEntries - 1 do + DstPal[I] := SrcPal[I]; +end; + +procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; SrcPal: PPalette32); +var + I: LongInt; + Pix64: TColor64Rec; + Idx: UInt32; +begin + // two most common conversions (Index8->R8G8B8 nad Index8->A8R8G8B8) + // are made separately from general conversions to make them faster + if (SrcInfo.Format = ifIndex8) and (DstInfo.Format in [ifR8G8B8, ifA8R8G8B8]) then + for I := 0 to NumPixels - 1 do + begin + with PColor24Rec(Dst)^ do + begin + R := SrcPal[Src^].R; + G := SrcPal[Src^].G; + B := SrcPal[Src^].B; + end; + if DstInfo.Format = ifA8R8G8B8 then + PColor32Rec(Dst).A := SrcPal[Src^].A; + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end + else + for I := 0 to NumPixels - 1 do + begin + // index to palette is read from source and color + // is retrieved from palette entry. Color is then + // scaled to 16bits and written to dest + IndexGetSrcPixel(Src, SrcInfo, Idx); + with Pix64 do + begin + A := SrcPal[Idx].A shl 8; + R := SrcPal[Idx].R shl 8; + G := SrcPal[Idx].G shl 8; + B := SrcPal[Idx].B shl 8; + end; + ChannelSetDstPixel(Dst, DstInfo, Pix64); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; SrcPal: PPalette32); +var + I: LongInt; + Gray: TColor64Rec; + Alpha: Word; + Idx: UInt32; +begin + // most common conversion (Index8->Gray8) + // is made separately from general conversions to make it faster + if (SrcInfo.Format = ifIndex8) and (DstInfo.Format = ifGray8) then + begin + for I := 0 to NumPixels - 1 do + begin + Dst^ := Round(GrayConv.R * SrcPal[Src^].R + GrayConv.G * SrcPal[Src^].G + + GrayConv.B * SrcPal[Src^].B); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end + end + else + for I := 0 to NumPixels - 1 do + begin + // index to palette is read from source and color + // is retrieved from palette entry. Color is then + // transformed to grayscale and assigned to the highest + // byte of Gray value + IndexGetSrcPixel(Src, SrcInfo, Idx); + Alpha := SrcPal[Idx].A shl 8; + Gray.A := MulDiv(Round(GrayConv.R * SrcPal[Idx].R + GrayConv.G * SrcPal[Idx].G + + GrayConv.B * SrcPal[Idx].B), 65535, 255); + GraySetDstPixel(Dst, DstInfo, Gray, Alpha); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + +procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, + DstInfo: PImageFormatInfo; SrcPal: PPalette32); +var + I: LongInt; + Idx: UInt32; + PixF: TColorFPRec; +begin + for I := 0 to NumPixels - 1 do + begin + // index to palette is read from source and color + // is retrieved from palette entry. Color is then + // scaled to 0..1 and written to dest + IndexGetSrcPixel(Src, SrcInfo, Idx); + with PixF do + begin + A := SrcPal[Idx].A * OneDiv8Bit; + R := SrcPal[Idx].R * OneDiv8Bit; + G := SrcPal[Idx].G * OneDiv8Bit; + B := SrcPal[Idx].B * OneDiv8Bit; + end; + FloatSetDstPixel(Dst, DstInfo, PixF); + Inc(Src, SrcInfo.BytesPerPixel); + Inc(Dst, DstInfo.BytesPerPixel); + end; +end; + + +{ Special formats conversion functions } + +type + // DXT RGB color block + TDXTColorBlock = packed record + Color0, Color1: Word; + Mask: UInt32; + end; + PDXTColorBlock = ^TDXTColorBlock; + + // DXT explicit alpha for a block + TDXTAlphaBlockExp = packed record + Alphas: array[0..3] of Word; + end; + PDXTAlphaBlockExp = ^TDXTAlphaBlockExp; + + // DXT interpolated alpha for a block + TDXTAlphaBlockInt = packed record + Alphas: array[0..7] of Byte; + end; + PDXTAlphaBlockInt = ^TDXTAlphaBlockInt; + + TPixelInfo = record + Color: Word; + Alpha: Byte; + Orig: TColor32Rec; + end; + + TPixelBlock = array[0..15] of TPixelInfo; + +function DecodeCol(Color: Word): TColor32Rec; +{$IFDEF USE_INLINE} inline; {$ENDIF} +begin + Result.A := $FF; +{ Result.R := ((Color and $F800) shr 11) shl 3; + Result.G := ((Color and $07E0) shr 5) shl 2; + Result.B := (Color and $001F) shl 3;} + // this color expansion is slower but gives better results + Result.R := (Color shr 11) * 255 div 31; + Result.G := ((Color shr 5) and $3F) * 255 div 63; + Result.B := (Color and $1F) * 255 div 31; +end; + +procedure DecodeDXT1(SrcBits, DestBits: PByte; Width, Height: LongInt); +var + Sel, X, Y, I, J, K: LongInt; + Block: TDXTColorBlock; + Colors: array[0..3] of TColor32Rec; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + Block := PDXTColorBlock(SrcBits)^; + Inc(SrcBits, SizeOf(Block)); + // we read and decode endpoint colors + Colors[0] := DecodeCol(Block.Color0); + Colors[1] := DecodeCol(Block.Color1); + // and interpolate between them + if Block.Color0 > Block.Color1 then + begin + // interpolation for block without alpha + Colors[2].A := $FF; + Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3; + Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3; + Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3; + Colors[3].A := $FF; + Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3; + Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3; + Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3; + end + else + begin + // interpolation for block with alpha + Colors[2].A := $FF; + Colors[2].R := (Colors[0].R + Colors[1].R) shr 1; + Colors[2].G := (Colors[0].G + Colors[1].G) shr 1; + Colors[2].B := (Colors[0].B + Colors[1].B) shr 1; + Colors[3].A := 0; + Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3; + Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3; + Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3; + end; + + // we distribute the dxt block colors across the 4x4 block of the + // destination image according to the dxt block mask + K := 0; + for J := 0 to 3 do + for I := 0 to 3 do + begin + Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1); + if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then + PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] := + Colors[Sel]; + Inc(K); + end; + end; +end; + +procedure DecodeDXT3(SrcBits, DestBits: PByte; Width, Height: LongInt); +var + Sel, X, Y, I, J, K: LongInt; + Block: TDXTColorBlock; + AlphaBlock: TDXTAlphaBlockExp; + Colors: array[0..3] of TColor32Rec; + AWord: Word; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + AlphaBlock := PDXTAlphaBlockExp(SrcBits)^; + Inc(SrcBits, SizeOf(AlphaBlock)); + Block := PDXTColorBlock(SrcBits)^; + Inc(SrcBits, SizeOf(Block)); + // we read and decode endpoint colors + Colors[0] := DecodeCol(Block.Color0); + Colors[1] := DecodeCol(Block.Color1); + // and interpolate between them + Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3; + Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3; + Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3; + Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3; + Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3; + Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3; + + // we distribute the dxt block colors and alphas + // across the 4x4 block of the destination image + // according to the dxt block mask and alpha block + K := 0; + for J := 0 to 3 do + begin + AWord := AlphaBlock.Alphas[J]; + for I := 0 to 3 do + begin + Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1); + if (X shl 2 + I < Width) and (Y shl 2 + J < Height) then + begin + Colors[Sel].A := AWord and $0F; + Colors[Sel].A := Colors[Sel].A or (Colors[Sel].A shl 4); + PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] := + Colors[Sel]; + end; + Inc(K); + AWord := AWord shr 4; + end; + end; + end; +end; + +procedure GetInterpolatedAlphas(var AlphaBlock: TDXTAlphaBlockInt); +begin + with AlphaBlock do + if Alphas[0] > Alphas[1] then + begin + // Interpolation of six alphas + Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7; + Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7; + Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7; + Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7; + Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7; + Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7; + end + else + begin + // Interpolation of four alphas, two alphas are set directly + Alphas[2] := (4 * Alphas[0] + 1 * Alphas[1] + 2) div 5; + Alphas[3] := (3 * Alphas[0] + 2 * Alphas[1] + 2) div 5; + Alphas[4] := (2 * Alphas[0] + 3 * Alphas[1] + 2) div 5; + Alphas[5] := (1 * Alphas[0] + 4 * Alphas[1] + 2) div 5; + Alphas[6] := 0; + Alphas[7] := $FF; + end; +end; + +procedure DecodeDXT5(SrcBits, DestBits: PByte; Width, Height: LongInt); +var + Sel, X, Y, I, J, K: LongInt; + Block: TDXTColorBlock; + AlphaBlock: TDXTAlphaBlockInt; + Colors: array[0..3] of TColor32Rec; + AMask: array[0..1] of UInt32; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + AlphaBlock := PDXTAlphaBlockInt(SrcBits)^; + Inc(SrcBits, SizeOf(AlphaBlock)); + Block := PDXTColorBlock(SrcBits)^; + Inc(SrcBits, SizeOf(Block)); + // we read and decode endpoint colors + Colors[0] := DecodeCol(Block.Color0); + Colors[1] := DecodeCol(Block.Color1); + // and interpolate between them + Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3; + Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3; + Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3; + Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3; + Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3; + Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3; + // 6 bit alpha mask is copied into two long words for + // easier usage + AMask[0] := PUInt32(@AlphaBlock.Alphas[2])^ and $00FFFFFF; + AMask[1] := PUInt32(@AlphaBlock.Alphas[5])^ and $00FFFFFF; + // alpha interpolation between two endpoint alphas + GetInterpolatedAlphas(AlphaBlock); + + // we distribute the dxt block colors and alphas + // across the 4x4 block of the destination image + // accroding to the dxt block mask and alpha block mask + K := 0; + for J := 0 to 3 do + for I := 0 to 3 do + begin + Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1); + if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then + begin + Colors[Sel].A := AlphaBlock.Alphas[AMask[J shr 1] and 7]; + PPalette32(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := + Colors[Sel]; + end; + Inc(K); + AMask[J shr 1] := AMask[J shr 1] shr 3; + end; + end; +end; + +procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos, + Width, Height: LongInt); +var + X, Y, I: LongInt; + Src: PColor32Rec; +begin + I := 0; + // 4x4 pixel block is filled with information about every + // pixel in the block: alpha, original color, 565 color + for Y := 0 to 3 do + for X := 0 to 3 do + begin + Src := @PPalette32(SrcBits)[(YPos shl 2 + Y) * Width + XPos shl 2 + X]; + Block[I].Color := ((Src.R shr 3) shl 11) or ((Src.G shr 2) shl 5) or + (Src.B shr 3); + Block[I].Alpha := Src.A; + Block[I].Orig := Src^; + Inc(I); + end; +end; + +function ColorDistance(const C1, C2: TColor32Rec): LongInt; +{$IFDEF USE_INLINE} inline;{$ENDIF} +begin + Result := (C1.R - C2.R) * (C1.R - C2.R) + + (C1.G - C2.G) * (C1.G - C2.G) + (C1.B - C2.B) * (C1.B - C2.B); +end; + +procedure GetEndpoints(const Block: TPixelBlock; var Ep0, Ep1: Word); +var + I, J, Farthest, Dist: LongInt; + Colors: array[0..15] of TColor32Rec; +begin + // we choose two colors from the pixel block which has the + // largest distance between them + for I := 0 to 15 do + Colors[I] := Block[I].Orig; + Farthest := -1; + for I := 0 to 15 do + for J := I + 1 to 15 do + begin + Dist := ColorDistance(Colors[I], Colors[J]); + if Dist > Farthest then + begin + Farthest := Dist; + Ep0 := Block[I].Color; + Ep1 := Block[J].Color; + end; + end; +end; + +procedure GetAlphaEndpoints(const Block: TPixelBlock; var Min, Max: Byte); +var + I: LongInt; +begin + Min := 255; + Max := 0; + // we choose the lowest and the highest alpha values + for I := 0 to 15 do + begin + if Block[I].Alpha < Min then + Min := Block[I].Alpha; + if Block[I].Alpha > Max then + Max := Block[I].Alpha; + end; +end; + +procedure FixEndpoints(var Ep0, Ep1: Word; HasAlpha: Boolean); +var + Temp: Word; +begin + // if dxt block has alpha information, Ep0 must be smaller + // than Ep1, if the block has no alpha Ep1 must be smaller + if HasAlpha then + begin + if Ep0 > Ep1 then + begin + Temp := Ep0; + Ep0 := Ep1; + Ep1 := Temp; + end; + end + else + if Ep0 < Ep1 then + begin + Temp := Ep0; + Ep0 := Ep1; + Ep1 := Temp; + end; +end; + +function GetColorMask(Ep0, Ep1: Word; NumCols: LongInt; + const Block: TPixelBlock): UInt32; +var + I, J, Closest, Dist: LongInt; + Colors: array[0..3] of TColor32Rec; + Mask: array[0..15] of Byte; +begin + // we decode endpoint colors + Colors[0] := DecodeCol(Ep0); + Colors[1] := DecodeCol(Ep1); + // and interpolate colors between (3 for DXT1 with alpha, 4 for the others) + if NumCols = 3 then + begin + Colors[2].R := (Colors[0].R + Colors[1].R) shr 1; + Colors[2].G := (Colors[0].G + Colors[1].G) shr 1; + Colors[2].B := (Colors[0].B + Colors[1].B) shr 1; + Colors[3].R := (Colors[0].R + Colors[1].R) shr 1; + Colors[3].G := (Colors[0].G + Colors[1].G) shr 1; + Colors[3].B := (Colors[0].B + Colors[1].B) shr 1; + end + else + begin + Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3; + Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3; + Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3; + Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3; + Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3; + Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3; + end; + + for I := 0 to 15 do + begin + // this is only for DXT1 with alpha + if (Block[I].Alpha < 128) and (NumCols = 3) then + begin + Mask[I] := 3; + Continue; + end; + // for each of the 16 input pixels the nearest color in the + // 4 dxt colors is found + Closest := MaxInt; + for J := 0 to NumCols - 1 do + begin + Dist := ColorDistance(Block[I].Orig, Colors[J]); + if Dist < Closest then + begin + Closest := Dist; + Mask[I] := J; + end; + end; + end; + + Result := 0; + for I := 0 to 15 do + Result := Result or (Mask[I] shl (I shl 1)); +end; + +procedure GetAlphaMask(Ep0, Ep1: Byte; var Block: TPixelBlock; Mask: PByteArray); +var + Alphas: array[0..7] of Byte; + M: array[0..15] of Byte; + I, J, Closest, Dist: LongInt; +begin + Alphas[0] := Ep0; + Alphas[1] := Ep1; + // interpolation between two given alpha endpoints + // (I use 6 interpolated values mode) + Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7; + Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7; + Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7; + Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7; + Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7; + Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7; + + // the closest interpolated values for each of the input alpha + // is found + for I := 0 to 15 do + begin + Closest := MaxInt; + for J := 0 to 7 do + begin + Dist := Abs(Alphas[J] - Block[I].Alpha); + if Dist < Closest then + begin + Closest := Dist; + M[I] := J; + end; + end; + end; + + Mask[0] := M[0] or (M[1] shl 3) or ((M[2] and 3) shl 6); + Mask[1] := ((M[2] and 4) shr 2) or (M[3] shl 1) or (M[4] shl 4) or + ((M[5] and 1) shl 7); + Mask[2] := ((M[5] and 6) shr 1) or (M[6] shl 2) or (M[7] shl 5); + Mask[3] := M[8] or (M[9] shl 3) or ((M[10] and 3) shl 6); + Mask[4] := ((M[10] and 4) shr 2) or (M[11] shl 1) or (M[12] shl 4) or + ((M[13] and 1) shl 7); + Mask[5] := ((M[13] and 6) shr 1) or (M[14] shl 2) or (M[15] shl 5); +end; + + +procedure EncodeDXT1(SrcBits: PByte; DestBits: PByte; Width, Height: LongInt); +var + X, Y, I: LongInt; + HasAlpha: Boolean; + Block: TDXTColorBlock; + Pixels: TPixelBlock; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + GetBlock(Pixels, SrcBits, X, Y, Width, Height); + HasAlpha := False; + for I := 0 to 15 do + if Pixels[I].Alpha < 128 then + begin + HasAlpha := True; + Break; + end; + GetEndpoints(Pixels, Block.Color0, Block.Color1); + FixEndpoints(Block.Color0, Block.Color1, HasAlpha); + if HasAlpha then + Block.Mask := GetColorMask(Block.Color0, Block.Color1, 3, Pixels) + else + Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels); + PDXTColorBlock(DestBits)^ := Block; + Inc(DestBits, SizeOf(Block)); + end; +end; + +procedure EncodeDXT3(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt); +var + X, Y, I: LongInt; + Block: TDXTColorBlock; + AlphaBlock: TDXTAlphaBlockExp; + Pixels: TPixelBlock; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + GetBlock(Pixels, SrcBits, X, Y, Width, Height); + for I := 0 to 7 do + PByteArray(@AlphaBlock.Alphas)[I] := + (Pixels[I shl 1].Alpha shr 4) or ((Pixels[I shl 1 + 1].Alpha shr 4) shl 4); + GetEndpoints(Pixels, Block.Color0, Block.Color1); + FixEndpoints(Block.Color0, Block.Color1, False); + Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels); + PDXTAlphaBlockExp(DestBits)^ := AlphaBlock; + Inc(DestBits, SizeOf(AlphaBlock)); + PDXTColorBlock(DestBits)^ := Block; + Inc(DestBits, SizeOf(Block)); + end; +end; + +procedure EncodeDXT5(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt); +var + X, Y: LongInt; + Block: TDXTColorBlock; + AlphaBlock: TDXTAlphaBlockInt; + Pixels: TPixelBlock; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + GetBlock(Pixels, SrcBits, X, Y, Width, Height); + GetEndpoints(Pixels, Block.Color0, Block.Color1); + FixEndpoints(Block.Color0, Block.Color1, False); + Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels); + GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); + GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, + PByteArray(@AlphaBlock.Alphas[2])); + PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; + Inc(DestBits, SizeOf(AlphaBlock)); + PDXTColorBlock(DestBits)^ := Block; + Inc(DestBits, SizeOf(Block)); + end; +end; + +type + TBTCBlock = packed record + MLower, MUpper: Byte; + BitField: Word; + end; + PBTCBlock = ^TBTCBlock; + +procedure EncodeBTC(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer); +var + X, Y, I, J: Integer; + Block: TBTCBlock; + M, MLower, MUpper, K: Integer; + Pixels: array[0..15] of Byte; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + M := 0; + MLower := 0; + MUpper := 0; + FillChar(Block, SizeOf(Block), 0); + K := 0; + + // Store 4x4 pixels and compute average, lower, and upper intensity levels + for I := 0 to 3 do + for J := 0 to 3 do + begin + Pixels[K] := PByteArray(SrcBits)[(Y shl 2 + I) * Width + X shl 2 + J]; + Inc(M, Pixels[K]); + Inc(K); + end; + + M := M div 16; + K := 0; + + // Now compute upper and lower levels, number of upper pixels, + // and update bit field (1 when pixel is above avg. level M) + for I := 0 to 15 do + begin + if Pixels[I] > M then + begin + Inc(MUpper, Pixels[I]); + Inc(K); + Block.BitField := Block.BitField or (1 shl I); + end + else + Inc(MLower, Pixels[I]); + end; + + // Scale levels and save them to block + if K > 0 then + Block.MUpper := ClampToByte(MUpper div K) + else + Block.MUpper := 0; + Block.MLower := ClampToByte(MLower div (16 - K)); + + // Finally save block to dest data + PBTCBlock(DestBits)^ := Block; + Inc(DestBits, SizeOf(Block)); + end; +end; + +procedure GetOneChannelBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos, + Width, Height, BytesPP, ChannelIdx: Integer); +var + X, Y, I: Integer; + Src: PByte; +begin + I := 0; + // 4x4 pixel block is filled with information about every pixel in the block, + // but only one channel value is stored in Alpha field + for Y := 0 to 3 do + for X := 0 to 3 do + begin + Src := @PByteArray(SrcBits)[(YPos * 4 + Y) * Width * BytesPP + + (XPos * 4 + X) * BytesPP + ChannelIdx]; + Block[I].Alpha := Src^; + Inc(I); + end; +end; + +procedure EncodeATI1N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer); +var + X, Y: Integer; + AlphaBlock: TDXTAlphaBlockInt; + Pixels: TPixelBlock; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + // Encode one channel + GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 1, 0); + GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); + GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, + PByteArray(@AlphaBlock.Alphas[2])); + PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; + Inc(DestBits, SizeOf(AlphaBlock)); + end; +end; + +procedure EncodeATI2N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer); +var + X, Y: Integer; + AlphaBlock: TDXTAlphaBlockInt; + Pixels: TPixelBlock; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + // Encode Red/X channel + GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelRed); + GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); + GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, + PByteArray(@AlphaBlock.Alphas[2])); + PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; + Inc(DestBits, SizeOf(AlphaBlock)); + // Encode Green/Y channel + GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelGreen); + GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]); + GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels, + PByteArray(@AlphaBlock.Alphas[2])); + PDXTAlphaBlockInt(DestBits)^ := AlphaBlock; + Inc(DestBits, SizeOf(AlphaBlock)); + end; +end; + +procedure EncodeBinary(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer); +var + Src: PByte absolute SrcBits; + Bitmap: PByteArray absolute DestBits; + X, Y, WidthBytes: Integer; + PixelThresholded, Threshold: Byte; +begin + Threshold := ClampToByte(GetOption(ImagingBinaryThreshold)); + WidthBytes := (Width + 7) div 8; + + for Y := 0 to Height - 1 do + for X := 0 to Width - 1 do + begin + if Src^ > Threshold then + PixelThresholded := 255 + else + PixelThresholded := 0; + + Bitmap[Y * WidthBytes + X div 8] := Bitmap[Y * WidthBytes + X div 8] or // OR current value of byte with following: + (PixelThresholded and 1) // To make 1 from 255, 0 remains 0 + shl (7 - (X mod 8)); // Put current bit to proper place in byte + + Inc(Src); + end; +end; + +procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: Integer); +var + X, Y, I, J, K: Integer; + Block: TBTCBlock; + Dest: PByte; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + Block := PBTCBlock(SrcBits)^; + Inc(SrcBits, SizeOf(Block)); + K := 0; + + // Just write MUpper when there is '1' in bit field and MLower + // when there is '0' + for I := 0 to 3 do + for J := 0 to 3 do + begin + Dest := @PByteArray(DestBits)[(Y shl 2 + I) * Width + X shl 2 + J]; + if Block.BitField and (1 shl K) <> 0 then + Dest^ := Block.MUpper + else + Dest^ := Block.MLower; + Inc(K); + end; + end; +end; + +procedure DecodeATI1N(SrcBits, DestBits: PByte; Width, Height: Integer); +var + X, Y, I, J: Integer; + AlphaBlock: TDXTAlphaBlockInt; + AMask: array[0..1] of UInt32; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + AlphaBlock := PDXTAlphaBlockInt(SrcBits)^; + Inc(SrcBits, SizeOf(AlphaBlock)); + // 6 bit alpha mask is copied into two long words for + // easier usage + AMask[0] := PUInt32(@AlphaBlock.Alphas[2])^ and $00FFFFFF; + AMask[1] := PUInt32(@AlphaBlock.Alphas[5])^ and $00FFFFFF; + // alpha interpolation between two endpoint alphas + GetInterpolatedAlphas(AlphaBlock); + + // we distribute the dxt block alphas + // across the 4x4 block of the destination image + for J := 0 to 3 do + for I := 0 to 3 do + begin + PByteArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := + AlphaBlock.Alphas[AMask[J shr 1] and 7]; + AMask[J shr 1] := AMask[J shr 1] shr 3; + end; + end; +end; + +procedure DecodeATI2N(SrcBits, DestBits: PByte; Width, Height: Integer); +var + X, Y, I, J: Integer; + Color: TColor32Rec; + AlphaBlock1, AlphaBlock2: TDXTAlphaBlockInt; + AMask1: array[0..1] of UInt32; + AMask2: array[0..1] of UInt32; +begin + for Y := 0 to Height div 4 - 1 do + for X := 0 to Width div 4 - 1 do + begin + // Read the first alpha block and get masks + AlphaBlock1 := PDXTAlphaBlockInt(SrcBits)^; + Inc(SrcBits, SizeOf(AlphaBlock1)); + AMask1[0] := PUInt32(@AlphaBlock1.Alphas[2])^ and $00FFFFFF; + AMask1[1] := PUInt32(@AlphaBlock1.Alphas[5])^ and $00FFFFFF; + // Read the secind alpha block and get masks + AlphaBlock2 := PDXTAlphaBlockInt(SrcBits)^; + Inc(SrcBits, SizeOf(AlphaBlock2)); + AMask2[0] := PUInt32(@AlphaBlock2.Alphas[2])^ and $00FFFFFF; + AMask2[1] := PUInt32(@AlphaBlock2.Alphas[5])^ and $00FFFFFF; + // alpha interpolation between two endpoint alphas + GetInterpolatedAlphas(AlphaBlock1); + GetInterpolatedAlphas(AlphaBlock2); + + Color.A := $FF; + Color.B := 0; + + // Distribute alpha block values across 4x4 pixel block, + // first alpha block represents Red channel, second is Green. + for J := 0 to 3 do + for I := 0 to 3 do + begin + Color.R := AlphaBlock1.Alphas[AMask1[J shr 1] and 7]; + Color.G := AlphaBlock2.Alphas[AMask2[J shr 1] and 7]; + PColor32RecArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := Color; + AMask1[J shr 1] := AMask1[J shr 1] shr 3; + AMask2[J shr 1] := AMask2[J shr 1] shr 3; + end; + end; +end; + +procedure DecodeBinary(SrcBits, DestBits: PByte; Width, Height: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF} +begin + Convert1To8(SrcBits, DestBits, Width, Height, (Width + 7) div 8, True); +end; + +procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer; + SpecialFormat: TImageFormat); +begin + case SpecialFormat of + ifDXT1: DecodeDXT1(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); + ifDXT3: DecodeDXT3(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); + ifDXT5: DecodeDXT5(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); + ifBTC: DecodeBTC (SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); + ifATI1N: DecodeATI1N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); + ifATI2N: DecodeATI2N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); + ifBinary: DecodeBinary(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height); + end; +end; + +procedure UnSpecialToSpecial(SrcBits: Pointer; const DestImage: TImageData; + SpecialFormat: TImageFormat); +begin + case SpecialFormat of + ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); + ifDXT3: EncodeDXT3(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); + ifDXT5: EncodeDXT5(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); + ifBTC: EncodeBTC (SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); + ifATI1N: EncodeATI1N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); + ifATI2N: EncodeATI2N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); + ifBinary: EncodeBinary(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); + end; +end; + +procedure ConvertSpecial(var Image: TImageData; + SrcInfo, DstInfo: PImageFormatInfo); +var + WorkImage: TImageData; + + procedure CheckSize(var Img: TImageData; Info: PImageFormatInfo); + var + Width, Height: LongInt; + begin + Width := Img.Width; + Height := Img.Height; + DstInfo.CheckDimensions(Info.Format, Width, Height); + ResizeImage(Img, Width, Height, rfNearest); + end; + +begin + if SrcInfo.IsSpecial and DstInfo.IsSpecial then + begin + // Convert source to nearest 'normal' format + InitImage(WorkImage); + NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage); + SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format); + FreeImage(Image); + // Make sure output of SpecialToUnSpecial is the same as input of + // UnSpecialToSpecial + if SrcInfo.SpecialNearestFormat <> DstInfo.SpecialNearestFormat then + ConvertImage(WorkImage, DstInfo.SpecialNearestFormat); + // Convert work image to dest special format + CheckSize(WorkImage, DstInfo); + NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image); + UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format); + FreeImage(WorkImage); + end + else if SrcInfo.IsSpecial and not DstInfo.IsSpecial then + begin + // Convert source to nearest 'normal' format + InitImage(WorkImage); + NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage); + SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format); + FreeImage(Image); + // Now convert to dest format + ConvertImage(WorkImage, DstInfo.Format); + Image := WorkImage; + end + else if not SrcInfo.IsSpecial and DstInfo.IsSpecial then + begin + // Convert source to nearest format + WorkImage := Image; + ConvertImage(WorkImage, DstInfo.SpecialNearestFormat); + // Now convert from nearest to dest + CheckSize(WorkImage, DstInfo); + InitImage(Image); + NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image); + UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format); + FreeImage(WorkImage); + end; +end; + +function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; +begin + if FInfos[Format] <> nil then + Result := Width * Height * FInfos[Format].BytesPerPixel + else + Result := 0; +end; + +procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt); +begin +end; + +function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; +begin + // DXT can be used only for images with dimensions that are + // multiples of four + CheckDXTDimensions(Format, Width, Height); + Result := Width * Height; + if Format in [ifDXT1, ifATI1N] then + Result := Result div 2; +end; + +procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt); +begin + // DXT image dimensions must be multiples of four + Width := (Width + 3) and not 3; // div 4 * 4; + Height := (Height + 3) and not 3; // div 4 * 4; +end; + +function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; +begin + // BTC can be used only for images with dimensions that are + // multiples of four + CheckDXTDimensions(Format, Width, Height); + Result := Width * Height div 4; // 2bits/pixel +end; + +function GetBCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; +begin + raise ENotImplemented.Create(); +end; + +procedure CheckBCDimensions(Format: TImageFormat; var Width, Height: LongInt); +begin + raise ENotImplemented.Create(); +end; + +function GetBinaryPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; +begin + // Binary images are aligned on BYTE boundary + Result := ((Width + 7) div 8) * Height; // 1bit/pixel +end; + +{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo } + +function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; +begin + Result.Color := PUInt32(Bits)^; +end; + +procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); +begin + PUInt32(Bits)^ := Color.Color; +end; + +function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; +begin + Result.A := PColor32Rec(Bits).A * OneDiv8Bit; + Result.R := PColor32Rec(Bits).R * OneDiv8Bit; + Result.G := PColor32Rec(Bits).G * OneDiv8Bit; + Result.B := PColor32Rec(Bits).B * OneDiv8Bit; +end; + +procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); +begin + PColor32Rec(Bits).A := ClampToByte(Round(Color.A * 255.0)); + PColor32Rec(Bits).R := ClampToByte(Round(Color.R * 255.0)); + PColor32Rec(Bits).G := ClampToByte(Round(Color.G * 255.0)); + PColor32Rec(Bits).B := ClampToByte(Round(Color.B * 255.0)); +end; + +function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; +begin + case Info.Format of + ifR8G8B8, ifX8R8G8B8: + begin + Result.A := $FF; + PColor24Rec(@Result)^ := PColor24Rec(Bits)^; + end; + ifGray8, ifA8Gray8: + begin + if Info.HasAlphaChannel then + Result.A := PWordRec(Bits).High + else + Result.A := $FF; + Result.R := PWordRec(Bits).Low; + Result.G := PWordRec(Bits).Low; + Result.B := PWordRec(Bits).Low; + end; + end; +end; + +procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); +begin + case Info.Format of + ifR8G8B8, ifX8R8G8B8: + begin + PColor24Rec(Bits)^ := PColor24Rec(@Color)^; + end; + ifGray8, ifA8Gray8: + begin + if Info.HasAlphaChannel then + PWordRec(Bits).High := Color.A; + PWordRec(Bits).Low := Round(GrayConv.R * Color.R + GrayConv.G * Color.G + + GrayConv.B * Color.B); + end; + end; +end; + +function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; +begin + case Info.Format of + ifR8G8B8, ifX8R8G8B8: + begin + Result.A := 1.0; + Result.R := PColor24Rec(Bits).R * OneDiv8Bit; + Result.G := PColor24Rec(Bits).G * OneDiv8Bit; + Result.B := PColor24Rec(Bits).B * OneDiv8Bit; + end; + ifGray8, ifA8Gray8: + begin + if Info.HasAlphaChannel then + Result.A := PWordRec(Bits).High * OneDiv8Bit + else + Result.A := 1.0; + Result.R := PWordRec(Bits).Low * OneDiv8Bit; + Result.G := PWordRec(Bits).Low * OneDiv8Bit; + Result.B := PWordRec(Bits).Low * OneDiv8Bit; + end; + end; +end; + +procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); +begin + case Info.Format of + ifR8G8B8, ifX8R8G8B8: + begin + PColor24Rec(Bits).R := ClampToByte(Round(Color.R * 255.0)); + PColor24Rec(Bits).G := ClampToByte(Round(Color.G * 255.0)); + PColor24Rec(Bits).B := ClampToByte(Round(Color.B * 255.0)); + end; + ifGray8, ifA8Gray8: + begin + if Info.HasAlphaChannel then + PWordRec(Bits).High := ClampToByte(Round(Color.A * 255.0)); + PWordRec(Bits).Low := ClampToByte(Round((GrayConv.R * Color.R + GrayConv.G * Color.G + + GrayConv.B * Color.B) * 255.0)); + end; + end; +end; + +function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; +begin + case Info.Format of + ifA32R32G32B32F, ifA32B32G32R32F: + begin + Result := PColorFPRec(Bits)^; + end; + ifR32G32B32F, ifB32G32R32F: + begin + Result.A := 1.0; + Result.Color96Rec := PColor96FPRec(Bits)^; + end; + ifR32F: + begin + Result.A := 1.0; + Result.R := PSingle(Bits)^; + Result.G := 0.0; + Result.B := 0.0; + end; + end; + if Info.IsRBSwapped then + SwapValues(Result.R, Result.B); +end; + +procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); +begin + case Info.Format of + ifA32R32G32B32F, ifA32B32G32R32F: + begin + PColorFPRec(Bits)^ := Color; + end; + ifR32G32B32F, ifB32G32R32F: + begin + PColor96FPRec(Bits)^ := Color.Color96Rec; + end; + ifR32F: + begin + PSingle(Bits)^ := Color.R; + end; + end; + if Info.IsRBSwapped then + SwapValues(PColor96FPRec(Bits).R, PColor96FPRec(Bits).B); +end; + +initialization + // Initialize default sampling filter function pointers and radii + SamplingFilterFunctions[sfNearest] := FilterNearest; + SamplingFilterFunctions[sfLinear] := FilterLinear; + SamplingFilterFunctions[sfCosine] := FilterCosine; + SamplingFilterFunctions[sfHermite] := FilterHermite; + SamplingFilterFunctions[sfQuadratic] := FilterQuadratic; + SamplingFilterFunctions[sfGaussian] := FilterGaussian; + SamplingFilterFunctions[sfSpline] := FilterSpline; + SamplingFilterFunctions[sfLanczos] := FilterLanczos; + SamplingFilterFunctions[sfMitchell] := FilterMitchell; + SamplingFilterFunctions[sfCatmullRom] := FilterCatmullRom; + SamplingFilterRadii[sfNearest] := 1.0; + SamplingFilterRadii[sfLinear] := 1.0; + SamplingFilterRadii[sfCosine] := 1.0; + SamplingFilterRadii[sfHermite] := 1.0; + SamplingFilterRadii[sfQuadratic] := 1.5; + SamplingFilterRadii[sfGaussian] := 1.25; + SamplingFilterRadii[sfSpline] := 2.0; + SamplingFilterRadii[sfLanczos] := 3.0; + SamplingFilterRadii[sfMitchell] := 2.0; + SamplingFilterRadii[sfCatmullRom] := 2.0; + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - nothing now + + -- 0.80 ------------------------------------------------------- + - Added PaletteIsGrayScale and Color32ToGray functions. + + -- 0.77 Changes/Bug Fixes ------------------------------------- + - NOT YET: Added support for Passthrough image data formats. + - Added ConvertToPixel32 helper function. + + -- 0.26.5 Changes/Bug Fixes ----------------------------------- + - Removed optimized codepath for few data formats from StretchResample + function. It was quite buggy and not so much faster anyway. + - Added PaletteHasAlpha function. + - Added support functions for ifBinary data format. + - Added optional pixel scaling to Convert1To8, Convert2To8, + abd Convert4To8 functions. + + -- 0.26.3 Changes/Bug Fixes ----------------------------------- + - Filtered resampling ~10% faster now. + - Fixed DXT3 alpha encoding. + - ifIndex8 format now has HasAlphaChannel=True. + + -- 0.25.0 Changes/Bug Fixes ----------------------------------- + - Made some resampling stuff public so that it can be used in canvas class. + - Added some color constructors. + - Added VisualizePalette helper function. + - Fixed ConvertSpecial, not very readable before and error when + converting special->special. + + -- 0.24.3 Changes/Bug Fixes ----------------------------------- + - Some refactorings a changes to DXT based formats. + - Added ifATI1N and ifATI2N image data formats support structures and functions. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Added ifBTC image format support structures and functions. + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - FillMipMapLevel now works well with indexed and special formats too. + - Moved Convert1To8 and Convert4To8 functions from ImagingBitmaps here + and created new Convert2To8 function. They are now used by more than one + file format loader. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - StretchResample now uses pixel get/set functions stored in + TImageFormatInfo so it is much faster for formats that override + them with optimized ones + - added pixel set/get functions optimized for various image formats + (to be stored in TImageFormatInfo) + - bug in ConvertSpecial caused problems when converting DXTC images + to bitmaps in ImagingComponents + - bug in StretchRect caused that it didn't work with ifR32F and + ifR16F formats + - removed leftover code in FillMipMapLevel which disabled + filtered resizing of images witch ChannelSize <> 8bits + - added half float converting functions and support for half based + image formats where needed + - added TranslatePixel and IsImageFormatValid functions + - fixed possible range overflows when converting from FP to integer images + - added pixel set/get functions: GetPixel32Generic, GetPixelFPGeneric, + SetPixel32Generic, SetPixelFPGeneric + - fixed occasional range overflows in StretchResample + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - added StretchNearest, StretchResample and some sampling functions + - added ChannelCount values to TImageFormatInfo constants + - added resolution validity check to GetDXTPixelsSize + + -- 0.15 Changes/Bug Fixes ----------------------------------- + - added RBSwapFormat values to some TImageFormatInfo definitions + - fixed bug in ConvertSpecial (causing DXT images to convert only to 32bit) + - added CopyPixel, ComparePixels helper functions + + -- 0.13 Changes/Bug Fixes ----------------------------------- + - replaced pixel format conversions for colors not to be + darkened when converting from low bit counts + - ReduceColorsMedianCut was updated to support creating one + optimal palette for more images and it is somewhat faster + now too + - there was ugly bug in DXTC dimensions checking +} + +end. + diff --git a/Imaging/ImagingGif.pas b/Imaging/ImagingGif.pas index 7fe42e9..9563ca8 100644 --- a/Imaging/ImagingGif.pas +++ b/Imaging/ImagingGif.pas @@ -1,1239 +1,1275 @@ -{ - $Id: ImagingGif.pas 157 2009-02-15 14:24:58Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains image format loader/saver for GIF images.} -unit ImagingGif; - -{$I ImagingOptions.inc} - -interface - -uses - SysUtils, Classes, Imaging, ImagingTypes, ImagingIO, ImagingUtility; - -type - { GIF (Graphics Interchange Format) loader/saver class. GIF was - (and is still used) popular format for storing images supporting - multiple images per file and single color transparency. - Pixel format is 8 bit indexed where each image frame can have - its own color palette. GIF uses lossless LZW compression - (patent expired few years ago). - Imaging can load and save all GIFs with all frames and supports - transparency. Imaging can load just raw ifIndex8 frames or - also animate them in ifA8R8G8B8 format. See ImagingGIFLoadAnimated option.} - TGIFFileFormat = class(TImageFileFormat) - private - FLoadAnimated: LongBool; - function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer; - procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle; - Width, Height: Integer; Interlaced: Boolean; Data: Pointer); - procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; - Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer); - protected - function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean): Boolean; override; - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); override; - public - constructor Create; override; - function TestFormat(Handle: TImagingHandle): Boolean; override; - published - property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated; - end; - -implementation - -const - SGIFFormatName = 'Graphics Interchange Format'; - SGIFMasks = '*.gif'; - GIFSupportedFormats: TImageFormats = [ifIndex8]; - GIFDefaultLoadAnimated = True; - -type - TGIFVersion = (gv87, gv89); - TDisposalMethod = (dmNoRemoval, dmLeave, dmRestoreBackground, - dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7); - -const - GIFSignature: TChar3 = 'GIF'; - GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a'); - - // Masks for accessing fields in PackedFields of TGIFHeader - GIFGlobalColorTable = $80; - GIFColorResolution = $70; - GIFColorTableSorted = $08; - GIFColorTableSize = $07; - - // Masks for accessing fields in PackedFields of TImageDescriptor - GIFLocalColorTable = $80; - GIFInterlaced = $40; - GIFLocalTableSorted = $20; - - // Block identifiers - GIFPlainText: Byte = $01; - GIFGraphicControlExtension: Byte = $F9; - GIFCommentExtension: Byte = $FE; - GIFApplicationExtension: Byte = $FF; - GIFImageDescriptor: Byte = Ord(','); - GIFExtensionIntroducer: Byte = Ord('!'); - GIFTrailer: Byte = Ord(';'); - GIFBlockTerminator: Byte = $00; - - // Masks for accessing fields in PackedFields of TGraphicControlExtension - GIFTransparent = $01; - GIFUserInput = $02; - GIFDisposalMethod = $1C; - -type - TGIFHeader = packed record - // File header part - Signature: TChar3; // Header Signature (always "GIF") - Version: TChar3; // GIF format version("87a" or "89a") - // Logical Screen Descriptor part - ScreenWidth: Word; // Width of Display Screen in Pixels - ScreenHeight: Word; // Height of Display Screen in Pixels - PackedFields: Byte; // Screen and color map information - BackgroundColorIndex: Byte; // Background color index (in global color table) - AspectRatio: Byte; // Pixel aspect ratio, ratio = (AspectRatio + 15) / 64 - end; - - TImageDescriptor = packed record - //Separator: Byte; // leave that out since we always read one bye ahead - Left: Word; // X position of image with respect to logical screen - Top: Word; // Y position - Width: Word; - Height: Word; - PackedFields: Byte; - end; - -const - // GIF extension labels - GIFExtTypeGraphic = $F9; - GIFExtTypePlainText = $01; - GIFExtTypeApplication = $FF; - GIFExtTypeComment = $FE; - -type - TGraphicControlExtension = packed record - BlockSize: Byte; - PackedFields: Byte; - DelayTime: Word; - TransparentColorIndex: Byte; - Terminator: Byte; - end; - -const - // Netscape sub block types - GIFAppLoopExtension = 1; - GIFAppBufferExtension = 2; - -type - TGIFIdentifierCode = array[0..7] of AnsiChar; - TGIFAuthenticationCode = array[0..2] of AnsiChar; - TGIFApplicationRec = packed record - Identifier: TGIFIdentifierCode; - Authentication: TGIFAuthenticationCode; - end; - -const - CodeTableSize = 4096; - HashTableSize = 17777; - -type - TReadContext = record - Inx: Integer; - Size: Integer; - Buf: array [0..255 + 4] of Byte; - CodeSize: Integer; - ReadMask: Integer; - end; - PReadContext = ^TReadContext; - - TWriteContext = record - Inx: Integer; - CodeSize: Integer; - Buf: array [0..255 + 4] of Byte; - end; - PWriteContext = ^TWriteContext; - - TOutputContext = record - W: Integer; - H: Integer; - X: Integer; - Y: Integer; - BitsPerPixel: Integer; - Pass: Integer; - Interlace: Boolean; - LineIdent: Integer; - Data: Pointer; - CurrLineData: Pointer; - end; - - TImageDict = record - Tail: Word; - Index: Word; - Col: Byte; - end; - PImageDict = ^TImageDict; - - PIntCodeTable = ^TIntCodeTable; - TIntCodeTable = array [0..CodeTableSize - 1] of Word; - - TDictTable = array [0..CodeTableSize - 1] of TImageDict; - PDictTable = ^TDictTable; - -resourcestring - SGIFDecodingError = 'Error when decoding GIF LZW data'; - -{ - TGIFFileFormat implementation -} - -constructor TGIFFileFormat.Create; -begin - inherited Create; - FName := SGIFFormatName; - FCanLoad := True; - FCanSave := True; - FIsMultiImageFormat := True; - FSupportedFormats := GIFSupportedFormats; - FLoadAnimated := GIFDefaultLoadAnimated; - - AddMasks(SGIFMasks); - RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated); -end; - -function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer; -begin - Result := Y; - case Pass of - 0, 1: - Inc(Result, 8); - 2: - Inc(Result, 4); - 3: - Inc(Result, 2); - end; - if Result >= Height then - begin - if Pass = 0 then - begin - Pass := 1; - Result := 4; - if Result < Height then - Exit; - end; - if Pass = 1 then - begin - Pass := 2; - Result := 2; - if Result < Height then - Exit; - end; - if Pass = 2 then - begin - Pass := 3; - Result := 1; - end; - end; -end; - -{ GIF LZW decompresion code is from JVCL JvGIF.pas unit.} -procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer; - Interlaced: Boolean; Data: Pointer); -var - MinCodeSize: Byte; - MaxCode, BitMask, InitCodeSize: Integer; - ClearCode, EndingCode, FirstFreeCode, FreeCode: Word; - I, OutCount, Code: Integer; - CurCode, OldCode, InCode, FinalChar: Word; - Prefix, Suffix, OutCode: PIntCodeTable; - ReadCtxt: TReadContext; - OutCtxt: TOutputContext; - TableFull: Boolean; - - function ReadCode(var Context: TReadContext): Integer; - var - RawCode: Integer; - ByteIndex: Integer; - Bytes: Byte; - BytesToLose: Integer; - begin - while (Context.Inx + Context.CodeSize > Context.Size) and - (Stream.Position < Stream.Size) do - begin - // Not enough bits in buffer - refill it - Not very efficient, but infrequently called - BytesToLose := Context.Inx shr 3; - // Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes - Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3); - Context.Inx := Context.Inx and 7; - Context.Size := Context.Size - (BytesToLose shl 3); - Stream.Read(Bytes, 1); - if Bytes > 0 then - Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes); - Context.Size := Context.Size + (Bytes shl 3); - end; - ByteIndex := Context.Inx shr 3; - RawCode := Context.Buf[Word(ByteIndex)] + - (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8); - if Context.CodeSize > 8 then - RawCode := RawCode + (LongInt(Context.Buf[ByteIndex + 2]) shl 16); - RawCode := RawCode shr (Context.Inx and 7); - Context.Inx := Context.Inx + Byte(Context.CodeSize); - Result := RawCode and Context.ReadMask; - end; - - procedure Output(Value: Byte; var Context: TOutputContext); - var - P: PByte; - begin - if Context.Y >= Context.H then - Exit; - - // Only ifIndex8 supported - P := @PByteArray(Context.CurrLineData)[Context.X]; - P^ := Value; - - {case Context.BitsPerPixel of - 1: - begin - P := @PByteArray(Context.CurrLineData)[Context.X shr 3]; - if (Context.X and $07) <> 0 then - P^ := P^ or Word(Value shl (7 - (Word(Context.X and 7)))) - else - P^ := Byte(Value shl 7); - end; - 4: - begin - P := @PByteArray(Context.CurrLineData)[Context.X shr 1]; - if (Context.X and 1) <> 0 then - P^ := P^ or Value - else - P^ := Byte(Value shl 4); - end; - 8: - begin - P := @PByteArray(Context.CurrLineData)[Context.X]; - P^ := Value; - end; - end;} - Inc(Context.X); - - if Context.X < Context.W then - Exit; - Context.X := 0; - if Context.Interlace then - Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass) - else - Inc(Context.Y); - - Context.CurrLineData := @PByteArray(Context.Data)[Context.Y * Context.LineIdent]; - end; - -begin - OutCount := 0; - OldCode := 0; - FinalChar := 0; - TableFull := False; - GetMem(Prefix, SizeOf(TIntCodeTable)); - GetMem(Suffix, SizeOf(TIntCodeTable)); - GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word)); - try - Stream.Read(MinCodeSize, 1); - if (MinCodeSize < 2) or (MinCodeSize > 9) then - RaiseImaging(SGIFDecodingError, []); - // Initial read context - ReadCtxt.Inx := 0; - ReadCtxt.Size := 0; - ReadCtxt.CodeSize := MinCodeSize + 1; - ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1; - // Initialise pixel-output context - OutCtxt.X := 0; - OutCtxt.Y := 0; - OutCtxt.Pass := 0; - OutCtxt.W := Width; - OutCtxt.H := Height; - OutCtxt.BitsPerPixel := MinCodeSize; - OutCtxt.Interlace := Interlaced; - OutCtxt.LineIdent := Width; - OutCtxt.Data := Data; - OutCtxt.CurrLineData := Data; - BitMask := (1 shl OutCtxt.BitsPerPixel) - 1; - // 2 ^ MinCodeSize accounts for all colours in file - ClearCode := 1 shl MinCodeSize; - EndingCode := ClearCode + 1; - FreeCode := ClearCode + 2; - FirstFreeCode := FreeCode; - // 2^ (MinCodeSize + 1) includes clear and eoi Code and space too - InitCodeSize := ReadCtxt.CodeSize; - MaxCode := 1 shl ReadCtxt.CodeSize; - Code := ReadCode(ReadCtxt); - while (Code <> EndingCode) and (Code <> $FFFF) and - (OutCtxt.Y < OutCtxt.H) do - begin - if Code = ClearCode then - begin - ReadCtxt.CodeSize := InitCodeSize; - MaxCode := 1 shl ReadCtxt.CodeSize; - ReadCtxt.ReadMask := MaxCode - 1; - FreeCode := FirstFreeCode; - Code := ReadCode(ReadCtxt); - CurCode := Code; - OldCode := Code; - if Code = $FFFF then - Break; - FinalChar := (CurCode and BitMask); - Output(Byte(FinalChar), OutCtxt); - TableFull := False; - end - else - begin - CurCode := Code; - InCode := Code; - if CurCode >= FreeCode then - begin - CurCode := OldCode; - OutCode^[OutCount] := FinalChar; - Inc(OutCount); - end; - while CurCode > BitMask do - begin - if OutCount > CodeTableSize then - RaiseImaging(SGIFDecodingError, []); - OutCode^[OutCount] := Suffix^[CurCode]; - Inc(OutCount); - CurCode := Prefix^[CurCode]; - end; - - FinalChar := CurCode and BitMask; - OutCode^[OutCount] := FinalChar; - Inc(OutCount); - for I := OutCount - 1 downto 0 do - Output(Byte(OutCode^[I]), OutCtxt); - OutCount := 0; - // Update dictionary - if not TableFull then - begin - Prefix^[FreeCode] := OldCode; - Suffix^[FreeCode] := FinalChar; - // Advance to next free slot - Inc(FreeCode); - if FreeCode >= MaxCode then - begin - if ReadCtxt.CodeSize < 12 then - begin - Inc(ReadCtxt.CodeSize); - MaxCode := MaxCode shl 1; - ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1; - end - else - TableFull := True; - end; - end; - OldCode := InCode; - end; - Code := ReadCode(ReadCtxt); - end; - if Code = $FFFF then - RaiseImaging(SGIFDecodingError, []); - finally - FreeMem(Prefix); - FreeMem(OutCode); - FreeMem(Suffix); - end; -end; - -{ GIF LZW compresion code is from JVCL JvGIF.pas unit.} -procedure TGIFFileFormat.LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer; - Interlaced: Boolean; Data: Pointer); -var - LineIdent: Integer; - MinCodeSize, Col: Byte; - InitCodeSize, X, Y: Integer; - Pass: Integer; - MaxCode: Integer; { 1 shl CodeSize } - ClearCode, EndingCode, LastCode, Tail: Integer; - I, HashValue: Integer; - LenString: Word; - Dict: PDictTable; - HashTable: TList; - PData: PByte; - WriteCtxt: TWriteContext; - - function InitHash(P: Integer): Integer; - begin - Result := (P + 3) * 301; - end; - - procedure WriteCode(Code: Integer; var Context: TWriteContext); - var - BufIndex: Integer; - Bytes: Byte; - begin - BufIndex := Context.Inx shr 3; - Code := Code shl (Context.Inx and 7); - Context.Buf[BufIndex] := Context.Buf[BufIndex] or Byte(Code); - Context.Buf[BufIndex + 1] := Byte(Code shr 8); - Context.Buf[BufIndex + 2] := Byte(Code shr 16); - Context.Inx := Context.Inx + Context.CodeSize; - if Context.Inx >= 255 * 8 then - begin - // Flush out full buffer - Bytes := 255; - IO.Write(Handle, @Bytes, 1); - IO.Write(Handle, @Context.Buf, Bytes); - Move(Context.Buf[255], Context.Buf[0], 2); - FillChar(Context.Buf[2], 255, 0); - Context.Inx := Context.Inx - (255 * 8); - end; - end; - - procedure FlushCode(var Context: TWriteContext); - var - Bytes: Byte; - begin - Bytes := (Context.Inx + 7) shr 3; - if Bytes > 0 then - begin - IO.Write(Handle, @Bytes, 1); - IO.Write(Handle, @Context.Buf, Bytes); - end; - // Data block terminator - a block of zero Size - Bytes := 0; - IO.Write(Handle, @Bytes, 1); - end; - -begin - LineIdent := Width; - Tail := 0; - HashValue := 0; - Col := 0; - HashTable := TList.Create; - GetMem(Dict, SizeOf(TDictTable)); - try - for I := 0 to HashTableSize - 1 do - HashTable.Add(nil); - - // Initialise encoder variables - InitCodeSize := BitCount + 1; - if InitCodeSize = 2 then - Inc(InitCodeSize); - MinCodeSize := InitCodeSize - 1; - IO.Write(Handle, @MinCodeSize, 1); - ClearCode := 1 shl MinCodeSize; - EndingCode := ClearCode + 1; - LastCode := EndingCode; - MaxCode := 1 shl InitCodeSize; - LenString := 0; - // Setup write context - WriteCtxt.Inx := 0; - WriteCtxt.CodeSize := InitCodeSize; - FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0); - WriteCode(ClearCode, WriteCtxt); - Y := 0; - Pass := 0; - - while Y < Height do - begin - PData := @PByteArray(Data)[Y * LineIdent]; - for X := 0 to Width - 1 do - begin - // Only ifIndex8 support - case BitCount of - 8: - begin - Col := PData^; - PData := @PByteArray(PData)[1]; - end; - {4: - begin - if X and 1 <> 0 then - begin - Col := PData^ and $0F; - PData := @PByteArray(PData)[1]; - end - else - Col := PData^ shr 4; - end; - 1: - begin - if X and 7 = 7 then - begin - Col := PData^ and 1; - PData := @PByteArray(PData)[1]; - end - else - Col := (PData^ shr (7 - (X and $07))) and $01; - end;} - end; - Inc(LenString); - if LenString = 1 then - begin - Tail := Col; - HashValue := InitHash(Col); - end - else - begin - HashValue := HashValue * (Col + LenString + 4); - I := HashValue mod HashTableSize; - HashValue := HashValue mod HashTableSize; - while (HashTable[I] <> nil) and - ((PImageDict(HashTable[I])^.Tail <> Tail) or - (PImageDict(HashTable[I])^.Col <> Col)) do - begin - Inc(I); - if I >= HashTableSize then - I := 0; - end; - if HashTable[I] <> nil then // Found in the strings table - Tail := PImageDict(HashTable[I])^.Index - else - begin - // Not found - WriteCode(Tail, WriteCtxt); - Inc(LastCode); - HashTable[I] := @Dict^[LastCode]; - PImageDict(HashTable[I])^.Index := LastCode; - PImageDict(HashTable[I])^.Tail := Tail; - PImageDict(HashTable[I])^.Col := Col; - Tail := Col; - HashValue := InitHash(Col); - LenString := 1; - if LastCode >= MaxCode then - begin - // Next Code will be written longer - MaxCode := MaxCode shl 1; - Inc(WriteCtxt.CodeSize); - end - else - if LastCode >= CodeTableSize - 2 then - begin - // Reset tables - WriteCode(Tail, WriteCtxt); - WriteCode(ClearCode, WriteCtxt); - LenString := 0; - LastCode := EndingCode; - WriteCtxt.CodeSize := InitCodeSize; - MaxCode := 1 shl InitCodeSize; - for I := 0 to HashTableSize - 1 do - HashTable[I] := nil; - end; - end; - end; - end; - if Interlaced then - Y := InterlaceStep(Y, Height, Pass) - else - Inc(Y); - end; - WriteCode(Tail, WriteCtxt); - WriteCode(EndingCode, WriteCtxt); - FlushCode(WriteCtxt); - finally - HashTable.Free; - FreeMem(Dict); - end; -end; - -function TGIFFileFormat.LoadData(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -type - TFrameInfo = record - Left, Top: Integer; - Width, Height: Integer; - Disposal: TDisposalMethod; - HasTransparency: Boolean; - HasLocalPal: Boolean; - TransIndex: Integer; - BackIndex: Integer; - end; -var - Header: TGIFHeader; - HasGlobalPal: Boolean; - GlobalPalLength: Integer; - GlobalPal: TPalette32Size256; - ScreenWidth, ScreenHeight, I, CachedIndex: Integer; - BlockID: Byte; - HasGraphicExt: Boolean; - GraphicExt: TGraphicControlExtension; - FrameInfos: array of TFrameInfo; - AppRead: Boolean; - CachedFrame: TImageData; - AnimFrames: TDynImageDataArray; - - function ReadBlockID: Byte; - begin - Result := GIFTrailer; - if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then - Result := GIFTrailer; - end; - - procedure ReadExtensions; - var - BlockSize, BlockType, ExtType: Byte; - AppRec: TGIFApplicationRec; - LoopCount: SmallInt; - - procedure SkipBytes; - begin - with GetIO do - repeat - // Read block sizes and skip them - Read(Handle, @BlockSize, SizeOf(BlockSize)); - Seek(Handle, BlockSize, smFromCurrent); - until BlockSize = 0; - end; - - begin - HasGraphicExt := False; - AppRead := False; - - // Read extensions until image descriptor is found. Only graphic extension - // is stored now (for transparency), others are skipped. - while BlockID = GIFExtensionIntroducer do - with GetIO do - begin - Read(Handle, @ExtType, SizeOf(ExtType)); - - while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do - begin - if ExtType = GIFGraphicControlExtension then - begin - HasGraphicExt := True; - Read(Handle, @GraphicExt, SizeOf(GraphicExt)); - end - else if (ExtType = GIFApplicationExtension) and not AppRead then - begin - Read(Handle, @BlockSize, SizeOf(BlockSize)); - if BlockSize >= SizeOf(AppRec) then - begin - Read(Handle, @AppRec, SizeOf(AppRec)); - if (AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0') then - begin - Read(Handle, @BlockSize, SizeOf(BlockSize)); - while BlockSize <> 0 do - begin - BlockType := ReadBlockID; - Dec(BlockSize); - - case BlockType of - GIFAppLoopExtension: - if (BlockSize >= SizeOf(LoopCount)) then - begin - // Read loop count - Read(Handle, @LoopCount, SizeOf(LoopCount)); - Dec(BlockSize, SizeOf(LoopCount)); - end; - GIFAppBufferExtension: - begin - Dec(BlockSize, SizeOf(Word)); - Seek(Handle, SizeOf(Word), smFromCurrent); - end; - end; - end; - SkipBytes; - AppRead := True; - end - else - begin - // Revert all bytes reading - Seek(Handle, - SizeOf(AppRec) - SizeOf(BlockSize), smFromCurrent); - SkipBytes; - end; - end - else - begin - Seek(Handle, - BlockSize - SizeOf(BlockSize), smFromCurrent); - SkipBytes; - end; - end - else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then - repeat - // Read block sizes and skip them - Read(Handle, @BlockSize, SizeOf(BlockSize)); - Seek(Handle, BlockSize, smFromCurrent); - until BlockSize = 0; - - // Read ID of following block - BlockID := ReadBlockID; - ExtType := BlockID; - end - end; - end; - - procedure CopyLZWData(Dest: TStream); - var - CodeSize, BlockSize: Byte; - InputSize: Integer; - Buff: array[Byte] of Byte; - begin - InputSize := ImagingIO.GetInputSize(GetIO, Handle); - // Copy codesize to stream - GetIO.Read(Handle, @CodeSize, 1); - Dest.Write(CodeSize, 1); - repeat - // Read and write data blocks, last is block term value of 0 - GetIO.Read(Handle, @BlockSize, 1); - Dest.Write(BlockSize, 1); - if BlockSize > 0 then - begin - GetIO.Read(Handle, @Buff[0], BlockSize); - Dest.Write(Buff[0], BlockSize); - end; - until (BlockSize = 0) or (GetIO.Tell(Handle) >= InputSize); - end; - - procedure ReadFrame; - var - ImageDesc: TImageDescriptor; - Interlaced: Boolean; - I, Idx, LocalPalLength: Integer; - LocalPal: TPalette32Size256; - LZWStream: TMemoryStream; - - procedure RemoveBadFrame; - begin - FreeImage(Images[Idx]); - SetLength(Images, Length(Images) - 1); - end; - - begin - Idx := Length(Images); - SetLength(Images, Idx + 1); - SetLength(FrameInfos, Idx + 1); - FillChar(LocalPal, SizeOf(LocalPal), 0); - - with GetIO do - begin - // Read and parse image descriptor - Read(Handle, @ImageDesc, SizeOf(ImageDesc)); - FrameInfos[Idx].HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable; - Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced; - LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize; - LocalPalLength := 1 shl (LocalPalLength + 1); // Total pal length is 2^(n+1) - - // From Mozilla source - if (ImageDesc.Width = 0) or (ImageDesc.Width > Header.ScreenWidth) then - ImageDesc.Width := Header.ScreenWidth; - if (ImageDesc.Height = 0) or (ImageDesc.Height > Header.ScreenHeight) then - ImageDesc.Height := Header.ScreenHeight; - - FrameInfos[Idx].Left := ImageDesc.Left; - FrameInfos[Idx].Top := ImageDesc.Top; - FrameInfos[Idx].Width := ImageDesc.Width; - FrameInfos[Idx].Height := ImageDesc.Height; - FrameInfos[Idx].BackIndex := Header.BackgroundColorIndex; - - // Create new image for this frame which would be later pasted onto logical screen - NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]); - - // Load local palette if there is any - if FrameInfos[Idx].HasLocalPal then - for I := 0 to LocalPalLength - 1 do - begin - LocalPal[I].A := 255; - Read(Handle, @LocalPal[I].R, SizeOf(LocalPal[I].R)); - Read(Handle, @LocalPal[I].G, SizeOf(LocalPal[I].G)); - Read(Handle, @LocalPal[I].B, SizeOf(LocalPal[I].B)); - end; - - // Use local pal if present or global pal if present or create - // default pal if neither of them is present - if FrameInfos[Idx].HasLocalPal then - Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal)) - else if HasGlobalPal then - Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal)) - else - FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2); - - if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then - begin - // Resize the screen if needed to fit the frame - ScreenWidth := Max(ScreenWidth, ImageDesc.Width + ImageDesc.Left); - ScreenHeight := Max(ScreenHeight, ImageDesc.Height + ImageDesc.Top); - end - else - begin - // Remove frame outside logical screen - RemoveBadFrame; - Exit; - end; - - // If Grahic Control Extension is present make use of it - if HasGraphicExt then - begin - FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent; - FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2); - if FrameInfos[Idx].HasTransparency then - begin - FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex; - Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0; - end; - end - else - FrameInfos[Idx].HasTransparency := False; - - LZWStream := TMemoryStream.Create; - try - try - // Copy LZW data to temp stream, needed for correct decompression - CopyLZWData(LZWStream); - LZWStream.Position := 0; - // Data decompression finally - LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits); - except - RemoveBadFrame; - Exit; - end; - finally - LZWStream.Free; - end; - end; - end; - - procedure CopyFrameTransparent32(const Image, Frame: TImageData; Left, Top: Integer); - var - X, Y: Integer; - Src: PByte; - Dst: PColor32; - begin - Src := Frame.Bits; - - // Copy all pixels from frame to log screen but ignore the transparent ones - for Y := 0 to Frame.Height - 1 do - begin - Dst := @PColor32RecArray(Image.Bits)[(Top + Y) * Image.Width + Left]; - for X := 0 to Frame.Width - 1 do - begin - if (Frame.Palette[Src^].A <> 0) then - Dst^ := Frame.Palette[Src^].Color; - Inc(Src); - Inc(Dst); - end; - end; - end; - - procedure AnimateFrame(Index: Integer; var AnimFrame: TImageData); - var - I, First, Last: Integer; - UseCache: Boolean; - BGColor: TColor32; - begin - // We may need to use raw frame 0 to n to correctly animate n-th frame - Last := Index; - First := Max(0, Last); - // See if we can use last animate frame as a basis for this one - // (so we don't have to use previous raw frames). - UseCache := TestImage(CachedFrame) and (CachedIndex = Index - 1) and (CachedIndex >= 0) and - (FrameInfos[CachedIndex].Disposal <> dmRestorePrevious); - - // Reuse or release cache - if UseCache then - CloneImage(CachedFrame, AnimFrame) - else - FreeImage(CachedFrame); - - // Default color for clearing of the screen - BGColor := Images[Index].Palette[FrameInfos[Index].BackIndex].Color; - - // Now prepare logical screen for drawing of raw frame at Index. - // We may need to use all previous raw frames to get the screen - // to proper state (according to their disposal methods). - - if not UseCache then - begin - if FrameInfos[Index].HasTransparency then - BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color; - // Clear whole screen - FillMemoryLongWord(AnimFrame.Bits, AnimFrame.Size, BGColor); - - // Try to maximize First so we don't have to use all 0 to n raw frames - while First > 0 do - begin - if (ScreenWidth = Images[First].Width) and (ScreenHeight = Images[First].Height) then - begin - if (FrameInfos[First].Disposal = dmRestoreBackground) and (First < Last) then - Break; - end; - Dec(First); - end; - - for I := First to Last - 1 do - begin - case FrameInfos[I].Disposal of - dmNoRemoval, dmLeave: - begin - // Copy previous raw frame onto screen - CopyFrameTransparent32(AnimFrame, Images[I], FrameInfos[I].Left, FrameInfos[I].Top); - end; - dmRestoreBackground: - if (I > First) then - begin - // Restore background color - FillRect(AnimFrame, FrameInfos[I].Left, FrameInfos[I].Top, - FrameInfos[I].Width, FrameInfos[I].Height, @BGColor); - end; - dmRestorePrevious: ; // Do nothing - previous state is already on screen - end; - end; - end - else if FrameInfos[CachedIndex].Disposal = dmRestoreBackground then - begin - // We have our cached result but also need to restore - // background in a place of cached frame - if FrameInfos[CachedIndex].HasTransparency then - BGColor := Images[CachedIndex].Palette[FrameInfos[CachedIndex].TransIndex].Color; - FillRect(AnimFrame, FrameInfos[CachedIndex].Left, FrameInfos[CachedIndex].Top, - FrameInfos[CachedIndex].Width, FrameInfos[CachedIndex].Height, @BGColor); - end; - - // Copy current raw frame to prepared screen - CopyFrameTransparent32(AnimFrame, Images[Index], FrameInfos[Index].Left, FrameInfos[Index].Top); - - // Cache animated result - CloneImage(AnimFrame, CachedFrame); - CachedIndex := Index; - end; - -begin - AppRead := False; - - SetLength(Images, 0); - FillChar(GlobalPal, SizeOf(GlobalPal), 0); - - with GetIO do - begin - // Read GIF header - Read(Handle, @Header, SizeOf(Header)); - ScreenWidth := Header.ScreenWidth; - ScreenHeight := Header.ScreenHeight; - HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7 - GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2 - GlobalPalLength := 1 shl (GlobalPalLength + 1); // Total pal length is 2^(n+1) - - // Read global palette from file if present - if HasGlobalPal then - begin - for I := 0 to GlobalPalLength - 1 do - begin - GlobalPal[I].A := 255; - Read(Handle, @GlobalPal[I].R, SizeOf(GlobalPal[I].R)); - Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G)); - Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B)); - end; - end; - - // Read ID of the first block - BlockID := ReadBlockID; - - // Now read all data blocks in the file until file trailer is reached - while BlockID <> GIFTrailer do - begin - // Read blocks until we find the one of known type - while not (BlockID in [GIFTrailer, GIFExtensionIntroducer, GIFImageDescriptor]) do - BlockID := ReadBlockID; - // Read supported and skip unsupported extensions - ReadExtensions; - // If image frame is found read it - if BlockID = GIFImageDescriptor then - ReadFrame; - // Read next block's ID - BlockID := ReadBlockID; - // If block ID is unknown set it to end-of-GIF marker - if not (BlockID in [GIFExtensionIntroducer, GIFTrailer, GIFImageDescriptor]) then - BlockID := GIFTrailer; - end; - - if FLoadAnimated then - begin - // Aniated frames will be stored in AnimFrames - SetLength(AnimFrames, Length(Images)); - InitImage(CachedFrame); - CachedIndex := -1; - - for I := 0 to High(Images) do - begin - // Create new logical screen - NewImage(ScreenWidth, ScreenHeight, ifA8R8G8B8, AnimFrames[I]); - // Animate frames to current log screen - AnimateFrame(I, AnimFrames[I]); - end; - - // Now release raw 8bit frames and put animated 32bit ones - // to output array - FreeImage(CachedFrame); - for I := 0 to High(AnimFrames) do - begin - FreeImage(Images[I]); - Images[I] := AnimFrames[I]; - end; - end; - - Result := True; - end; -end; - -function TGIFFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: Integer): Boolean; -var - Header: TGIFHeader; - ImageDesc: TImageDescriptor; - ImageToSave: TImageData; - MustBeFreed: Boolean; - I, J: Integer; - GraphicExt: TGraphicControlExtension; - - procedure FindMaxDimensions(var MaxWidth, MaxHeight: Word); - var - I: Integer; - begin - MaxWidth := Images[FFirstIdx].Width; - MaxHeight := Images[FFirstIdx].Height; - - for I := FFirstIdx + 1 to FLastIdx do - begin - MaxWidth := Iff(Images[I].Width > MaxWidth, Images[I].Width, MaxWidth); - MaxHeight := Iff(Images[I].Height > MaxWidth, Images[I].Height, MaxHeight); - end; - end; - -begin - // Fill header with data, select size of largest image in array as - // logical screen size - FillChar(Header, Sizeof(Header), 0); - Header.Signature := GIFSignature; - Header.Version := GIFVersions[gv89]; - FindMaxDimensions(Header.ScreenWidth, Header.ScreenHeight); - Header.PackedFields := GIFColorResolution; // Color resolution is 256 - GetIO.Write(Handle, @Header, SizeOf(Header)); - - // Prepare default GC extension with delay - FillChar(GraphicExt, Sizeof(GraphicExt), 0); - GraphicExt.DelayTime := 65; - GraphicExt.BlockSize := 4; - - for I := FFirstIdx to FLastIdx do - begin - if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then - with GetIO, ImageToSave do - try - // Write Graphic Control Extension with default delay - Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer)); - Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension)); - Write(Handle, @GraphicExt, SizeOf(GraphicExt)); - // Write frame marker and fill and write image descriptor for this frame - Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor)); - FillChar(ImageDesc, Sizeof(ImageDesc), 0); - ImageDesc.Width := Width; - ImageDesc.Height := Height; - ImageDesc.PackedFields := GIFLocalColorTable or GIFColorTableSize; // Use lccal color table with 256 entries - Write(Handle, @ImageDesc, SizeOf(ImageDesc)); - - // Write local color table for each frame - for J := 0 to 255 do - begin - Write(Handle, @Palette[J].R, SizeOf(Palette[J].R)); - Write(Handle, @Palette[J].G, SizeOf(Palette[J].G)); - Write(Handle, @Palette[J].B, SizeOf(Palette[J].B)); - end; - - // Fonally compress image data - LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits); - - finally - if MustBeFreed then - FreeImage(ImageToSave); - end; - end; - - GetIO.Write(Handle, @GIFTrailer, SizeOf(GIFTrailer)); - Result := True; -end; - -procedure TGIFFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -begin - ConvertImage(Image, ifIndex8); -end; - -function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean; -var - Header: TGIFHeader; - ReadCount: LongInt; -begin - Result := False; - if Handle <> nil then - begin - ReadCount := GetIO.Read(Handle, @Header, SizeOf(Header)); - GetIO.Seek(Handle, -ReadCount, smFromCurrent); - Result := (ReadCount >= SizeOf(Header)) and - (Header.Signature = GIFSignature) and - ((Header.Version = GIFVersions[gv87]) or (Header.Version = GIFVersions[gv89])); - end; -end; - -initialization - RegisterImageFileFormat(TGIFFileFormat); - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.26.3 Changes/Bug Fixes --------------------------------- - - Fixed bug - loading of GIF with NETSCAPE app extensions - failed with Delphi 2009. - - -- 0.26.1 Changes/Bug Fixes --------------------------------- - - GIF loading and animation mostly rewritten, based on - modification by Sergey Galezdinov (ExtraGIF in Extras/Contrib). - - -- 0.25.0 Changes/Bug Fixes --------------------------------- - - Fixed loading of some rare GIFs, problems with LZW - decompression. - - -- 0.24.3 Changes/Bug Fixes --------------------------------- - - Better solution to transparency for some GIFs. Background not - transparent by default. - - -- 0.24.1 Changes/Bug Fixes --------------------------------- - - Made backround color transparent by default (alpha = 0). - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Fixed other loading bugs (local pal size, transparency). - - Added GIF saving. - - Fixed bug when loading multiframe GIFs and implemented few animation - features (disposal methods, ...). - - Loading of GIFs working. - - Unit created with initial stuff! -} - -end. +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains image format loader/saver for GIF images.} +unit ImagingGif; + +{$I ImagingOptions.inc} + +interface + +uses + SysUtils, Classes, Imaging, ImagingTypes, ImagingIO, ImagingUtility; + +type + { GIF (Graphics Interchange Format) loader/saver class. GIF was + (and is still used) popular format for storing images supporting + multiple images per file and single color transparency. + Pixel format is 8 bit indexed where each image frame can have + its own color palette. GIF uses lossless LZW compression + (patent expired few years ago). + Imaging can load and save all GIFs with all frames and supports + transparency. Imaging can load just raw ifIndex8 frames or + also animate them in ifA8R8G8B8 format. See ImagingGIFLoadAnimated option.} + TGIFFileFormat = class(TImageFileFormat) + private + FLoadAnimated: LongBool; + function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer; + procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle; + Width, Height: Integer; Interlaced: Boolean; Data: Pointer); + procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; + Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer); + protected + procedure Define; override; + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean): Boolean; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + public + function TestFormat(Handle: TImagingHandle): Boolean; override; + published + property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated; + end; + +implementation + +const + SGIFFormatName = 'Graphics Interchange Format'; + SGIFMasks = '*.gif'; + GIFSupportedFormats: TImageFormats = [ifIndex8]; + GIFDefaultLoadAnimated = True; + +type + TGIFVersion = (gv87, gv89); + TDisposalMethod = (dmNoRemoval, dmLeave, dmRestoreBackground, + dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7); + +const + GIFSignature: TChar3 = 'GIF'; + GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a'); + GIFDefaultDelay = 65; + + // Masks for accessing fields in PackedFields of TGIFHeader + GIFGlobalColorTable = $80; + GIFColorResolution = $70; + GIFColorTableSorted = $08; + GIFColorTableSize = $07; + + // Masks for accessing fields in PackedFields of TImageDescriptor + GIFLocalColorTable = $80; + GIFInterlaced = $40; + GIFLocalTableSorted = $20; + + // Block identifiers + GIFPlainText: Byte = $01; + GIFGraphicControlExtension: Byte = $F9; + GIFCommentExtension: Byte = $FE; + GIFApplicationExtension: Byte = $FF; + GIFImageDescriptor: Byte = Ord(','); + GIFExtensionIntroducer: Byte = Ord('!'); + GIFTrailer: Byte = Ord(';'); + GIFBlockTerminator: Byte = $00; + + // Masks for accessing fields in PackedFields of TGraphicControlExtension + GIFTransparent = $01; + GIFUserInput = $02; + GIFDisposalMethod = $1C; + +const + // Netscape sub block types + GIFAppLoopExtension = 1; + GIFAppBufferExtension = 2; + +type + TGIFHeader = packed record + // File header part + Signature: TChar3; // Header Signature (always "GIF") + Version: TChar3; // GIF format version("87a" or "89a") + // Logical Screen Descriptor part + ScreenWidth: Word; // Width of Display Screen in Pixels + ScreenHeight: Word; // Height of Display Screen in Pixels + PackedFields: Byte; // Screen and color map information + BackgroundColorIndex: Byte; // Background color index (in global color table) + AspectRatio: Byte; // Pixel aspect ratio, ratio = (AspectRatio + 15) / 64 + end; + + TImageDescriptor = packed record + //Separator: Byte; // leave that out since we always read one bye ahead + Left: Word; // X position of image with respect to logical screen + Top: Word; // Y position + Width: Word; + Height: Word; + PackedFields: Byte; + end; + +const + // GIF extension labels + GIFExtTypeGraphic = $F9; + GIFExtTypePlainText = $01; + GIFExtTypeApplication = $FF; + GIFExtTypeComment = $FE; + +type + TGraphicControlExtension = packed record + BlockSize: Byte; + PackedFields: Byte; + DelayTime: Word; + TransparentColorIndex: Byte; + Terminator: Byte; + end; + +type + TGIFIdentifierCode = array[0..7] of AnsiChar; + TGIFAuthenticationCode = array[0..2] of AnsiChar; + TGIFApplicationRec = packed record + Identifier: TGIFIdentifierCode; + Authentication: TGIFAuthenticationCode; + end; + +const + CodeTableSize = 4096; + HashTableSize = 17777; + +type + TReadContext = record + Inx: Integer; + Size: Integer; + Buf: array [0..255 + 4] of Byte; + CodeSize: Integer; + ReadMask: Integer; + end; + PReadContext = ^TReadContext; + + TWriteContext = record + Inx: Integer; + CodeSize: Integer; + Buf: array [0..255 + 4] of Byte; + end; + PWriteContext = ^TWriteContext; + + TOutputContext = record + W: Integer; + H: Integer; + X: Integer; + Y: Integer; + BitsPerPixel: Integer; + Pass: Integer; + Interlace: Boolean; + LineIdent: Integer; + Data: Pointer; + CurrLineData: Pointer; + end; + + TImageDict = record + Tail: Word; + Index: Word; + Col: Byte; + end; + PImageDict = ^TImageDict; + + PIntCodeTable = ^TIntCodeTable; + TIntCodeTable = array [0..CodeTableSize - 1] of Word; + + TDictTable = array [0..CodeTableSize - 1] of TImageDict; + PDictTable = ^TDictTable; + +resourcestring + SGIFDecodingError = 'Error when decoding GIF LZW data'; + +{ + TGIFFileFormat implementation +} + +procedure TGIFFileFormat.Define; +begin + inherited; + FName := SGIFFormatName; + FFeatures := [ffLoad, ffSave, ffMultiImage]; + FSupportedFormats := GIFSupportedFormats; + FLoadAnimated := GIFDefaultLoadAnimated; + + AddMasks(SGIFMasks); + RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated); +end; + +function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer; +begin + Result := Y; + case Pass of + 0, 1: + Inc(Result, 8); + 2: + Inc(Result, 4); + 3: + Inc(Result, 2); + end; + if Result >= Height then + begin + if Pass = 0 then + begin + Pass := 1; + Result := 4; + if Result < Height then + Exit; + end; + if Pass = 1 then + begin + Pass := 2; + Result := 2; + if Result < Height then + Exit; + end; + if Pass = 2 then + begin + Pass := 3; + Result := 1; + end; + end; +end; + +{ GIF LZW decompression code is from JVCL JvGIF.pas unit.} +procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer; + Interlaced: Boolean; Data: Pointer); +var + MinCodeSize: Byte; + MaxCode, BitMask, InitCodeSize: Integer; + ClearCode, EndingCode, FirstFreeCode, FreeCode: Word; + I, OutCount, Code: Integer; + CurCode, OldCode, InCode, FinalChar: Word; + Prefix, Suffix, OutCode: PIntCodeTable; + ReadCtxt: TReadContext; + OutCtxt: TOutputContext; + TableFull: Boolean; + + function ReadCode(var Context: TReadContext): Integer; + var + RawCode: Integer; + ByteIndex: Integer; + Bytes: Byte; + BytesToLose: Integer; + begin + while (Context.Inx + Context.CodeSize > Context.Size) and + (Stream.Position < Stream.Size) do + begin + // Not enough bits in buffer - refill it - Not very efficient, but infrequently called + BytesToLose := Context.Inx shr 3; + // Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes + Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3); + Context.Inx := Context.Inx and 7; + Context.Size := Context.Size - (BytesToLose shl 3); + Stream.Read(Bytes, 1); + if Bytes > 0 then + Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes); + Context.Size := Context.Size + (Bytes shl 3); + end; + ByteIndex := Context.Inx shr 3; + RawCode := Context.Buf[Word(ByteIndex)] + + (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8); + if Context.CodeSize > 8 then + RawCode := RawCode + (Integer(Context.Buf[ByteIndex + 2]) shl 16); + RawCode := RawCode shr (Context.Inx and 7); + Context.Inx := Context.Inx + Byte(Context.CodeSize); + Result := RawCode and Context.ReadMask; + end; + + procedure Output(Value: Byte; var Context: TOutputContext); + var + P: PByte; + begin + if Context.Y >= Context.H then + Exit; + + // Only ifIndex8 supported + P := @PByteArray(Context.CurrLineData)[Context.X]; + P^ := Value; + + {case Context.BitsPerPixel of + 1: + begin + P := @PByteArray(Context.CurrLineData)[Context.X shr 3]; + if (Context.X and $07) <> 0 then + P^ := P^ or Word(Value shl (7 - (Word(Context.X and 7)))) + else + P^ := Byte(Value shl 7); + end; + 4: + begin + P := @PByteArray(Context.CurrLineData)[Context.X shr 1]; + if (Context.X and 1) <> 0 then + P^ := P^ or Value + else + P^ := Byte(Value shl 4); + end; + 8: + begin + P := @PByteArray(Context.CurrLineData)[Context.X]; + P^ := Value; + end; + end;} + Inc(Context.X); + + if Context.X < Context.W then + Exit; + Context.X := 0; + if Context.Interlace then + Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass) + else + Inc(Context.Y); + + Context.CurrLineData := @PByteArray(Context.Data)[Context.Y * Context.LineIdent]; + end; + +begin + OutCount := 0; + OldCode := 0; + FinalChar := 0; + TableFull := False; + GetMem(Prefix, SizeOf(TIntCodeTable)); + GetMem(Suffix, SizeOf(TIntCodeTable)); + GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word)); + try + Stream.Read(MinCodeSize, 1); + if (MinCodeSize < 2) or (MinCodeSize > 9) then + RaiseImaging(SGIFDecodingError, []); + // Initial read context + ReadCtxt.Inx := 0; + ReadCtxt.Size := 0; + ReadCtxt.CodeSize := MinCodeSize + 1; + ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1; + // Initialize pixel-output context + OutCtxt.X := 0; + OutCtxt.Y := 0; + OutCtxt.Pass := 0; + OutCtxt.W := Width; + OutCtxt.H := Height; + OutCtxt.BitsPerPixel := MinCodeSize; + OutCtxt.Interlace := Interlaced; + OutCtxt.LineIdent := Width; + OutCtxt.Data := Data; + OutCtxt.CurrLineData := Data; + BitMask := (1 shl OutCtxt.BitsPerPixel) - 1; + // 2 ^ MinCodeSize accounts for all colours in file + ClearCode := 1 shl MinCodeSize; + EndingCode := ClearCode + 1; + FreeCode := ClearCode + 2; + FirstFreeCode := FreeCode; + // 2^ (MinCodeSize + 1) includes clear and eoi Code and space too + InitCodeSize := ReadCtxt.CodeSize; + MaxCode := 1 shl ReadCtxt.CodeSize; + Code := ReadCode(ReadCtxt); + while (Code <> EndingCode) and (Code <> $FFFF) and + (OutCtxt.Y < OutCtxt.H) do + begin + if Code = ClearCode then + begin + ReadCtxt.CodeSize := InitCodeSize; + MaxCode := 1 shl ReadCtxt.CodeSize; + ReadCtxt.ReadMask := MaxCode - 1; + FreeCode := FirstFreeCode; + Code := ReadCode(ReadCtxt); + CurCode := Code; + OldCode := Code; + if Code = $FFFF then + Break; + FinalChar := (CurCode and BitMask); + Output(Byte(FinalChar), OutCtxt); + TableFull := False; + end + else + begin + CurCode := Code; + InCode := Code; + if CurCode >= FreeCode then + begin + CurCode := OldCode; + OutCode^[OutCount] := FinalChar; + Inc(OutCount); + end; + while CurCode > BitMask do + begin + if OutCount > CodeTableSize then + RaiseImaging(SGIFDecodingError, []); + OutCode^[OutCount] := Suffix^[CurCode]; + Inc(OutCount); + CurCode := Prefix^[CurCode]; + end; + + FinalChar := CurCode and BitMask; + OutCode^[OutCount] := FinalChar; + Inc(OutCount); + for I := OutCount - 1 downto 0 do + Output(Byte(OutCode^[I]), OutCtxt); + OutCount := 0; + // Update dictionary + if not TableFull then + begin + Prefix^[FreeCode] := OldCode; + Suffix^[FreeCode] := FinalChar; + // Advance to next free slot + Inc(FreeCode); + if FreeCode >= MaxCode then + begin + if ReadCtxt.CodeSize < 12 then + begin + Inc(ReadCtxt.CodeSize); + MaxCode := MaxCode shl 1; + ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1; + end + else + TableFull := True; + end; + end; + OldCode := InCode; + end; + Code := ReadCode(ReadCtxt); + end; + if Code = $FFFF then + RaiseImaging(SGIFDecodingError, []); + finally + FreeMem(Prefix); + FreeMem(OutCode); + FreeMem(Suffix); + end; +end; + +{ GIF LZW compression code is from JVCL JvGIF.pas unit.} +procedure TGIFFileFormat.LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer; + Interlaced: Boolean; Data: Pointer); +var + LineIdent: Integer; + MinCodeSize, Col: Byte; + InitCodeSize, X, Y: Integer; + Pass: Integer; + MaxCode: Integer; { 1 shl CodeSize } + ClearCode, EndingCode, LastCode, Tail: Integer; + I, HashValue: Integer; + LenString: Word; + Dict: PDictTable; + HashTable: TList; + PData: PByte; + WriteCtxt: TWriteContext; + + function InitHash(P: Integer): Integer; + begin + Result := (P + 3) * 301; + end; + + procedure WriteCode(Code: Integer; var Context: TWriteContext); + var + BufIndex: Integer; + Bytes: Byte; + begin + BufIndex := Context.Inx shr 3; + Code := Code shl (Context.Inx and 7); + Context.Buf[BufIndex] := Context.Buf[BufIndex] or Byte(Code); + Context.Buf[BufIndex + 1] := Byte(Code shr 8); + Context.Buf[BufIndex + 2] := Byte(Code shr 16); + Context.Inx := Context.Inx + Context.CodeSize; + if Context.Inx >= 255 * 8 then + begin + // Flush out full buffer + Bytes := 255; + IO.Write(Handle, @Bytes, 1); + IO.Write(Handle, @Context.Buf, Bytes); + Move(Context.Buf[255], Context.Buf[0], 2); + FillChar(Context.Buf[2], 255, 0); + Context.Inx := Context.Inx - (255 * 8); + end; + end; + + procedure FlushCode(var Context: TWriteContext); + var + Bytes: Byte; + begin + Bytes := (Context.Inx + 7) shr 3; + if Bytes > 0 then + begin + IO.Write(Handle, @Bytes, 1); + IO.Write(Handle, @Context.Buf, Bytes); + end; + // Data block terminator - a block of zero Size + Bytes := 0; + IO.Write(Handle, @Bytes, 1); + end; + +begin + LineIdent := Width; + Tail := 0; + HashValue := 0; + Col := 0; + HashTable := TList.Create; + GetMem(Dict, SizeOf(TDictTable)); + try + for I := 0 to HashTableSize - 1 do + HashTable.Add(nil); + + // Initialize encoder variables + InitCodeSize := BitCount + 1; + if InitCodeSize = 2 then + Inc(InitCodeSize); + MinCodeSize := InitCodeSize - 1; + IO.Write(Handle, @MinCodeSize, 1); + ClearCode := 1 shl MinCodeSize; + EndingCode := ClearCode + 1; + LastCode := EndingCode; + MaxCode := 1 shl InitCodeSize; + LenString := 0; + // Setup write context + WriteCtxt.Inx := 0; + WriteCtxt.CodeSize := InitCodeSize; + FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0); + WriteCode(ClearCode, WriteCtxt); + Y := 0; + Pass := 0; + + while Y < Height do + begin + PData := @PByteArray(Data)[Y * LineIdent]; + for X := 0 to Width - 1 do + begin + // Only ifIndex8 support + case BitCount of + 8: + begin + Col := PData^; + PData := @PByteArray(PData)[1]; + end; + {4: + begin + if X and 1 <> 0 then + begin + Col := PData^ and $0F; + PData := @PByteArray(PData)[1]; + end + else + Col := PData^ shr 4; + end; + 1: + begin + if X and 7 = 7 then + begin + Col := PData^ and 1; + PData := @PByteArray(PData)[1]; + end + else + Col := (PData^ shr (7 - (X and $07))) and $01; + end;} + end; + Inc(LenString); + if LenString = 1 then + begin + Tail := Col; + HashValue := InitHash(Col); + end + else + begin + HashValue := HashValue * (Col + LenString + 4); + I := HashValue mod HashTableSize; + HashValue := HashValue mod HashTableSize; + while (HashTable[I] <> nil) and + ((PImageDict(HashTable[I])^.Tail <> Tail) or + (PImageDict(HashTable[I])^.Col <> Col)) do + begin + Inc(I); + if I >= HashTableSize then + I := 0; + end; + if HashTable[I] <> nil then // Found in the strings table + Tail := PImageDict(HashTable[I])^.Index + else + begin + // Not found + WriteCode(Tail, WriteCtxt); + Inc(LastCode); + HashTable[I] := @Dict^[LastCode]; + PImageDict(HashTable[I])^.Index := LastCode; + PImageDict(HashTable[I])^.Tail := Tail; + PImageDict(HashTable[I])^.Col := Col; + Tail := Col; + HashValue := InitHash(Col); + LenString := 1; + if LastCode >= MaxCode then + begin + // Next Code will be written longer + MaxCode := MaxCode shl 1; + Inc(WriteCtxt.CodeSize); + end + else + if LastCode >= CodeTableSize - 2 then + begin + // Reset tables + WriteCode(Tail, WriteCtxt); + WriteCode(ClearCode, WriteCtxt); + LenString := 0; + LastCode := EndingCode; + WriteCtxt.CodeSize := InitCodeSize; + MaxCode := 1 shl InitCodeSize; + for I := 0 to HashTableSize - 1 do + HashTable[I] := nil; + end; + end; + end; + end; + if Interlaced then + Y := InterlaceStep(Y, Height, Pass) + else + Inc(Y); + end; + WriteCode(Tail, WriteCtxt); + WriteCode(EndingCode, WriteCtxt); + FlushCode(WriteCtxt); + finally + HashTable.Free; + FreeMem(Dict); + end; +end; + +function TGIFFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +type + TFrameInfo = record + Left, Top: Integer; + Width, Height: Integer; + Disposal: TDisposalMethod; + HasTransparency: Boolean; + HasLocalPal: Boolean; + TransIndex: Integer; + BackIndex: Integer; + end; +var + Header: TGIFHeader; + HasGlobalPal: Boolean; + GlobalPalLength: Integer; + GlobalPal: TPalette32Size256; + ScreenWidth, ScreenHeight, I, CachedIndex: Integer; + BlockID: Byte; + HasGraphicExt: Boolean; + GraphicExt: TGraphicControlExtension; + FrameInfos: array of TFrameInfo; + AppRead: Boolean; + CachedFrame: TImageData; + AnimFrames: TDynImageDataArray; + + function ReadBlockID: Byte; + begin + Result := GIFTrailer; + if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then + Result := GIFTrailer; + end; + + procedure ReadExtensions; + var + BlockSize, BlockType, ExtType: Byte; + AppRec: TGIFApplicationRec; + LoopCount: SmallInt; + + procedure SkipBytes; + begin + with GetIO do + repeat + // Read block sizes and skip them + Read(Handle, @BlockSize, SizeOf(BlockSize)); + Seek(Handle, BlockSize, smFromCurrent); + until BlockSize = 0; + end; + + begin + HasGraphicExt := False; + AppRead := False; + + // Read extensions until image descriptor is found. Only graphic extension + // is stored now (for transparency), others are skipped. + while BlockID = GIFExtensionIntroducer do + with GetIO do + begin + Read(Handle, @ExtType, SizeOf(ExtType)); + + while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do + begin + if ExtType = GIFGraphicControlExtension then + begin + HasGraphicExt := True; + Read(Handle, @GraphicExt, SizeOf(GraphicExt)); + end + else if (ExtType = GIFApplicationExtension) and not AppRead then + begin + Read(Handle, @BlockSize, SizeOf(BlockSize)); + if BlockSize >= SizeOf(AppRec) then + begin + Read(Handle, @AppRec, SizeOf(AppRec)); + if ((AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0')) or + ((AppRec.Identifier = 'ANIMEXTS') and (AppRec.Authentication = '1.0')) then + begin + Read(Handle, @BlockSize, SizeOf(BlockSize)); + while BlockSize <> 0 do + begin + BlockType := ReadBlockID; + Dec(BlockSize); + + case BlockType of + GIFAppLoopExtension: + if (BlockSize >= SizeOf(LoopCount)) then + begin + // Read loop count + Read(Handle, @LoopCount, SizeOf(LoopCount)); + Dec(BlockSize, SizeOf(LoopCount)); + if LoopCount > 0 then + Inc(LoopCount); // Netscape extension is really "repeats" not "loops" + FMetadata.SetMetaItem(SMetaAnimationLoops, LoopCount); + end; + GIFAppBufferExtension: + begin + Dec(BlockSize, SizeOf(Word)); + Seek(Handle, SizeOf(Word), smFromCurrent); + end; + end; + end; + SkipBytes; + AppRead := True; + end + else + begin + // Revert all bytes reading + Seek(Handle, - SizeOf(AppRec) - SizeOf(BlockSize), smFromCurrent); + SkipBytes; + end; + end + else + begin + Seek(Handle, - BlockSize - SizeOf(BlockSize), smFromCurrent); + SkipBytes; + end; + end + else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then + repeat + // Read block sizes and skip them + Read(Handle, @BlockSize, SizeOf(BlockSize)); + Seek(Handle, BlockSize, smFromCurrent); + until BlockSize = 0; + + // Read ID of following block + BlockID := ReadBlockID; + ExtType := BlockID; + end + end; + end; + + procedure CopyLZWData(Dest: TStream); + var + CodeSize, BlockSize: Byte; + InputSize: Integer; + Buff: array[Byte] of Byte; + begin + InputSize := ImagingIO.GetInputSize(GetIO, Handle); + // Copy codesize to stream + GetIO.Read(Handle, @CodeSize, 1); + Dest.Write(CodeSize, 1); + repeat + // Read and write data blocks, last is block term value of 0 + GetIO.Read(Handle, @BlockSize, 1); + Dest.Write(BlockSize, 1); + if BlockSize > 0 then + begin + GetIO.Read(Handle, @Buff[0], BlockSize); + Dest.Write(Buff[0], BlockSize); + end; + until (BlockSize = 0) or (GetIO.Tell(Handle) >= InputSize); + end; + + procedure ReadFrame; + var + ImageDesc: TImageDescriptor; + Interlaced: Boolean; + I, Idx, LocalPalLength: Integer; + LocalPal: TPalette32Size256; + LZWStream: TMemoryStream; + + procedure RemoveBadFrame; + begin + FreeImage(Images[Idx]); + SetLength(Images, Length(Images) - 1); + end; + + begin + Idx := Length(Images); + SetLength(Images, Idx + 1); + SetLength(FrameInfos, Idx + 1); + FillChar(LocalPal, SizeOf(LocalPal), 0); + + with GetIO do + begin + // Read and parse image descriptor + Read(Handle, @ImageDesc, SizeOf(ImageDesc)); + FrameInfos[Idx].HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable; + Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced; + LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize; + LocalPalLength := 1 shl (LocalPalLength + 1); // Total pal length is 2^(n+1) + + // From Mozilla source + if (ImageDesc.Width = 0) or (ImageDesc.Width > Header.ScreenWidth) then + ImageDesc.Width := Header.ScreenWidth; + if (ImageDesc.Height = 0) or (ImageDesc.Height > Header.ScreenHeight) then + ImageDesc.Height := Header.ScreenHeight; + + FrameInfos[Idx].Left := ImageDesc.Left; + FrameInfos[Idx].Top := ImageDesc.Top; + FrameInfos[Idx].Width := ImageDesc.Width; + FrameInfos[Idx].Height := ImageDesc.Height; + FrameInfos[Idx].BackIndex := Header.BackgroundColorIndex; + + // Create new image for this frame which would be later pasted onto logical screen + NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]); + + // Load local palette if there is any + if FrameInfos[Idx].HasLocalPal then + for I := 0 to LocalPalLength - 1 do + begin + LocalPal[I].A := 255; + Read(Handle, @LocalPal[I].R, SizeOf(LocalPal[I].R)); + Read(Handle, @LocalPal[I].G, SizeOf(LocalPal[I].G)); + Read(Handle, @LocalPal[I].B, SizeOf(LocalPal[I].B)); + end; + + // Use local pal if present or global pal if present or create + // default pal if neither of them is present + if FrameInfos[Idx].HasLocalPal then + Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal)) + else if HasGlobalPal then + Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal)) + else + FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2); + + if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then + begin + // Resize the screen if needed to fit the frame + ScreenWidth := Max(ScreenWidth, ImageDesc.Width + ImageDesc.Left); + ScreenHeight := Max(ScreenHeight, ImageDesc.Height + ImageDesc.Top); + end + else + begin + // Remove frame outside logical screen + RemoveBadFrame; + Exit; + end; + + // If Graphic Control Extension is present make use of it + if HasGraphicExt then + begin + FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent; + FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2); + if FrameInfos[Idx].HasTransparency then + begin + FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex; + Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0; + end; + FMetadata.SetMetaItem(SMetaFrameDelay, Integer(GraphicExt.DelayTime * 10), Idx); + end + else + FrameInfos[Idx].HasTransparency := False; + + LZWStream := TMemoryStream.Create; + try + try + // Copy LZW data to temp stream, needed for correct decompression + CopyLZWData(LZWStream); + LZWStream.Position := 0; + // Data decompression finally + LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits); + except + RemoveBadFrame; + Exit; + end; + finally + LZWStream.Free; + end; + end; + end; + + procedure CopyFrameTransparent32(const Image, Frame: TImageData; Left, Top: Integer); + var + X, Y: Integer; + Src: PByte; + Dst: PColor32; + begin + Src := Frame.Bits; + + // Copy all pixels from frame to log screen but ignore the transparent ones + for Y := 0 to Frame.Height - 1 do + begin + Dst := @PColor32RecArray(Image.Bits)[(Top + Y) * Image.Width + Left]; + for X := 0 to Frame.Width - 1 do + begin + if (Frame.Palette[Src^].A <> 0) then + Dst^ := Frame.Palette[Src^].Color; + Inc(Src); + Inc(Dst); + end; + end; + end; + + procedure AnimateFrame(Index: Integer; var AnimFrame: TImageData); + var + I, First, Last: Integer; + UseCache: Boolean; + BGColor: TColor32; + begin + // We may need to use raw frame 0 to n to correctly animate n-th frame + Last := Index; + First := Max(0, Last); + // See if we can use last animate frame as a basis for this one + // (so we don't have to use previous raw frames). + UseCache := TestImage(CachedFrame) and (CachedIndex = Index - 1) and (CachedIndex >= 0) and + (FrameInfos[CachedIndex].Disposal <> dmRestorePrevious); + + // Reuse or release cache + if UseCache then + CloneImage(CachedFrame, AnimFrame) + else + FreeImage(CachedFrame); + + // Default color for clearing of the screen + BGColor := Images[Index].Palette[FrameInfos[Index].BackIndex].Color; + + // Now prepare logical screen for drawing of raw frame at Index. + // We may need to use all previous raw frames to get the screen + // to proper state (according to their disposal methods). + + if not UseCache then + begin + if FrameInfos[Index].HasTransparency then + BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color; + // Clear whole screen + FillMemoryUInt32(AnimFrame.Bits, AnimFrame.Size, BGColor); + + // Try to maximize First so we don't have to use all 0 to n raw frames + while First > 0 do + begin + if (ScreenWidth = Images[First].Width) and (ScreenHeight = Images[First].Height) then + begin + if (FrameInfos[First].Disposal = dmRestoreBackground) and (First < Last) then + Break; + end; + Dec(First); + end; + + for I := First to Last - 1 do + begin + case FrameInfos[I].Disposal of + dmNoRemoval, dmLeave: + begin + // Copy previous raw frame onto screen + CopyFrameTransparent32(AnimFrame, Images[I], FrameInfos[I].Left, FrameInfos[I].Top); + end; + dmRestoreBackground: + if (I > First) then + begin + // Restore background color + FillRect(AnimFrame, FrameInfos[I].Left, FrameInfos[I].Top, + FrameInfos[I].Width, FrameInfos[I].Height, @BGColor); + end; + dmRestorePrevious: ; // Do nothing - previous state is already on screen + end; + end; + end + else if FrameInfos[CachedIndex].Disposal = dmRestoreBackground then + begin + // We have our cached result but also need to restore + // background in a place of cached frame + if FrameInfos[CachedIndex].HasTransparency then + BGColor := Images[CachedIndex].Palette[FrameInfos[CachedIndex].TransIndex].Color; + FillRect(AnimFrame, FrameInfos[CachedIndex].Left, FrameInfos[CachedIndex].Top, + FrameInfos[CachedIndex].Width, FrameInfos[CachedIndex].Height, @BGColor); + end; + + // Copy current raw frame to prepared screen + CopyFrameTransparent32(AnimFrame, Images[Index], FrameInfos[Index].Left, FrameInfos[Index].Top); + + // Cache animated result + CloneImage(AnimFrame, CachedFrame); + CachedIndex := Index; + end; + +begin + AppRead := False; + + SetLength(Images, 0); + FillChar(GlobalPal, SizeOf(GlobalPal), 0); + + with GetIO do + begin + // Read GIF header + Read(Handle, @Header, SizeOf(Header)); + ScreenWidth := Header.ScreenWidth; + ScreenHeight := Header.ScreenHeight; + HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7 + GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2 + GlobalPalLength := 1 shl (GlobalPalLength + 1); // Total pal length is 2^(n+1) + + // Read global palette from file if present + if HasGlobalPal then + begin + for I := 0 to GlobalPalLength - 1 do + begin + GlobalPal[I].A := 255; + Read(Handle, @GlobalPal[I].R, SizeOf(GlobalPal[I].R)); + Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G)); + Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B)); + end; + end; + + // Read ID of the first block + BlockID := ReadBlockID; + + // Now read all data blocks in the file until file trailer is reached + while BlockID <> GIFTrailer do + begin + // Read blocks until we find the one of known type + while not (BlockID in [GIFTrailer, GIFExtensionIntroducer, GIFImageDescriptor]) do + BlockID := ReadBlockID; + // Read supported and skip unsupported extensions + ReadExtensions; + // If image frame is found read it + if BlockID = GIFImageDescriptor then + ReadFrame; + // Read next block's ID + BlockID := ReadBlockID; + // If block ID is unknown set it to end-of-GIF marker + if not (BlockID in [GIFExtensionIntroducer, GIFTrailer, GIFImageDescriptor]) then + BlockID := GIFTrailer; + end; + + if FLoadAnimated then + begin + // Aniated frames will be stored in AnimFrames + SetLength(AnimFrames, Length(Images)); + InitImage(CachedFrame); + CachedIndex := -1; + + for I := 0 to High(Images) do + begin + // Create new logical screen + NewImage(ScreenWidth, ScreenHeight, ifA8R8G8B8, AnimFrames[I]); + // Animate frames to current log screen + AnimateFrame(I, AnimFrames[I]); + end; + + // Now release raw 8bit frames and put animated 32bit ones + // to output array + FreeImage(CachedFrame); + for I := 0 to High(AnimFrames) do + begin + FreeImage(Images[I]); + Images[I] := AnimFrames[I]; + end; + end; + + Result := True; + end; +end; + +function TGIFFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + Header: TGIFHeader; + ImageDesc: TImageDescriptor; + ImageToSave: TImageData; + MustBeFreed: Boolean; + I, J: Integer; + GraphicExt: TGraphicControlExtension; + + procedure FindMaxDimensions(var MaxWidth, MaxHeight: Word); + var + I: Integer; + begin + MaxWidth := Images[FFirstIdx].Width; + MaxHeight := Images[FFirstIdx].Height; + + for I := FFirstIdx + 1 to FLastIdx do + begin + MaxWidth := Iff(Images[I].Width > MaxWidth, Images[I].Width, MaxWidth); + MaxHeight := Iff(Images[I].Height > MaxWidth, Images[I].Height, MaxHeight); + end; + end; + + procedure SetFrameDelay(Idx: Integer; var Ext: TGraphicControlExtension); + begin + if FMetadata.HasMetaItemForSaving(SMetaFrameDelay, Idx) then + Ext.DelayTime := FMetadata.MetaItemsForSavingMulti[SMetaFrameDelay, Idx] div 10 + else + Ext.DelayTime := GIFDefaultDelay; + end; + + procedure SaveGlobalMetadata; + var + AppExt: TGIFApplicationRec; + BlockSize, LoopExtId: Byte; + Repeats: Word; + begin + if FMetadata.HasMetaItemForSaving(SMetaAnimationLoops) then + with GetIO do + begin + FillChar(AppExt, SizeOf(AppExt), 0); + AppExt.Identifier := 'NETSCAPE'; + AppExt.Authentication := '2.0'; + Repeats := FMetadata.MetaItemsForSaving[SMetaAnimationLoops]; + if Repeats > 0 then + Dec(Repeats); + LoopExtId := GIFAppLoopExtension; + + Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer)); + Write(Handle, @GIFApplicationExtension, SizeOf(GIFApplicationExtension)); + BlockSize := 11; + Write(Handle, @BlockSize, SizeOf(BlockSize)); + Write(Handle, @AppExt, SizeOf(AppExt)); + BlockSize := 3; + Write(Handle, @BlockSize, SizeOf(BlockSize)); + Write(Handle, @LoopExtId, SizeOf(LoopExtId)); + Write(Handle, @Repeats, SizeOf(Repeats)); + Write(Handle, @GIFBlockTerminator, SizeOf(GIFBlockTerminator)); + end; + end; + +begin + // Fill header with data, select size of largest image in array as + // logical screen size + FillChar(Header, Sizeof(Header), 0); + Header.Signature := GIFSignature; + Header.Version := GIFVersions[gv89]; + FindMaxDimensions(Header.ScreenWidth, Header.ScreenHeight); + Header.PackedFields := GIFColorResolution; // Color resolution is 256 + GetIO.Write(Handle, @Header, SizeOf(Header)); + + // Prepare default GC extension with delay + FillChar(GraphicExt, Sizeof(GraphicExt), 0); + GraphicExt.DelayTime := GIFDefaultDelay; + GraphicExt.BlockSize := 4; + + SaveGlobalMetadata; + + for I := FFirstIdx to FLastIdx do + begin + if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then + with GetIO, ImageToSave do + try + // Write Graphic Control Extension with default delay + Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer)); + Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension)); + SetFrameDelay(I, GraphicExt); + Write(Handle, @GraphicExt, SizeOf(GraphicExt)); + // Write frame marker and fill and write image descriptor for this frame + Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor)); + FillChar(ImageDesc, Sizeof(ImageDesc), 0); + ImageDesc.Width := Width; + ImageDesc.Height := Height; + ImageDesc.PackedFields := GIFLocalColorTable or GIFColorTableSize; // Use local color table with 256 entries + Write(Handle, @ImageDesc, SizeOf(ImageDesc)); + + // Write local color table for each frame + for J := 0 to 255 do + begin + Write(Handle, @Palette[J].R, SizeOf(Palette[J].R)); + Write(Handle, @Palette[J].G, SizeOf(Palette[J].G)); + Write(Handle, @Palette[J].B, SizeOf(Palette[J].B)); + end; + + // Finally compress image data + LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits); + + finally + if MustBeFreed then + FreeImage(ImageToSave); + end; + end; + + GetIO.Write(Handle, @GIFTrailer, SizeOf(GIFTrailer)); + Result := True; +end; + +procedure TGIFFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +begin + ConvertImage(Image, ifIndex8); +end; + +function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean; +var + Header: TGIFHeader; + ReadCount: Integer; +begin + Result := False; + if Handle <> nil then + begin + ReadCount := GetIO.Read(Handle, @Header, SizeOf(Header)); + GetIO.Seek(Handle, -ReadCount, smFromCurrent); + Result := (ReadCount >= SizeOf(Header)) and + (Header.Signature = GIFSignature) and + ((Header.Version = GIFVersions[gv87]) or (Header.Version = GIFVersions[gv89])); + end; +end; + +initialization + RegisterImageFileFormat(TGIFFileFormat); + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - nothing now + + -- 0.77 Changes/Bug Fixes ----------------------------------- + - Fixed crash when resaving GIF with animation metadata. + - Writes frame delays of GIF animations from metadata. + - Reads and writes looping of GIF animations stored into/from metadata. + + -- 0.26.5 Changes/Bug Fixes --------------------------------- + - Reads frame delays from GIF animations into metadata. + + -- 0.26.3 Changes/Bug Fixes --------------------------------- + - Fixed bug - loading of GIF with NETSCAPE app extensions + failed with Delphi 2009. + + -- 0.26.1 Changes/Bug Fixes --------------------------------- + - GIF loading and animation mostly rewritten, based on + modification by Sergey Galezdinov (ExtraGIF in Extras/Contrib). + + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - Fixed loading of some rare GIFs, problems with LZW + decompression. + + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - Better solution to transparency for some GIFs. Background not + transparent by default. + + -- 0.24.1 Changes/Bug Fixes --------------------------------- + - Made background color transparent by default (alpha = 0). + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Fixed other loading bugs (local pal size, transparency). + - Added GIF saving. + - Fixed bug when loading multi-frame GIFs and implemented few animation + features (disposal methods, ...). + - Loading of GIFs working. + - Unit created with initial stuff! +} + +end. diff --git a/Imaging/ImagingIO.pas b/Imaging/ImagingIO.pas index 04c0256..9d79424 100644 --- a/Imaging/ImagingIO.pas +++ b/Imaging/ImagingIO.pas @@ -1,574 +1,669 @@ -{ - $Id: ImagingIO.pas 100 2007-06-28 21:09:52Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains default IO functions for reading from/writting to - files, streams and memory.} -unit ImagingIO; - -{$I ImagingOptions.inc} - -interface - -uses - SysUtils, Classes, ImagingTypes, Imaging, ImagingUtility; - -type - TMemoryIORec = record - Data: ImagingUtility.PByteArray; - Position: LongInt; - Size: LongInt; - end; - PMemoryIORec = ^TMemoryIORec; - -var - OriginalFileIO: TIOFunctions; - FileIO: TIOFunctions; - StreamIO: TIOFunctions; - MemoryIO: TIOFunctions; - -{ Helper function that returns size of input (from current position to the end) - represented by Handle (and opened and operated on by members of IOFunctions).} -function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt; -{ Helper function that initializes TMemoryIORec with given params.} -function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec; - -implementation - -const - DefaultBufferSize = 16 * 1024; - -type - { Based on TaaBufferedStream - Copyright (c) Julian M Bucknall 1997, 1999 } - TBufferedStream = class(TObject) - private - FBuffer: PByteArray; - FBufSize: Integer; - FBufStart: Integer; - FBufPos: Integer; - FBytesInBuf: Integer; - FSize: Integer; - FDirty: Boolean; - FStream: TStream; - function GetPosition: Integer; - function GetSize: Integer; - procedure ReadBuffer; - procedure WriteBuffer; - procedure SetPosition(const Value: Integer); - public - constructor Create(AStream: TStream); - destructor Destroy; override; - function Read(var Buffer; Count: Integer): Integer; - function Write(const Buffer; Count: Integer): Integer; - function Seek(Offset: Integer; Origin: Word): Integer; - procedure Commit; - property Stream: TStream read FStream; - property Position: Integer read GetPosition write SetPosition; - property Size: Integer read GetSize; - end; - -constructor TBufferedStream.Create(AStream: TStream); -begin - inherited Create; - FStream := AStream; - FBufSize := DefaultBufferSize; - GetMem(FBuffer, FBufSize); - FBufPos := 0; - FBytesInBuf := 0; - FBufStart := 0; - FDirty := False; - FSize := AStream.Size; -end; - -destructor TBufferedStream.Destroy; -begin - if FBuffer <> nil then - begin - Commit; - FreeMem(FBuffer); - end; - FStream.Position := Position; // Make sure source stream has right position - inherited Destroy; -end; - -function TBufferedStream.GetPosition: Integer; -begin - Result := FBufStart + FBufPos; -end; - -procedure TBufferedStream.SetPosition(const Value: Integer); -begin - Seek(Value, soFromCurrent); -end; - -function TBufferedStream.GetSize: Integer; -begin - Result := FSize; -end; - -procedure TBufferedStream.ReadBuffer; -var - SeekResult: Integer; -begin - SeekResult := FStream.Seek(FBufStart, 0); - if SeekResult = -1 then - raise Exception.Create('TBufferedStream.ReadBuffer: seek failed'); - FBytesInBuf := FStream.Read(FBuffer^, FBufSize); - if FBytesInBuf <= 0 then - raise Exception.Create('TBufferedStream.ReadBuffer: read failed'); -end; - -procedure TBufferedStream.WriteBuffer; -var - SeekResult: Integer; - BytesWritten: Integer; -begin - SeekResult := FStream.Seek(FBufStart, 0); - if SeekResult = -1 then - raise Exception.Create('TBufferedStream.WriteBuffer: seek failed'); - BytesWritten := FStream.Write(FBuffer^, FBytesInBuf); - if BytesWritten <> FBytesInBuf then - raise Exception.Create('TBufferedStream.WriteBuffer: write failed'); -end; - -procedure TBufferedStream.Commit; -begin - if FDirty then - begin - WriteBuffer; - FDirty := False; - end; -end; - -function TBufferedStream.Read(var Buffer; Count: Integer): Integer; -var - BufAsBytes : TByteArray absolute Buffer; - BufIdx, BytesToGo, BytesToRead: Integer; -begin - // Calculate the actual number of bytes we can read - this depends on - // the current position and size of the stream as well as the number - // of bytes requested. - BytesToGo := Count; - if FSize < (FBufStart + FBufPos + Count) then - BytesToGo := FSize - (FBufStart + FBufPos); - - if BytesToGo <= 0 then - begin - Result := 0; - Exit; - end; - // Remember to return the result of our calculation - Result := BytesToGo; - - BufIdx := 0; - if FBytesInBuf = 0 then - ReadBuffer; - // Calculate the number of bytes we can read prior to the loop - BytesToRead := FBytesInBuf - FBufPos; - if BytesToRead > BytesToGo then - BytesToRead := BytesToGo; - // Copy from the stream buffer to the caller's buffer - Move(FBuffer^[FBufPos], BufAsBytes[BufIdx], BytesToRead); - // Calculate the number of bytes still to read} - Dec(BytesToGo, BytesToRead); - - // while we have bytes to read, read them - while BytesToGo > 0 do - begin - Inc(BufIdx, BytesToRead); - // As we've exhausted this buffer-full, advance to the next, check - // to see whether we need to write the buffer out first - if FDirty then - begin - WriteBuffer; - FDirty := false; - end; - Inc(FBufStart, FBufSize); - FBufPos := 0; - ReadBuffer; - // Calculate the number of bytes we can read in this cycle - BytesToRead := FBytesInBuf; - if BytesToRead > BytesToGo then - BytesToRead := BytesToGo; - // Ccopy from the stream buffer to the caller's buffer - Move(FBuffer^, BufAsBytes[BufIdx], BytesToRead); - // Calculate the number of bytes still to read - Dec(BytesToGo, BytesToRead); - end; - // Remember our new position - Inc(FBufPos, BytesToRead); - if FBufPos = FBufSize then - begin - Inc(FBufStart, FBufSize); - FBufPos := 0; - FBytesInBuf := 0; - end; -end; - -function TBufferedStream.Seek(Offset: Integer; Origin: Word): Integer; -var - NewBufStart, NewPos: Integer; -begin - // Calculate the new position - case Origin of - soFromBeginning : NewPos := Offset; - soFromCurrent : NewPos := FBufStart + FBufPos + Offset; - soFromEnd : NewPos := FSize + Offset; - else - raise Exception.Create('TBufferedStream.Seek: invalid origin'); - end; - - if (NewPos < 0) or (NewPos > FSize) then - begin - //NewPos := ClampInt(NewPos, 0, FSize); don't do this - for writing - end; - // Calculate which page of the file we need to be at - NewBufStart := NewPos and not Pred(FBufSize); - // If the new page is different than the old, mark the buffer as being - // ready to be replenished, and if need be write out any dirty data - if NewBufStart <> FBufStart then - begin - if FDirty then - begin - WriteBuffer; - FDirty := False; - end; - FBufStart := NewBufStart; - FBytesInBuf := 0; - end; - // Save the new position - FBufPos := NewPos - NewBufStart; - Result := NewPos; -end; - -function TBufferedStream.Write(const Buffer; Count: Integer): Integer; -var - BufAsBytes: TByteArray absolute Buffer; - BufIdx, BytesToGo, BytesToWrite: Integer; -begin - // When we write to this stream we always assume that we can write the - // requested number of bytes: if we can't (eg, the disk is full) we'll - // get an exception somewhere eventually. - BytesToGo := Count; - // Remember to return the result of our calculation - Result := BytesToGo; - - BufIdx := 0; - if (FBytesInBuf = 0) and (FSize > FBufStart) then - ReadBuffer; - // Calculate the number of bytes we can write prior to the loop - BytesToWrite := FBufSize - FBufPos; - if BytesToWrite > BytesToGo then - BytesToWrite := BytesToGo; - // Copy from the caller's buffer to the stream buffer - Move(BufAsBytes[BufIdx], FBuffer^[FBufPos], BytesToWrite); - // Mark our stream buffer as requiring a save to the actual stream, - // note that this will suffice for the rest of the routine as well: no - // inner routine will turn off the dirty flag. - FDirty := True; - // Calculate the number of bytes still to write - Dec(BytesToGo, BytesToWrite); - - // While we have bytes to write, write them - while BytesToGo > 0 do - begin - Inc(BufIdx, BytesToWrite); - // As we've filled this buffer, write it out to the actual stream - // and advance to the next buffer, reading it if required - FBytesInBuf := FBufSize; - WriteBuffer; - Inc(FBufStart, FBufSize); - FBufPos := 0; - FBytesInBuf := 0; - if FSize > FBufStart then - ReadBuffer; - // Calculate the number of bytes we can write in this cycle - BytesToWrite := FBufSize; - if BytesToWrite > BytesToGo then - BytesToWrite := BytesToGo; - // Copy from the caller's buffer to our buffer - Move(BufAsBytes[BufIdx], FBuffer^, BytesToWrite); - // Calculate the number of bytes still to write - Dec(BytesToGo, BytesToWrite); - end; - // Remember our new position - Inc(FBufPos, BytesToWrite); - // Make sure the count of valid bytes is correct - if FBytesInBuf < FBufPos then - FBytesInBuf := FBufPos; - // Make sure the stream size is correct - if FSize < (FBufStart + FBytesInBuf) then - FSize := FBufStart + FBytesInBuf; - // If we're at the end of the buffer, write it out and advance to the - // start of the next page - if FBufPos = FBufSize then - begin - WriteBuffer; - FDirty := False; - Inc(FBufStart, FBufSize); - FBufPos := 0; - FBytesInBuf := 0; - end; -end; - -{ File IO functions } - -function FileOpenRead(FileName: PChar): TImagingHandle; cdecl; -begin - Result := TBufferedStream.Create(TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite)); -end; - -function FileOpenWrite(FileName: PChar): TImagingHandle; cdecl; -begin - Result := TBufferedStream.Create(TFileStream.Create(FileName, fmCreate or fmShareDenyWrite)); -end; - -procedure FileClose(Handle: TImagingHandle); cdecl; -var - Stream: TStream; -begin - Stream := TBufferedStream(Handle).Stream; - TBufferedStream(Handle).Free; - Stream.Free; -end; - -function FileEof(Handle: TImagingHandle): Boolean; cdecl; -begin - Result := TBufferedStream(Handle).Position = TBufferedStream(Handle).Size; -end; - -function FileSeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode): - LongInt; cdecl; -begin - Result := TBufferedStream(Handle).Seek(Offset, LongInt(Mode)); -end; - -function FileTell(Handle: TImagingHandle): LongInt; cdecl; -begin - Result := TBufferedStream(Handle).Position; -end; - -function FileRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): - LongInt; cdecl; -begin - Result := TBufferedStream(Handle).Read(Buffer^, Count); -end; - -function FileWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): - LongInt; cdecl; -begin - Result := TBufferedStream(Handle).Write(Buffer^, Count); -end; - -{ Stream IO functions } - -function StreamOpenRead(FileName: PChar): TImagingHandle; cdecl; -begin - Result := FileName; -end; - -function StreamOpenWrite(FileName: PChar): TImagingHandle; cdecl; -begin - Result := FileName; -end; - -procedure StreamClose(Handle: TImagingHandle); cdecl; -begin -end; - -function StreamEof(Handle: TImagingHandle): Boolean; cdecl; -begin - Result := TStream(Handle).Position = TStream(Handle).Size; -end; - -function StreamSeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode): - LongInt; cdecl; -begin - Result := TStream(Handle).Seek(Offset, LongInt(Mode)); -end; - -function StreamTell(Handle: TImagingHandle): LongInt; cdecl; -begin - Result := TStream(Handle).Position; -end; - -function StreamRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): - LongInt; cdecl; -begin - Result := TStream(Handle).Read(Buffer^, Count); -end; - -function StreamWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): - LongInt; cdecl; -begin - Result := TStream(Handle).Write(Buffer^, Count); -end; - -{ Memory IO functions } - -function MemoryOpenRead(FileName: PChar): TImagingHandle; cdecl; -begin - Result := FileName; -end; - -function MemoryOpenWrite(FileName: PChar): TImagingHandle; cdecl; -begin - Result := FileName; -end; - -procedure MemoryClose(Handle: TImagingHandle); cdecl; -begin -end; - -function MemoryEof(Handle: TImagingHandle): Boolean; cdecl; -begin - Result := PMemoryIORec(Handle).Position = PMemoryIORec(Handle).Size; -end; - -function MemorySeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode): - LongInt; cdecl; -begin - Result := PMemoryIORec(Handle).Position; - case Mode of - smFromBeginning: Result := Offset; - smFromCurrent: Result := PMemoryIORec(Handle).Position + Offset; - smFromEnd: Result := PMemoryIORec(Handle).Size + Offset; - end; - //Result := ClampInt(Result, 0, PMemoryIORec(Handle).Size); don't do this - some file formats use it - PMemoryIORec(Handle).Position := Result; -end; - -function MemoryTell(Handle: TImagingHandle): LongInt; cdecl; -begin - Result := PMemoryIORec(Handle).Position; -end; - -function MemoryRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): - LongInt; cdecl; -var - Rec: PMemoryIORec; -begin - Rec := PMemoryIORec(Handle); - Result := Count; - if Rec.Position + Count > Rec.Size then - Result := Rec.Size - Rec.Position; - Move(Rec.Data[Rec.Position], Buffer^, Result); - Rec.Position := Rec.Position + Result; -end; - -function MemoryWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): - LongInt; cdecl; -var - Rec: PMemoryIORec; -begin - Rec := PMemoryIORec(Handle); - Result := Count; - if Rec.Position + Count > Rec.Size then - Result := Rec.Size - Rec.Position; - Move(Buffer^, Rec.Data[Rec.Position], Result); - Rec.Position := Rec.Position + Result; -end; - -{ Helper IO functions } - -function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt; -var - OldPos: Int64; -begin - OldPos := IOFunctions.Tell(Handle); - IOFunctions.Seek(Handle, 0, smFromEnd); - Result := IOFunctions.Tell(Handle); - IOFunctions.Seek(Handle, OldPos, smFromBeginning); -end; - -function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec; -begin - Result.Data := Data; - Result.Position := 0; - Result.Size := Size; -end; - -initialization - OriginalFileIO.OpenRead := FileOpenRead; - OriginalFileIO.OpenWrite := FileOpenWrite; - OriginalFileIO.Close := FileClose; - OriginalFileIO.Eof := FileEof; - OriginalFileIO.Seek := FileSeek; - OriginalFileIO.Tell := FileTell; - OriginalFileIO.Read := FileRead; - OriginalFileIO.Write := FileWrite; - - StreamIO.OpenRead := StreamOpenRead; - StreamIO.OpenWrite := StreamOpenWrite; - StreamIO.Close := StreamClose; - StreamIO.Eof := StreamEof; - StreamIO.Seek := StreamSeek; - StreamIO.Tell := StreamTell; - StreamIO.Read := StreamRead; - StreamIO.Write := StreamWrite; - - MemoryIO.OpenRead := MemoryOpenRead; - MemoryIO.OpenWrite := MemoryOpenWrite; - MemoryIO.Close := MemoryClose; - MemoryIO.Eof := MemoryEof; - MemoryIO.Seek := MemorySeek; - MemoryIO.Tell := MemoryTell; - MemoryIO.Read := MemoryRead; - MemoryIO.Write := MemoryWrite; - - ResetFileIO; - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Added merge between buffered read-only and write-only file - stream adapters - TIFF saving needed both reading and writing. - - Fixed bug causing wrong value of TBufferedWriteFile.Size - (needed to add buffer pos to size). - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Removed TMemoryIORec.Written, use Position to get proper memory - position (Written didn't take Seeks into account). - - Added TBufferedReadFile and TBufferedWriteFile classes for - buffered file reading/writting. File IO functions now use these - classes resulting in performance increase mainly in file formats - that read/write many small chunks. - - Added fmShareDenyWrite to FileOpenRead. You can now read - files opened for reading by Imaging from other apps. - - Added GetInputSize and PrepareMemIO helper functions. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - changed behaviour of MemorySeek to act as TStream - based Seeks -} -end. - +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains default IO functions for reading from/writing to + files, streams and memory.} +unit ImagingIO; + +{$I ImagingOptions.inc} + +interface + +uses + SysUtils, Classes, ImagingTypes, Imaging, ImagingUtility; + +type + TMemoryIORec = record + Data: ImagingUtility.PByteArray; + Position: LongInt; + Size: LongInt; + end; + PMemoryIORec = ^TMemoryIORec; + +var + OriginalFileIO: TIOFunctions; + FileIO: TIOFunctions; + StreamIO: TIOFunctions; + MemoryIO: TIOFunctions; + +{ Helper function that returns size of input (from current position to the end) + represented by Handle (and opened and operated on by members of IOFunctions).} +function GetInputSize(const IOFunctions: TIOFunctions; Handle: TImagingHandle): Int64; +{ Helper function that initializes TMemoryIORec with given params.} +function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec; +{ Reads one text line from input (CR+LF, CR, or LF as line delimiter).} +function ReadLine(const IOFunctions: TIOFunctions; Handle: TImagingHandle; + out Line: AnsiString; FailOnControlChars: Boolean = False): Boolean; +{ Writes one text line to input with optional line delimiter.} +procedure WriteLine(const IOFunctions: TIOFunctions; Handle: TImagingHandle; + const Line: AnsiString; const LineEnding: AnsiString = sLineBreak); + +type + TReadMemoryStream = class(TCustomMemoryStream) + public + constructor Create(Data: Pointer; Size: Integer); + class function CreateFromIOHandle(const IOFunctions: TIOFunctions; Handle: TImagingHandle): TReadMemoryStream; + end; + + TImagingIOStream = class(TStream) + private + FIO: TIOFunctions; + FHandle: TImagingHandle; + public + constructor Create(const IOFunctions: TIOFunctions; Handle: TImagingHandle); + end; + +implementation + +const + DefaultBufferSize = 16 * 1024; + +type + { Based on TaaBufferedStream + Copyright (c) Julian M Bucknall 1997, 1999 } + TBufferedStream = class + private + FBuffer: PByteArray; + FBufSize: Integer; + FBufStart: Integer; + FBufPos: Integer; + FBytesInBuf: Integer; + FSize: Integer; + FDirty: Boolean; + FStream: TStream; + function GetPosition: Integer; + function GetSize: Integer; + procedure ReadBuffer; + procedure WriteBuffer; + procedure SetPosition(const Value: Integer); + public + constructor Create(AStream: TStream); + destructor Destroy; override; + function Read(var Buffer; Count: Integer): Integer; + function Write(const Buffer; Count: Integer): Integer; + function Seek(Offset: Integer; Origin: Word): Integer; + procedure Commit; + property Stream: TStream read FStream; + property Position: Integer read GetPosition write SetPosition; + property Size: Integer read GetSize; + end; + +constructor TBufferedStream.Create(AStream: TStream); +begin + inherited Create; + FStream := AStream; + FBufSize := DefaultBufferSize; + GetMem(FBuffer, FBufSize); + FBufPos := 0; + FBytesInBuf := 0; + FBufStart := 0; + FDirty := False; + FSize := AStream.Size; +end; + +destructor TBufferedStream.Destroy; +begin + if FBuffer <> nil then + begin + Commit; + FreeMem(FBuffer); + end; + FStream.Position := Position; // Make sure source stream has right position + inherited Destroy; +end; + +function TBufferedStream.GetPosition: Integer; +begin + Result := FBufStart + FBufPos; +end; + +procedure TBufferedStream.SetPosition(const Value: Integer); +begin + Seek(Value, soFromCurrent); +end; + +function TBufferedStream.GetSize: Integer; +begin + Result := FSize; +end; + +procedure TBufferedStream.ReadBuffer; +var + SeekResult: Integer; +begin + SeekResult := FStream.Seek(FBufStart, soBeginning); + if SeekResult = -1 then + raise Exception.Create('TBufferedStream.ReadBuffer: seek failed'); + FBytesInBuf := FStream.Read(FBuffer^, FBufSize); + if FBytesInBuf <= 0 then + raise Exception.Create('TBufferedStream.ReadBuffer: read failed'); +end; + +procedure TBufferedStream.WriteBuffer; +var + SeekResult: Integer; + BytesWritten: Integer; +begin + SeekResult := FStream.Seek(FBufStart, soBeginning); + if SeekResult = -1 then + raise Exception.Create('TBufferedStream.WriteBuffer: seek failed'); + BytesWritten := FStream.Write(FBuffer^, FBytesInBuf); + if BytesWritten <> FBytesInBuf then + raise Exception.Create('TBufferedStream.WriteBuffer: write failed'); +end; + +procedure TBufferedStream.Commit; +begin + if FDirty then + begin + WriteBuffer; + FDirty := False; + end; +end; + +function TBufferedStream.Read(var Buffer; Count: Integer): Integer; +var + BufAsBytes: TByteArray absolute Buffer; + BufIdx, BytesToGo, BytesToRead: Integer; +begin + // Calculate the actual number of bytes we can read - this depends on + // the current position and size of the stream as well as the number + // of bytes requested. + BytesToGo := Count; + if FSize < (FBufStart + FBufPos + Count) then + BytesToGo := FSize - (FBufStart + FBufPos); + + if BytesToGo <= 0 then + begin + Result := 0; + Exit; + end; + // Remember to return the result of our calculation + Result := BytesToGo; + + BufIdx := 0; + if FBytesInBuf = 0 then + ReadBuffer; + // Calculate the number of bytes we can read prior to the loop + BytesToRead := FBytesInBuf - FBufPos; + if BytesToRead > BytesToGo then + BytesToRead := BytesToGo; + // Copy from the stream buffer to the caller's buffer + Move(FBuffer^[FBufPos], BufAsBytes[BufIdx], BytesToRead); + // Calculate the number of bytes still to read} + Dec(BytesToGo, BytesToRead); + + // while we have bytes to read, read them + while BytesToGo > 0 do + begin + Inc(BufIdx, BytesToRead); + // As we've exhausted this buffer-full, advance to the next, check + // to see whether we need to write the buffer out first + if FDirty then + begin + WriteBuffer; + FDirty := false; + end; + Inc(FBufStart, FBufSize); + FBufPos := 0; + ReadBuffer; + // Calculate the number of bytes we can read in this cycle + BytesToRead := FBytesInBuf; + if BytesToRead > BytesToGo then + BytesToRead := BytesToGo; + // Copy from the stream buffer to the caller's buffer + Move(FBuffer^, BufAsBytes[BufIdx], BytesToRead); + // Calculate the number of bytes still to read + Dec(BytesToGo, BytesToRead); + end; + // Remember our new position + Inc(FBufPos, BytesToRead); + if FBufPos = FBufSize then + begin + Inc(FBufStart, FBufSize); + FBufPos := 0; + FBytesInBuf := 0; + end; +end; + +function TBufferedStream.Seek(Offset: Integer; Origin: Word): Integer; +var + NewBufStart, NewPos: Integer; +begin + // Calculate the new position + case Origin of + soFromBeginning : NewPos := Offset; + soFromCurrent : NewPos := FBufStart + FBufPos + Offset; + soFromEnd : NewPos := FSize + Offset; + else + raise Exception.Create('TBufferedStream.Seek: invalid origin'); + end; + + if (NewPos < 0) or (NewPos > FSize) then + begin + //NewPos := ClampInt(NewPos, 0, FSize); don't do this - for writing + end; + // Calculate which page of the file we need to be at + NewBufStart := NewPos and not Pred(FBufSize); + // If the new page is different than the old, mark the buffer as being + // ready to be replenished, and if need be write out any dirty data + if NewBufStart <> FBufStart then + begin + if FDirty then + begin + WriteBuffer; + FDirty := False; + end; + FBufStart := NewBufStart; + FBytesInBuf := 0; + end; + // Save the new position + FBufPos := NewPos - NewBufStart; + Result := NewPos; +end; + +function TBufferedStream.Write(const Buffer; Count: Integer): Integer; +var + BufAsBytes: TByteArray absolute Buffer; + BufIdx, BytesToGo, BytesToWrite: Integer; +begin + // When we write to this stream we always assume that we can write the + // requested number of bytes: if we can't (eg, the disk is full) we'll + // get an exception somewhere eventually. + BytesToGo := Count; + // Remember to return the result of our calculation + Result := BytesToGo; + + BufIdx := 0; + if (FBytesInBuf = 0) and (FSize > FBufStart) then + ReadBuffer; + // Calculate the number of bytes we can write prior to the loop + BytesToWrite := FBufSize - FBufPos; + if BytesToWrite > BytesToGo then + BytesToWrite := BytesToGo; + // Copy from the caller's buffer to the stream buffer + Move(BufAsBytes[BufIdx], FBuffer^[FBufPos], BytesToWrite); + // Mark our stream buffer as requiring a save to the actual stream, + // note that this will suffice for the rest of the routine as well: no + // inner routine will turn off the dirty flag. + FDirty := True; + // Calculate the number of bytes still to write + Dec(BytesToGo, BytesToWrite); + + // While we have bytes to write, write them + while BytesToGo > 0 do + begin + Inc(BufIdx, BytesToWrite); + // As we've filled this buffer, write it out to the actual stream + // and advance to the next buffer, reading it if required + FBytesInBuf := FBufSize; + WriteBuffer; + Inc(FBufStart, FBufSize); + FBufPos := 0; + FBytesInBuf := 0; + if FSize > FBufStart then + ReadBuffer; + // Calculate the number of bytes we can write in this cycle + BytesToWrite := FBufSize; + if BytesToWrite > BytesToGo then + BytesToWrite := BytesToGo; + // Copy from the caller's buffer to our buffer + Move(BufAsBytes[BufIdx], FBuffer^, BytesToWrite); + // Calculate the number of bytes still to write + Dec(BytesToGo, BytesToWrite); + end; + // Remember our new position + Inc(FBufPos, BytesToWrite); + // Make sure the count of valid bytes is correct + if FBytesInBuf < FBufPos then + FBytesInBuf := FBufPos; + // Make sure the stream size is correct + if FSize < (FBufStart + FBytesInBuf) then + FSize := FBufStart + FBytesInBuf; + // If we're at the end of the buffer, write it out and advance to the + // start of the next page + if FBufPos = FBufSize then + begin + WriteBuffer; + FDirty := False; + Inc(FBufStart, FBufSize); + FBufPos := 0; + FBytesInBuf := 0; + end; +end; + +{ File IO functions } + +function FileOpen(FileName: PChar; Mode: TOpenMode): TImagingHandle; cdecl; +var + Stream: TStream; +begin + Stream := nil; + + case Mode of + omReadOnly: Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); + omCreate: Stream := TFileStream.Create(FileName, fmCreate); + omReadWrite: + begin + if FileExists(FileName) then + Stream := TFileStream.Create(FileName, fmOpenReadWrite or fmShareExclusive) + else + Stream := TFileStream.Create(FileName, fmCreate); + end; + end; + + Assert(Stream <> nil); + Result := TBufferedStream.Create(Stream); +end; + +procedure FileClose(Handle: TImagingHandle); cdecl; +var + Stream: TStream; +begin + Stream := TBufferedStream(Handle).Stream; + TBufferedStream(Handle).Free; + Stream.Free; +end; + +function FileEof(Handle: TImagingHandle): Boolean; cdecl; +begin + Result := TBufferedStream(Handle).Position = TBufferedStream(Handle).Size; +end; + +function FileSeek(Handle: TImagingHandle; Offset: Int64; Mode: TSeekMode): Int64; cdecl; +begin + Result := TBufferedStream(Handle).Seek(Offset, LongInt(Mode)); +end; + +function FileTell(Handle: TImagingHandle): Int64; cdecl; +begin + Result := TBufferedStream(Handle).Position; +end; + +function FileRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl; +begin + Result := TBufferedStream(Handle).Read(Buffer^, Count); +end; + +function FileWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl; +begin + Result := TBufferedStream(Handle).Write(Buffer^, Count); +end; + +{ Stream IO functions } + +function StreamOpen(FileName: PChar; Mode: TOpenMode): TImagingHandle; cdecl; +begin + Result := FileName; +end; + +procedure StreamClose(Handle: TImagingHandle); cdecl; +begin +end; + +function StreamEof(Handle: TImagingHandle): Boolean; cdecl; +begin + Result := TStream(Handle).Position = TStream(Handle).Size; +end; + +function StreamSeek(Handle: TImagingHandle; Offset: Int64; Mode: TSeekMode): Int64; cdecl; +begin + Result := TStream(Handle).Seek(Offset, Word(Mode)); +end; + +function StreamTell(Handle: TImagingHandle): Int64; cdecl; +begin + Result := TStream(Handle).Position; +end; + +function StreamRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): + LongInt; cdecl; +begin + Result := TStream(Handle).Read(Buffer^, Count); +end; + +function StreamWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl; +begin + Result := TStream(Handle).Write(Buffer^, Count); +end; + +{ Memory IO functions } + +function MemoryOpen(FileName: PChar; Mode: TOpenMode): TImagingHandle; cdecl; +begin + Result := FileName; +end; + +procedure MemoryClose(Handle: TImagingHandle); cdecl; +begin +end; + +function MemoryEof(Handle: TImagingHandle): Boolean; cdecl; +begin + Result := PMemoryIORec(Handle).Position = PMemoryIORec(Handle).Size; +end; + +function MemorySeek(Handle: TImagingHandle; Offset: Int64; Mode: TSeekMode): Int64; cdecl; +begin + Result := PMemoryIORec(Handle).Position; + case Mode of + smFromBeginning: Result := Offset; + smFromCurrent: Result := PMemoryIORec(Handle).Position + Offset; + smFromEnd: Result := PMemoryIORec(Handle).Size + Offset; + end; + //Result := ClampInt(Result, 0, PMemoryIORec(Handle).Size); don't do this - some file formats use it + PMemoryIORec(Handle).Position := Result; +end; + +function MemoryTell(Handle: TImagingHandle): Int64; cdecl; +begin + Result := PMemoryIORec(Handle).Position; +end; + +function MemoryRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): + LongInt; cdecl; +var + Rec: PMemoryIORec; +begin + Rec := PMemoryIORec(Handle); + Result := Count; + if Rec.Position + Count > Rec.Size then + Result := Rec.Size - Rec.Position; + Move(Rec.Data[Rec.Position], Buffer^, Result); + Rec.Position := Rec.Position + Result; +end; + +function MemoryWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl; +var + Rec: PMemoryIORec; +begin + Rec := PMemoryIORec(Handle); + Result := Count; + if Rec.Position + Count > Rec.Size then + Result := Rec.Size - Rec.Position; + Move(Buffer^, Rec.Data[Rec.Position], Result); + Rec.Position := Rec.Position + Result; +end; + +{ Helper IO functions } + +function GetInputSize(const IOFunctions: TIOFunctions; Handle: TImagingHandle): Int64; +var + OldPos: Int64; +begin + OldPos := IOFunctions.Tell(Handle); + IOFunctions.Seek(Handle, 0, smFromEnd); + Result := IOFunctions.Tell(Handle); + IOFunctions.Seek(Handle, OldPos, smFromBeginning); +end; + +function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec; +begin + Result.Data := Data; + Result.Position := 0; + Result.Size := Size; +end; + +function ReadLine(const IOFunctions: TIOFunctions; Handle: TImagingHandle; + out Line: AnsiString; FailOnControlChars: Boolean): Boolean; +const + MaxLine = 1024; +var + EolPos, Pos: Integer; + C: AnsiChar; + EolReached: Boolean; + Endings: set of AnsiChar; +begin + Line := ''; + Pos := 0; + EolPos := 0; + EolReached := False; + Endings := [#10, #13]; + Result := True; + + while not IOFunctions.Eof(Handle) do + begin + IOFunctions.Read(Handle, @C, SizeOf(C)); + + if FailOnControlChars and (Byte(C) < $20) then + begin + Break; + end; + + if not (C in Endings) then + begin + if EolReached then + begin + IOFunctions.Seek(Handle, EolPos, smFromBeginning); + Exit; + end + else + begin + SetLength(Line, Length(Line) + 1); + Line[Length(Line)] := C; + end; + end + else if not EolReached then + begin + EolReached := True; + EolPos := IOFunctions.Tell(Handle); + end; + + Inc(Pos); + if Pos >= MaxLine then + begin + Break; + end; + end; + + Result := False; + IOFunctions.Seek(Handle, -Pos, smFromCurrent); +end; + +procedure WriteLine(const IOFunctions: TIOFunctions; Handle: TImagingHandle; + const Line: AnsiString; const LineEnding: AnsiString); +var + ToWrite: AnsiString; +begin + ToWrite := Line + LineEnding; + IOFunctions.Write(Handle, @ToWrite[1], Length(ToWrite)); +end; + +{ TReadMemoryStream } + +constructor TReadMemoryStream.Create(Data: Pointer; Size: Integer); +begin + SetPointer(Data, Size); +end; + +class function TReadMemoryStream.CreateFromIOHandle(const IOFunctions: TIOFunctions; Handle: TImagingHandle): TReadMemoryStream; +var + Data: Pointer; + Size: Integer; +begin + Size := GetInputSize(IOFunctions, Handle); + GetMem(Data, Size); + IOFunctions.Read(Handle, Data, Size); + Result := TReadMemoryStream.Create(Data, Size); +end; + +{ TImagingIOStream } + +constructor TImagingIOStream.Create(const IOFunctions: TIOFunctions; + Handle: TImagingHandle); +begin + +end; + +initialization + OriginalFileIO.Open := FileOpen; + OriginalFileIO.Close := FileClose; + OriginalFileIO.Eof := FileEof; + OriginalFileIO.Seek := FileSeek; + OriginalFileIO.Tell := FileTell; + OriginalFileIO.Read := FileRead; + OriginalFileIO.Write := FileWrite; + + StreamIO.Open := StreamOpen; + StreamIO.Close := StreamClose; + StreamIO.Eof := StreamEof; + StreamIO.Seek := StreamSeek; + StreamIO.Tell := StreamTell; + StreamIO.Read := StreamRead; + StreamIO.Write := StreamWrite; + + MemoryIO.Open := MemoryOpen; + MemoryIO.Close := MemoryClose; + MemoryIO.Eof := MemoryEof; + MemoryIO.Seek := MemorySeek; + MemoryIO.Tell := MemoryTell; + MemoryIO.Read := MemoryRead; + MemoryIO.Write := MemoryWrite; + + ResetFileIO; + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - nothing now + + -- 0.77.3 --------------------------------------------------- + - IO functions now have 64bit sizes and offsets. + - Added helper classes TReadMemoryStream and TImagingIOStream. + + -- 0.77.1 --------------------------------------------------- + - Updated IO Open functions according to changes in ImagingTypes. + - Added ReadLine and WriteLine functions. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Added merge between buffered read-only and write-only file + stream adapters - TIFF saving needed both reading and writing. + - Fixed bug causing wrong value of TBufferedWriteFile.Size + (needed to add buffer pos to size). + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Removed TMemoryIORec.Written, use Position to get proper memory + position (Written didn't take Seeks into account). + - Added TBufferedReadFile and TBufferedWriteFile classes for + buffered file reading/writing. File IO functions now use these + classes resulting in performance increase mainly in file formats + that read/write many small chunks. + - Added fmShareDenyWrite to FileOpenRead. You can now read + files opened for reading by Imaging from other apps. + - Added GetInputSize and PrepareMemIO helper functions. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - changed behaviour of MemorySeek to act as TStream + based Seeks +} +end. + diff --git a/Imaging/ImagingJpeg.pas b/Imaging/ImagingJpeg.pas index 35d2281..d25d096 100644 --- a/Imaging/ImagingJpeg.pas +++ b/Imaging/ImagingJpeg.pas @@ -1,597 +1,749 @@ -{ - $Id: ImagingJpeg.pas 168 2009-08-22 18:50:21Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains image format loader/saver for Jpeg images.} -unit ImagingJpeg; - -{$I ImagingOptions.inc} - -{ You can choose which Pascal JpegLib implementation will be used. - IMJPEGLIB is version bundled with Imaging which works with all supported - compilers and platforms. - PASJPEG is original JpegLib translation or version modified for FPC - (and shipped with it). You can use PASJPEG if this version is already - linked with another part of your program and you don't want to have - two quite large almost the same libraries linked to your exe. - This is the case with Lazarus applications for example.} - -{$DEFINE IMJPEGLIB} -{ $DEFINE PASJPEG} - -{ Automatically use FPC's PasJpeg when compiling with Lazarus. But not when - WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html} -{$IF Defined(LCL) and not Defined(WINDOWS)} - {$UNDEF IMJPEGLIB} - {$DEFINE PASJPEG} -{$IFEND} - -interface - -uses - SysUtils, ImagingTypes, Imaging, ImagingColors, -{$IF Defined(IMJPEGLIB)} - imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjdeferr, imjerror, - imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam, -{$ELSEIF Defined(PASJPEG)} - jpeglib, jmorecfg, jcomapi, jdapimin, jdeferr, jerror, - jdapistd, jcapimin, jcapistd, jdmarker, jcparam, -{$IFEND} - ImagingUtility; - -{$IF Defined(FPC) and Defined(PASJPEG)} - { When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB} - {$DEFINE RGBSWAPPED} -{$IFEND} - -type - { Class for loading/saving Jpeg images. Supports load/save of - 8 bit grayscale and 24 bit RGB images. Jpegs can be saved with optional - progressive encoding. - Based on IJG's JpegLib so doesn't support alpha channels and lossless - coding.} - TJpegFileFormat = class(TImageFileFormat) - private - FGrayScale: Boolean; - protected - FQuality: LongInt; - FProgressive: LongBool; - procedure SetJpegIO(const JpegIO: TIOFunctions); virtual; - function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean): Boolean; override; - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); override; - public - constructor Create; override; - function TestFormat(Handle: TImagingHandle): Boolean; override; - procedure CheckOptionsValidity; override; - published - { Controls Jpeg save compression quality. It is number in range 1..100. - 1 means small/ugly file, 100 means large/nice file. Accessible trough - ImagingJpegQuality option.} - property Quality: LongInt read FQuality write FQuality; - { If True Jpeg images are saved in progressive format. Accessible trough - ImagingJpegProgressive option.} - property Progressive: LongBool read FProgressive write FProgressive; - end; - -implementation - -const - SJpegFormatName = 'Joint Photographic Experts Group Image'; - SJpegMasks = '*.jpg,*.jpeg,*.jfif,*.jpe,*.jif'; - JpegSupportedFormats: TImageFormats = [ifR8G8B8, ifGray8]; - JpegDefaultQuality = 90; - JpegDefaultProgressive = False; - -const - { Jpeg file identifiers.} - JpegMagic: TChar2 = #$FF#$D8; - BufferSize = 16384; - -resourcestring - SJpegError = 'JPEG Error'; - -type - TJpegContext = record - case Byte of - 0: (common: jpeg_common_struct); - 1: (d: jpeg_decompress_struct); - 2: (c: jpeg_compress_struct); - end; - - TSourceMgr = record - Pub: jpeg_source_mgr; - Input: TImagingHandle; - Buffer: JOCTETPTR; - StartOfFile: Boolean; - end; - PSourceMgr = ^TSourceMgr; - - TDestMgr = record - Pub: jpeg_destination_mgr; - Output: TImagingHandle; - Buffer: JOCTETPTR; - end; - PDestMgr = ^TDestMgr; - -var - JIO: TIOFunctions; - JpegErrorMgr: jpeg_error_mgr; - -{ Intenal unit jpeglib support functions } - -procedure JpegError(CInfo: j_common_ptr); -var - Buffer: string; -begin - { Create the message and raise exception } - CInfo^.err^.format_message(CInfo, buffer); - raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]); -end; - -procedure OutputMessage(CurInfo: j_common_ptr); -begin -end; - -procedure ReleaseContext(var jc: TJpegContext); -begin - if jc.common.err = nil then - Exit; - jpeg_destroy(@jc.common); - jpeg_destroy_decompress(@jc.d); - jpeg_destroy_compress(@jc.c); - jc.common.err := nil; -end; - -procedure InitSource(cinfo: j_decompress_ptr); -begin - PSourceMgr(cinfo.src).StartOfFile := True; -end; - -function FillInputBuffer(cinfo: j_decompress_ptr): Boolean; -var - NBytes: LongInt; - Src: PSourceMgr; -begin - Src := PSourceMgr(cinfo.src); - NBytes := JIO.Read(Src.Input, Src.Buffer, BufferSize); - - if NBytes <= 0 then - begin - PChar(Src.Buffer)[0] := #$FF; - PChar(Src.Buffer)[1] := Char(JPEG_EOI); - NBytes := 2; - end; - Src.Pub.next_input_byte := Src.Buffer; - Src.Pub.bytes_in_buffer := NBytes; - Src.StartOfFile := False; - Result := True; -end; - -procedure SkipInputData(cinfo: j_decompress_ptr; num_bytes: LongInt); -var - Src: PSourceMgr; -begin - Src := PSourceMgr(cinfo.src); - if num_bytes > 0 then - begin - while num_bytes > Src.Pub.bytes_in_buffer do - begin - Dec(num_bytes, Src.Pub.bytes_in_buffer); - FillInputBuffer(cinfo); - end; - Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes]; - //Inc(LongInt(Src.Pub.next_input_byte), num_bytes); - Dec(Src.Pub.bytes_in_buffer, num_bytes); - end; -end; - -procedure TermSource(cinfo: j_decompress_ptr); -var - Src: PSourceMgr; -begin - Src := PSourceMgr(cinfo.src); - // Move stream position back just after EOI marker so that more that one - // JPEG images can be loaded from one stream - JIO.Seek(Src.Input, -Src.Pub.bytes_in_buffer, smFromCurrent); -end; - -procedure JpegStdioSrc(var cinfo: jpeg_decompress_struct; Handle: - TImagingHandle); -var - Src: PSourceMgr; -begin - if cinfo.src = nil then - begin - cinfo.src := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT, - SizeOf(TSourceMgr)); - Src := PSourceMgr(cinfo.src); - Src.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT, - BufferSize * SizeOf(JOCTET)); - end; - Src := PSourceMgr(cinfo.src); - Src.Pub.init_source := InitSource; - Src.Pub.fill_input_buffer := FillInputBuffer; - Src.Pub.skip_input_data := SkipInputData; - Src.Pub.resync_to_restart := jpeg_resync_to_restart; - Src.Pub.term_source := TermSource; - Src.Input := Handle; - Src.Pub.bytes_in_buffer := 0; - Src.Pub.next_input_byte := nil; -end; - -procedure InitDest(cinfo: j_compress_ptr); -var - Dest: PDestMgr; -begin - Dest := PDestMgr(cinfo.dest); - Dest.Pub.next_output_byte := Dest.Buffer; - Dest.Pub.free_in_buffer := BufferSize; -end; - -function EmptyOutput(cinfo: j_compress_ptr): Boolean; -var - Dest: PDestMgr; -begin - Dest := PDestMgr(cinfo.dest); - JIO.Write(Dest.Output, Dest.Buffer, BufferSize); - Dest.Pub.next_output_byte := Dest.Buffer; - Dest.Pub.free_in_buffer := BufferSize; - Result := True; -end; - -procedure TermDest(cinfo: j_compress_ptr); -var - Dest: PDestMgr; - DataCount: LongInt; -begin - Dest := PDestMgr(cinfo.dest); - DataCount := BufferSize - Dest.Pub.free_in_buffer; - if DataCount > 0 then - JIO.Write(Dest.Output, Dest.Buffer, DataCount); -end; - -procedure JpegStdioDest(var cinfo: jpeg_compress_struct; Handle: - TImagingHandle); -var - Dest: PDestMgr; -begin - if cinfo.dest = nil then - cinfo.dest := cinfo.mem.alloc_small(j_common_ptr(@cinfo), - JPOOL_PERMANENT, SizeOf(TDestMgr)); - Dest := PDestMgr(cinfo.dest); - Dest.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_IMAGE, - BufferSize * SIZEOF(JOCTET)); - Dest.Pub.init_destination := InitDest; - Dest.Pub.empty_output_buffer := EmptyOutput; - Dest.Pub.term_destination := TermDest; - Dest.Output := Handle; -end; - -procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext); -begin - FillChar(jc, sizeof(jc), 0); - // Set standard error handlers and then override some - jc.common.err := jpeg_std_error(JpegErrorMgr); - jc.common.err.error_exit := JpegError; - jc.common.err.output_message := OutputMessage; - - jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d)); - JpegStdioSrc(jc.d, Handle); - jpeg_read_header(@jc.d, True); - jc.d.scale_num := 1; - jc.d.scale_denom := 1; - jc.d.do_block_smoothing := True; - if jc.d.out_color_space = JCS_GRAYSCALE then - begin - jc.d.quantize_colors := True; - jc.d.desired_number_of_colors := 256; - end; -end; - -procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext; - Saver: TJpegFileFormat); -begin - FillChar(jc, sizeof(jc), 0); - // Set standard error handlers and then override some - jc.common.err := jpeg_std_error(JpegErrorMgr); - jc.common.err.error_exit := JpegError; - jc.common.err.output_message := OutputMessage; - - jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c)); - JpegStdioDest(jc.c, Handle); - if Saver.FGrayScale then - jc.c.in_color_space := JCS_GRAYSCALE - else - jc.c.in_color_space := JCS_YCbCr; - jpeg_set_defaults(@jc.c); - jpeg_set_quality(@jc.c, Saver.FQuality, True); - if Saver.FProgressive then - jpeg_simple_progression(@jc.c); -end; - -{ TJpegFileFormat class implementation } - -constructor TJpegFileFormat.Create; -begin - inherited Create; - FName := SJpegFormatName; - FCanLoad := True; - FCanSave := True; - FIsMultiImageFormat := False; - FSupportedFormats := JpegSupportedFormats; - - FQuality := JpegDefaultQuality; - FProgressive := JpegDefaultProgressive; - - AddMasks(SJpegMasks); - RegisterOption(ImagingJpegQuality, @FQuality); - RegisterOption(ImagingJpegProgressive, @FProgressive); -end; - -procedure TJpegFileFormat.CheckOptionsValidity; -begin - // Check if option values are valid - if not (FQuality in [1..100]) then - FQuality := JpegDefaultQuality; -end; - -function TJpegFileFormat.LoadData(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - PtrInc, LinesPerCall, LinesRead, I: Integer; - Dest: PByte; - jc: TJpegContext; - Info: TImageFormatInfo; - Col32: PColor32Rec; -{$IFDEF RGBSWAPPED} - Pix: PColor24Rec; -{$ENDIF} -begin - // Copy IO functions to global var used in JpegLib callbacks - Result := False; - SetJpegIO(GetIO); - SetLength(Images, 1); - - with JIO, Images[0] do - try - InitDecompressor(Handle, jc); - case jc.d.out_color_space of - JCS_GRAYSCALE: Format := ifGray8; - JCS_RGB: Format := ifR8G8B8; - JCS_CMYK: Format := ifA8R8G8B8; - else - Exit; - end; - NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]); - jpeg_start_decompress(@jc.d); - GetImageFormatInfo(Format, Info); - PtrInc := Width * Info.BytesPerPixel; - LinesPerCall := 1; - Dest := Bits; - - while jc.d.output_scanline < jc.d.output_height do - begin - LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall); - {$IFDEF RGBSWAPPED} - if Format = ifR8G8B8 then - begin - Pix := PColor24Rec(Dest); - for I := 0 to Width - 1 do - begin - SwapValues(Pix.R, Pix.B); - Inc(Pix); - end; - end; - {$ENDIF} - Inc(Dest, PtrInc * LinesRead); - end; - - if jc.d.out_color_space = JCS_CMYK then - begin - Col32 := Bits; - // Translate from CMYK to RGB - for I := 0 to Width * Height - 1 do - begin - CMYKToRGB(255 - Col32.B, 255 - Col32.G, 255 - Col32.R, 255 - Col32.A, - Col32.R, Col32.G, Col32.B); - Col32.A := 255; - Inc(Col32); - end; - end; - - jpeg_finish_output(@jc.d); - jpeg_finish_decompress(@jc.d); - Result := True; - finally - ReleaseContext(jc); - end; -end; - -function TJpegFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: LongInt): Boolean; -var - PtrInc, LinesWritten: LongInt; - Src, Line: PByte; - jc: TJpegContext; - ImageToSave: TImageData; - Info: TImageFormatInfo; - MustBeFreed: Boolean; -{$IFDEF RGBSWAPPED} - I: LongInt; - Pix: PColor24Rec; -{$ENDIF} -begin - Result := False; - // Copy IO functions to global var used in JpegLib callbacks - SetJpegIO(GetIO); - // Makes image to save compatible with Jpeg saving capabilities - if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then - with JIO, ImageToSave do - try - GetImageFormatInfo(Format, Info); - FGrayScale := Format = ifGray8; - InitCompressor(Handle, jc, Self); - jc.c.image_width := Width; - jc.c.image_height := Height; - if FGrayScale then - begin - jc.c.input_components := 1; - jc.c.in_color_space := JCS_GRAYSCALE; - end - else - begin - jc.c.input_components := 3; - jc.c.in_color_space := JCS_RGB; - end; - - PtrInc := Width * Info.BytesPerPixel; - Src := Bits; - - {$IFDEF RGBSWAPPED} - GetMem(Line, PtrInc); - {$ENDIF} - - jpeg_start_compress(@jc.c, True); - while (jc.c.next_scanline < jc.c.image_height) do - begin - {$IFDEF RGBSWAPPED} - if Format = ifR8G8B8 then - begin - Move(Src^, Line^, PtrInc); - Pix := PColor24Rec(Line); - for I := 0 to Width - 1 do - begin - SwapValues(Pix.R, Pix.B); - Inc(Pix, 1); - end; - end; - {$ELSE} - Line := Src; - {$ENDIF} - - LinesWritten := jpeg_write_scanlines(@jc.c, @Line, 1); - Inc(Src, PtrInc * LinesWritten); - end; - - jpeg_finish_compress(@jc.c); - Result := True; - finally - ReleaseContext(jc); - if MustBeFreed then - FreeImage(ImageToSave); - {$IFDEF RGBSWAPPED} - FreeMem(Line); - {$ENDIF} - end; -end; - -procedure TJpegFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -begin - if Info.HasGrayChannel then - ConvertImage(Image, ifGray8) - else - ConvertImage(Image, ifR8G8B8); -end; - -function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean; -var - ReadCount: LongInt; - ID: array[0..9] of AnsiChar; -begin - Result := False; - if Handle <> nil then - with GetIO do - begin - FillChar(ID, SizeOf(ID), 0); - ReadCount := Read(Handle, @ID, SizeOf(ID)); - Seek(Handle, -ReadCount, smFromCurrent); - Result := (ReadCount = SizeOf(ID)) and - CompareMem(@ID, @JpegMagic, SizeOf(JpegMagic)); - end; -end; - -procedure TJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions); -begin - JIO := JpegIO; -end; - -initialization - RegisterImageFileFormat(TJpegFileFormat); - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.26.3 Changes/Bug Fixes --------------------------------- - - Changed the Jpeg error manager, messages were not properly formated. - - -- 0.26.1 Changes/Bug Fixes --------------------------------- - - Fixed wrong color space setting in InitCompressor. - - Fixed problem with progressive Jpegs in FPC (modified JpegLib, - can't use FPC's PasJpeg in Windows). - - -- 0.25.0 Changes/Bug Fixes --------------------------------- - - FPC's PasJpeg wasn't really used in last version, fixed. - - -- 0.24.1 Changes/Bug Fixes --------------------------------- - - Fixed loading of CMYK jpeg images. Could cause heap corruption - and loaded image looked wrong. - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Removed JFIF/EXIF detection from TestFormat. Found JPEGs - with different headers (Lavc) which weren't recognized. - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - MakeCompatible method moved to base class, put ConvertToSupported here. - GetSupportedFormats removed, it is now set in constructor. - - Made public properties for options registered to SetOption/GetOption - functions. - - Changed extensions to filename masks. - - Changed SaveData, LoadData, and MakeCompatible methods according - to changes in base class in Imaging unit. - - Changes in TestFormat, now reads JFIF and EXIF signatures too. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - input position is now set correctly to the end of the image - after loading is done. Loading of sequence of JPEG files stored in - single stream works now - - when loading and saving images in FPC with PASJPEG read and - blue channels are swapped to have the same chanel order as IMJPEGLIB - - you can now choose between IMJPEGLIB and PASJPEG implementations - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - added SetJpegIO method which is used by JNG image format -} -end. - +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains image format loader/saver for Jpeg images.} +unit ImagingJpeg; + +{$I ImagingOptions.inc} + +{ You can choose which Pascal JpegLib implementation will be used. + IMJPEGLIB is version bundled with Imaging which works with all supported + compilers and platforms. + PASJPEG is original JpegLib translation or version modified for FPC + (and shipped with it). You can use PASJPEG if this version is already + linked with another part of your program and you don't want to have + two quite large almost the same libraries linked to your exe. + This is the case with Lazarus applications for example.} + +{$DEFINE IMJPEGLIB} +{ $DEFINE PASJPEG} + +{ Automatically use FPC's PasJpeg when compiling with Lazarus. } +{$IF Defined(LCL)} + {$UNDEF IMJPEGLIB} + {$DEFINE PASJPEG} +{$IFEND} + +{ We usually want to skip the rest of the corrupted file when loading JPEG files + instead of getting exception. JpegLib's error handler can only be + exited using setjmp/longjmp ("non-local goto") functions to get error + recovery when loading corrupted JPEG files. This is implemented in assembler + and currently available only for 32bit Delphi targets and FPC.} +{$DEFINE ErrorJmpRecovery} +{$IF Defined(DCC) and not Defined(CPUX86)} + {$UNDEF ErrorJmpRecovery} +{$IFEND} + +interface + +uses + SysUtils, ImagingTypes, Imaging, ImagingColors, +{$IF Defined(IMJPEGLIB)} + imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjdeferr, imjerror, + imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam, +{$ELSEIF Defined(PASJPEG)} + jpeglib, jmorecfg, jcomapi, jdapimin, jdeferr, jerror, + jdapistd, jcapimin, jcapistd, jdmarker, jcparam, +{$IFEND} + ImagingUtility; + +{$IF Defined(FPC) and Defined(PASJPEG)} + { When using FPC's pasjpeg the channel order is BGR instead of RGB. + See RGB_RED_IS_0 in jconfig.inc. } + {$DEFINE RGBSWAPPED} +{$IFEND} + +type + { Class for loading/saving Jpeg images. Supports load/save of + 8 bit grayscale and 24 bit RGB images. Jpegs can be saved with optional + progressive encoding. + Based on IJG's JpegLib so doesn't support alpha channels and lossless + coding.} + TJpegFileFormat = class(TImageFileFormat) + private + FGrayScale: Boolean; + protected + FQuality: LongInt; + FProgressive: LongBool; + procedure SetJpegIO(const JpegIO: TIOFunctions); virtual; + procedure Define; override; + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean): Boolean; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + public + function TestFormat(Handle: TImagingHandle): Boolean; override; + procedure CheckOptionsValidity; override; + published + { Controls Jpeg save compression quality. It is number in range 1..100. + 1 means small/ugly file, 100 means large/nice file. Accessible trough + ImagingJpegQuality option.} + property Quality: LongInt read FQuality write FQuality; + { If True Jpeg images are saved in progressive format. Accessible trough + ImagingJpegProgressive option.} + property Progressive: LongBool read FProgressive write FProgressive; + end; + +implementation + +const + SJpegFormatName = 'Joint Photographic Experts Group Image'; + SJpegMasks = '*.jpg,*.jpeg,*.jfif,*.jpe,*.jif'; + JpegSupportedFormats: TImageFormats = [ifR8G8B8, ifGray8]; + JpegDefaultQuality = 90; + JpegDefaultProgressive = False; + +const + { Jpeg file identifiers.} + JpegMagic: TChar2 = #$FF#$D8; + BufferSize = 16384; + +resourcestring + SJpegError = 'JPEG Error'; + +type + TJpegContext = record + case Byte of + 0: (common: jpeg_common_struct); + 1: (d: jpeg_decompress_struct); + 2: (c: jpeg_compress_struct); + end; + + TSourceMgr = record + Pub: jpeg_source_mgr; + Input: TImagingHandle; + Buffer: JOCTETPTR; + StartOfFile: Boolean; + end; + PSourceMgr = ^TSourceMgr; + + TDestMgr = record + Pub: jpeg_destination_mgr; + Output: TImagingHandle; + Buffer: JOCTETPTR; + end; + PDestMgr = ^TDestMgr; + +var + JIO: TIOFunctions; + JpegErrorMgr: jpeg_error_mgr; + +{ Internal unit jpeglib support functions } + +{$IFDEF ErrorJmpRecovery} + {$IFDEF DCC} + type + jmp_buf = record + EBX, + ESI, + EDI, + ESP, + EBP, + EIP: UInt32; + end; + pjmp_buf = ^jmp_buf; + + { JmpLib SetJmp/LongJmp Library + (C)Copyright 2003, 2004 Will DeWitt Jr. } + function SetJmp(out jmpb: jmp_buf): Integer; + asm + { -> EAX jmpb } + { <- EAX Result } + MOV EDX, [ESP] // Fetch return address (EIP) + // Save task state + MOV [EAX+jmp_buf.&EBX], EBX + MOV [EAX+jmp_buf.&ESI], ESI + MOV [EAX+jmp_buf.&EDI], EDI + MOV [EAX+jmp_buf.&ESP], ESP + MOV [EAX+jmp_buf.&EBP], EBP + MOV [EAX+jmp_buf.&EIP], EDX + + SUB EAX, EAX + @@1: + end; + + procedure LongJmp(const jmpb: jmp_buf; retval: Integer); + asm + { -> EAX jmpb } + { EDX retval } + { <- EAX Result } + XCHG EDX, EAX + + MOV ECX, [EDX+jmp_buf.&EIP] + // Restore task state + MOV EBX, [EDX+jmp_buf.&EBX] + MOV ESI, [EDX+jmp_buf.&ESI] + MOV EDI, [EDX+jmp_buf.&EDI] + MOV ESP, [EDX+jmp_buf.&ESP] + MOV EBP, [EDX+jmp_buf.&EBP] + MOV [ESP], ECX // Restore return address (EIP) + + TEST EAX, EAX // Ensure retval is <> 0 + JNZ @@1 + MOV EAX, 1 + @@1: + end; + {$ENDIF} + +type + TJmpBuf = jmp_buf; + TErrorClientData = record + JmpBuf: TJmpBuf; + ScanlineReadReached: Boolean; + end; + PErrorClientData = ^TErrorClientData; +{$ENDIF} + +procedure JpegError(CInfo: j_common_ptr); + + procedure RaiseError; + var + Buffer: AnsiString; + begin + // Create the message and raise exception + CInfo.err.format_message(CInfo, Buffer); + // Warning: you can get "Invalid argument index in format" exception when + // using FPC (see http://bugs.freepascal.org/view.php?id=21229). + // Fixed in FPC 2.7.1 + {$IF Defined(FPC) and (FPC_FULLVERSION <= 20701)} + raise EImagingError.CreateFmt(SJPEGError + ' %d', [CInfo.err.msg_code]); + {$ELSE} + raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + string(Buffer), [CInfo.err.msg_code]); + {$IFEND} + end; + +begin +{$IFDEF ErrorJmpRecovery} + // Only recovers on loads and when header is successfully loaded + // (error occurs when reading scanlines) + if (CInfo.client_data <> nil) and + PErrorClientData(CInfo.client_data).ScanlineReadReached then + begin + // Non-local jump to error handler in TJpegFileFormat.LoadData + longjmp(PErrorClientData(CInfo.client_data).JmpBuf, 1) + end + else + RaiseError; +{$ELSE} + RaiseError; +{$ENDIF} +end; + +procedure OutputMessage(CurInfo: j_common_ptr); +begin +end; + +procedure ReleaseContext(var jc: TJpegContext); +begin + if jc.common.err = nil then + Exit; + jpeg_destroy(@jc.common); + jpeg_destroy_decompress(@jc.d); + jpeg_destroy_compress(@jc.c); + jc.common.err := nil; +end; + +procedure InitSource(cinfo: j_decompress_ptr); +begin + PSourceMgr(cinfo.src).StartOfFile := True; +end; + +function FillInputBuffer(cinfo: j_decompress_ptr): Boolean; +var + NBytes: LongInt; + Src: PSourceMgr; +begin + Src := PSourceMgr(cinfo.src); + NBytes := JIO.Read(Src.Input, Src.Buffer, BufferSize); + + if NBytes <= 0 then + begin + PByteArray(Src.Buffer)[0] := $FF; + PByteArray(Src.Buffer)[1] := JPEG_EOI; + NBytes := 2; + end; + Src.Pub.next_input_byte := Src.Buffer; + Src.Pub.bytes_in_buffer := NBytes; + Src.StartOfFile := False; + Result := True; +end; + +procedure SkipInputData(cinfo: j_decompress_ptr; num_bytes: LongInt); +var + Src: PSourceMgr; +begin + Src := PSourceMgr(cinfo.src); + if num_bytes > 0 then + begin + while num_bytes > Src.Pub.bytes_in_buffer do + begin + Dec(num_bytes, Src.Pub.bytes_in_buffer); + FillInputBuffer(cinfo); + end; + Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes]; + //Inc(LongInt(Src.Pub.next_input_byte), num_bytes); + Dec(Src.Pub.bytes_in_buffer, num_bytes); + end; +end; + +procedure TermSource(cinfo: j_decompress_ptr); +var + Src: PSourceMgr; +begin + Src := PSourceMgr(cinfo.src); + // Move stream position back just after EOI marker so that more that one + // JPEG images can be loaded from one stream + JIO.Seek(Src.Input, -Src.Pub.bytes_in_buffer, smFromCurrent); +end; + +procedure JpegStdioSrc(var cinfo: jpeg_decompress_struct; Handle: + TImagingHandle); +var + Src: PSourceMgr; +begin + if cinfo.src = nil then + begin + cinfo.src := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT, + SizeOf(TSourceMgr)); + Src := PSourceMgr(cinfo.src); + Src.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT, + BufferSize * SizeOf(JOCTET)); + end; + Src := PSourceMgr(cinfo.src); + Src.Pub.init_source := InitSource; + Src.Pub.fill_input_buffer := FillInputBuffer; + Src.Pub.skip_input_data := SkipInputData; + Src.Pub.resync_to_restart := jpeg_resync_to_restart; + Src.Pub.term_source := TermSource; + Src.Input := Handle; + Src.Pub.bytes_in_buffer := 0; + Src.Pub.next_input_byte := nil; +end; + +procedure InitDest(cinfo: j_compress_ptr); +var + Dest: PDestMgr; +begin + Dest := PDestMgr(cinfo.dest); + Dest.Pub.next_output_byte := Dest.Buffer; + Dest.Pub.free_in_buffer := BufferSize; +end; + +function EmptyOutput(cinfo: j_compress_ptr): Boolean; +var + Dest: PDestMgr; +begin + Dest := PDestMgr(cinfo.dest); + JIO.Write(Dest.Output, Dest.Buffer, BufferSize); + Dest.Pub.next_output_byte := Dest.Buffer; + Dest.Pub.free_in_buffer := BufferSize; + Result := True; +end; + +procedure TermDest(cinfo: j_compress_ptr); +var + Dest: PDestMgr; + DataCount: LongInt; +begin + Dest := PDestMgr(cinfo.dest); + DataCount := BufferSize - Dest.Pub.free_in_buffer; + if DataCount > 0 then + JIO.Write(Dest.Output, Dest.Buffer, DataCount); +end; + +procedure JpegStdioDest(var cinfo: jpeg_compress_struct; Handle: + TImagingHandle); +var + Dest: PDestMgr; +begin + if cinfo.dest = nil then + cinfo.dest := cinfo.mem.alloc_small(j_common_ptr(@cinfo), + JPOOL_PERMANENT, SizeOf(TDestMgr)); + Dest := PDestMgr(cinfo.dest); + Dest.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_IMAGE, + BufferSize * SIZEOF(JOCTET)); + Dest.Pub.init_destination := InitDest; + Dest.Pub.empty_output_buffer := EmptyOutput; + Dest.Pub.term_destination := TermDest; + Dest.Output := Handle; +end; + +procedure SetupErrorMgr(var jc: TJpegContext); +begin + // Set standard error handlers and then override some + jc.common.err := jpeg_std_error(JpegErrorMgr); + jc.common.err.error_exit := JpegError; + jc.common.err.output_message := OutputMessage; +end; + +procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext); +begin + jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d)); + JpegStdioSrc(jc.d, Handle); + jpeg_read_header(@jc.d, True); + jc.d.scale_num := 1; + jc.d.scale_denom := 1; + jc.d.do_block_smoothing := True; + if jc.d.out_color_space = JCS_GRAYSCALE then + begin + jc.d.quantize_colors := True; + jc.d.desired_number_of_colors := 256; + end; +end; + +procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext; + Saver: TJpegFileFormat); +begin + jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c)); + JpegStdioDest(jc.c, Handle); + if Saver.FGrayScale then + jc.c.in_color_space := JCS_GRAYSCALE + else + jc.c.in_color_space := JCS_RGB; + jpeg_set_defaults(@jc.c); + jpeg_set_quality(@jc.c, Saver.FQuality, True); + if Saver.FProgressive then + jpeg_simple_progression(@jc.c); +end; + +{ TJpegFileFormat class implementation } + +procedure TJpegFileFormat.Define; +begin + FName := SJpegFormatName; + FFeatures := [ffLoad, ffSave]; + FSupportedFormats := JpegSupportedFormats; + + FQuality := JpegDefaultQuality; + FProgressive := JpegDefaultProgressive; + + AddMasks(SJpegMasks); + RegisterOption(ImagingJpegQuality, @FQuality); + RegisterOption(ImagingJpegProgressive, @FProgressive); +end; + +procedure TJpegFileFormat.CheckOptionsValidity; +begin + // Check if option values are valid + if not (FQuality in [1..100]) then + FQuality := JpegDefaultQuality; +end; + +function TJpegFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + PtrInc, LinesPerCall, LinesRead, I: Integer; + Dest: PByte; + jc: TJpegContext; + Info: TImageFormatInfo; + Col32: PColor32Rec; + NeedsRedBlueSwap: Boolean; + Pix: PColor24Rec; +{$IFDEF ErrorJmpRecovery} + ErrorClient: TErrorClientData; +{$ENDIF} + + procedure LoadMetaData; + var + ResUnit: TResolutionUnit; + begin + // Density unit: 0 - undef, 1 - inch, 2 - cm + if jc.d.saw_JFIF_marker and (jc.d.density_unit > 0) and + (jc.d.X_density > 0) and (jc.d.Y_density > 0) then + begin + ResUnit := ruDpi; + if jc.d.density_unit = 2 then + ResUnit := ruDpcm; + FMetadata.SetPhysicalPixelSize(ResUnit, jc.d.X_density, jc.d.Y_density); + end; + end; + +begin + // Copy IO functions to global var used in JpegLib callbacks + Result := False; + SetJpegIO(GetIO); + SetLength(Images, 1); + + with JIO, Images[0] do + try + ZeroMemory(@jc, SizeOf(jc)); + SetupErrorMgr(jc); + {$IFDEF ErrorJmpRecovery} + ZeroMemory(@ErrorClient, SizeOf(ErrorClient)); + jc.common.client_data := @ErrorClient; + if setjmp(ErrorClient.JmpBuf) <> 0 then + begin + Result := True; + Exit; + end; + {$ENDIF} + InitDecompressor(Handle, jc); + + case jc.d.out_color_space of + JCS_GRAYSCALE: Format := ifGray8; + JCS_RGB: Format := ifR8G8B8; + JCS_CMYK: Format := ifA8R8G8B8; + else + Exit; + end; + + NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]); + jpeg_start_decompress(@jc.d); + GetImageFormatInfo(Format, Info); + PtrInc := Width * Info.BytesPerPixel; + LinesPerCall := 1; + Dest := Bits; + + // If Jpeg's colorspace is RGB and not YCbCr we need to swap + // R and B to get Imaging's native order + NeedsRedBlueSwap := jc.d.jpeg_color_space = JCS_RGB; + {$IFDEF RGBSWAPPED} + // Force R-B swap for FPC's PasJpeg + NeedsRedBlueSwap := True; + {$ENDIF} + + {$IFDEF ErrorJmpRecovery} + ErrorClient.ScanlineReadReached := True; + {$ENDIF} + + while jc.d.output_scanline < jc.d.output_height do + begin + LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall); + if NeedsRedBlueSwap and (Format = ifR8G8B8) then + begin + Pix := PColor24Rec(Dest); + for I := 0 to Width - 1 do + begin + SwapValues(Pix.R, Pix.B); + Inc(Pix); + end; + end; + Inc(Dest, PtrInc * LinesRead); + end; + + if jc.d.out_color_space = JCS_CMYK then + begin + Col32 := Bits; + // Translate from CMYK to RGB + for I := 0 to Width * Height - 1 do + begin + CMYKToRGB(255 - Col32.B, 255 - Col32.G, 255 - Col32.R, 255 - Col32.A, + Col32.R, Col32.G, Col32.B); + Col32.A := 255; + Inc(Col32); + end; + end; + + // Store supported metadata + LoadMetaData; + + jpeg_finish_output(@jc.d); + jpeg_finish_decompress(@jc.d); + Result := True; + finally + ReleaseContext(jc); + end; +end; + +function TJpegFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + PtrInc, LinesWritten: LongInt; + Src, Line: PByte; + jc: TJpegContext; + ImageToSave: TImageData; + Info: TImageFormatInfo; + MustBeFreed: Boolean; +{$IFDEF RGBSWAPPED} + I: LongInt; + Pix: PColor24Rec; +{$ENDIF} + + procedure SaveMetaData; + var + XRes, YRes: Double; + begin + if FMetadata.GetPhysicalPixelSize(ruDpcm, XRes, YRes, True) then + begin + jc.c.density_unit := 2; // Dots per cm + jc.c.X_density := Round(XRes); + jc.c.Y_density := Round(YRes) + end; + end; + +begin + Result := False; + // Copy IO functions to global var used in JpegLib callbacks + SetJpegIO(GetIO); + + // Makes image to save compatible with Jpeg saving capabilities + if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then + with JIO, ImageToSave do + try + ZeroMemory(@jc, SizeOf(jc)); + SetupErrorMgr(jc); + + GetImageFormatInfo(Format, Info); + FGrayScale := Format = ifGray8; + InitCompressor(Handle, jc, Self); + jc.c.image_width := Width; + jc.c.image_height := Height; + if FGrayScale then + begin + jc.c.input_components := 1; + jc.c.in_color_space := JCS_GRAYSCALE; + end + else + begin + jc.c.input_components := 3; + jc.c.in_color_space := JCS_RGB; + end; + + PtrInc := Width * Info.BytesPerPixel; + Src := Bits; + + {$IFDEF RGBSWAPPED} + GetMem(Line, PtrInc); + {$ENDIF} + + // Save supported metadata + SaveMetaData; + + jpeg_start_compress(@jc.c, True); + while (jc.c.next_scanline < jc.c.image_height) do + begin + {$IFDEF RGBSWAPPED} + if Format = ifR8G8B8 then + begin + Move(Src^, Line^, PtrInc); + Pix := PColor24Rec(Line); + for I := 0 to Width - 1 do + begin + SwapValues(Pix.R, Pix.B); + Inc(Pix, 1); + end; + end; + {$ELSE} + Line := Src; + {$ENDIF} + + LinesWritten := jpeg_write_scanlines(@jc.c, @Line, 1); + Inc(Src, PtrInc * LinesWritten); + end; + + jpeg_finish_compress(@jc.c); + Result := True; + finally + ReleaseContext(jc); + if MustBeFreed then + FreeImage(ImageToSave); + {$IFDEF RGBSWAPPED} + FreeMem(Line); + {$ENDIF} + end; +end; + +procedure TJpegFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +begin + if Info.HasGrayChannel then + ConvertImage(Image, ifGray8) + else + ConvertImage(Image, ifR8G8B8); +end; + +function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean; +var + ReadCount: LongInt; + ID: array[0..9] of AnsiChar; +begin + Result := False; + if Handle <> nil then + with GetIO do + begin + FillChar(ID, SizeOf(ID), 0); + ReadCount := Read(Handle, @ID, SizeOf(ID)); + Seek(Handle, -ReadCount, smFromCurrent); + Result := (ReadCount = SizeOf(ID)) and + CompareMem(@ID, @JpegMagic, SizeOf(JpegMagic)); + end; +end; + +procedure TJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions); +begin + JIO := JpegIO; +end; + +initialization + RegisterImageFileFormat(TJpegFileFormat); + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - nothing now + + -- 0.77.1 --------------------------------------------------- + - Able to read corrupted JPEG files - loads partial image + and skips the corrupted parts (FPC and x86 Delphi). + - Fixed reading of physical resolution metadata, could cause + "divided by zero" later on for some files. + + -- 0.26.5 Changes/Bug Fixes --------------------------------- + - Fixed loading of some JPEGs with certain APPN markers (bug in JpegLib). + - Fixed swapped Red-Blue order when loading Jpegs with + jc.d.jpeg_color_space = JCS_RGB. + - Added loading and saving of physical pixel size metadata. + + -- 0.26.3 Changes/Bug Fixes --------------------------------- + - Changed the Jpeg error manager, messages were not properly formatted. + + -- 0.26.1 Changes/Bug Fixes --------------------------------- + - Fixed wrong color space setting in InitCompressor. + - Fixed problem with progressive Jpegs in FPC (modified JpegLib, + can't use FPC's PasJpeg in Windows). + + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - FPC's PasJpeg wasn't really used in last version, fixed. + + -- 0.24.1 Changes/Bug Fixes --------------------------------- + - Fixed loading of CMYK jpeg images. Could cause heap corruption + and loaded image looked wrong. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Removed JFIF/EXIF detection from TestFormat. Found JPEGs + with different headers (Lavc) which weren't recognized. + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - MakeCompatible method moved to base class, put ConvertToSupported here. + GetSupportedFormats removed, it is now set in constructor. + - Made public properties for options registered to SetOption/GetOption + functions. + - Changed extensions to filename masks. + - Changed SaveData, LoadData, and MakeCompatible methods according + to changes in base class in Imaging unit. + - Changes in TestFormat, now reads JFIF and EXIF signatures too. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - input position is now set correctly to the end of the image + after loading is done. Loading of sequence of JPEG files stored in + single stream works now + - when loading and saving images in FPC with PASJPEG read and + blue channels are swapped to have the same chanel order as IMJPEGLIB + - you can now choose between IMJPEGLIB and PASJPEG implementations + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - added SetJpegIO method which is used by JNG image format +} +end. + diff --git a/Imaging/ImagingNetworkGraphics.pas b/Imaging/ImagingNetworkGraphics.pas index 5b7dc02..c220e25 100644 --- a/Imaging/ImagingNetworkGraphics.pas +++ b/Imaging/ImagingNetworkGraphics.pas @@ -1,2573 +1,2699 @@ -{ - $Id: ImagingNetworkGraphics.pas 171 2009-09-02 01:34:19Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains image format loaders/savers for Network Graphics image - file formats PNG, MNG, and JNG.} -unit ImagingNetworkGraphics; - -interface - -{$I ImagingOptions.inc} - -{ If MN support is enabled we must make sure PNG and JNG are enabled too.} -{$IFNDEF DONT_LINK_MNG} - {$UNDEF DONT_LINK_PNG} - {$UNDEF DONT_LINK_JNG} -{$ENDIF} - -uses - Types, SysUtils, Classes, ImagingTypes, Imaging, ImagingUtility, ImagingFormats, dzlib; - -type - { Basic class for Network Graphics file formats loaders/savers.} - TNetworkGraphicsFileFormat = class(TImageFileFormat) - protected - FSignature: TChar8; - FPreFilter: LongInt; - FCompressLevel: LongInt; - FLossyCompression: LongBool; - FLossyAlpha: LongBool; - FQuality: LongInt; - FProgressive: LongBool; - function GetSupportedFormats: TImageFormats; override; - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); override; - public - constructor Create; override; - function TestFormat(Handle: TImagingHandle): Boolean; override; - procedure CheckOptionsValidity; override; - published - { Sets precompression filter used when saving images with lossless compression. - Allowed values are: 0 (none), 1 (sub), 2 (up), 3 (average), 4 (paeth), - 5 (use 0 for indexed/gray images and 4 for RGB/ARGB images), - 6 (adaptive filtering - use best filter for each scanline - very slow). - Note that filters 3 and 4 are much slower than filters 1 and 2. - Default value is 5.} - property PreFilter: LongInt read FPreFilter write FPreFilter; - { Sets ZLib compression level used when saving images with lossless compression. - Allowed values are in range 0 (no compresstion) to 9 (best compression). - Default value is 5.} - property CompressLevel: LongInt read FCompressLevel write FCompressLevel; - { Specifies whether MNG animation frames are saved with lossy or lossless - compression. Lossless frames are saved as PNG images and lossy frames are - saved as JNG images. Allowed values are 0 (False) and 1 (True). - Default value is 0.} - property LossyCompression: LongBool read FLossyCompression write FLossyCompression; - { Defines whether alpha channel of lossy MNG frames or JNG images - is lossy compressed too. Allowed values are 0 (False) and 1 (True). - Default value is 0.} - property LossyAlpha: LongBool read FLossyAlpha write FLossyAlpha; - { Specifies compression quality used when saving lossy MNG frames or JNG images. - For details look at ImagingJpegQuality option.} - property Quality: LongInt read FQuality write FQuality; - { Specifies whether images are saved in progressive format when saving lossy - MNG frames or JNG images. For details look at ImagingJpegProgressive.} - property Progressive: LongBool read FProgressive write FProgressive; - end; - - { Class for loading Portable Network Graphics Images. - Loads all types of this image format (all images in png test suite) - and saves all types with bitcount >= 8 (non-interlaced only). - Compression level and filtering can be set by options interface. - - Supported ancillary chunks (loading): - tRNS, bKGD - (for indexed images transparency contains alpha values for palette, - RGB/Gray images with transparency are converted to formats with alpha - and pixels with transparent color are replaced with background color - with alpha = 0).} - TPNGFileFormat = class(TNetworkGraphicsFileFormat) - private - FLoadAnimated: LongBool; - protected - function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean): Boolean; override; - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - public - constructor Create; override; - published - property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated; - end; - -{$IFNDEF DONT_LINK_MNG} - { Class for loading Multiple Network Graphics files. - This format has complex animation capabilities but Imaging only - extracts frames. Individual frames are stored as standard PNG or JNG - images. Loads all types of these frames stored in IHDR-IEND and - JHDR-IEND streams (Note that there are MNG chunks - like BASI which define images but does not contain image data itself, - those are ignored). - Imaging saves MNG files as MNG-VLC (very low complexity) so it is basicaly - an array of image frames without MNG animation chunks. Frames can be saved - as lossless PNG or lossy JNG images (look at TPNGFileFormat and - TJNGFileFormat for info). Every frame can be in different data format. - - Many frame compression settings can be modified by options interface.} - TMNGFileFormat = class(TNetworkGraphicsFileFormat) - protected - function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean): Boolean; override; - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - public - constructor Create; override; - end; -{$ENDIF} - -{$IFNDEF DONT_LINK_JNG} - { Class for loading JPEG Network Graphics Images. - Loads all types of this image format (all images in jng test suite) - and saves all types except 12 bit JPEGs. - Alpha channel in JNG images is stored separately from color/gray data and - can be lossy (as JPEG image) or lossless (as PNG image) compressed. - Type of alpha compression, compression level and quality, - and filtering can be set by options interface. - - Supported ancillary chunks (loading): - tRNS, bKGD - (Images with transparency are converted to formats with alpha - and pixels with transparent color are replaced with background color - with alpha = 0).} - TJNGFileFormat = class(TNetworkGraphicsFileFormat) - protected - function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean): Boolean; override; - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - public - constructor Create; override; - end; -{$ENDIF} - - -implementation - -uses -{$IFNDEF DONT_LINK_JNG} - ImagingJpeg, ImagingIO, -{$ENDIF} - ImagingCanvases; - -const - NGDefaultPreFilter = 5; - NGDefaultCompressLevel = 5; - NGDefaultLossyAlpha = False; - NGDefaultLossyCompression = False; - NGDefaultProgressive = False; - NGDefaultQuality = 90; - NGLosslessFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8, ifGray16, - ifA16Gray16, ifR8G8B8, ifA8R8G8B8, ifR16G16B16, ifA16R16G16B16, ifB16G16R16, - ifA16B16G16R16]; - NGLossyFormats: TImageFormats = [ifGray8, ifA8Gray8, ifR8G8B8, ifA8R8G8B8]; - PNGDefaultLoadAnimated = True; - - SPNGFormatName = 'Portable Network Graphics'; - SPNGMasks = '*.png'; - SMNGFormatName = 'Multiple Network Graphics'; - SMNGMasks = '*.mng'; - SJNGFormatName = 'JPEG Network Graphics'; - SJNGMasks = '*.jng'; - -resourcestring - SErrorLoadingChunk = 'Error when reading %s chunk data. File may be corrupted.'; - -type - { Chunk header.} - TChunkHeader = packed record - DataSize: LongWord; - ChunkID: TChar4; - end; - - { IHDR chunk format - PNG header.} - TIHDR = packed record - Width: LongWord; // Image width - Height: LongWord; // Image height - BitDepth: Byte; // Bits per pixel or bits per sample (for truecolor) - ColorType: Byte; // 0 = grayscale, 2 = truecolor, 3 = palette, - // 4 = gray + alpha, 6 = truecolor + alpha - Compression: Byte; // Compression type: 0 = ZLib - Filter: Byte; // Used precompress filter - Interlacing: Byte; // Used interlacing: 0 = no int, 1 = Adam7 - end; - PIHDR = ^TIHDR; - - { MHDR chunk format - MNG header.} - TMHDR = packed record - FrameWidth: LongWord; // Frame width - FrameHeight: LongWord; // Frame height - TicksPerSecond: LongWord; // FPS of animation - NominalLayerCount: LongWord; // Number of layers in file - NominalFrameCount: LongWord; // Number of frames in file - NominalPlayTime: LongWord; // Play time of animation in ticks - SimplicityProfile: LongWord; // Defines which MNG features are used in this file - end; - PMHDR = ^TMHDR; - - { JHDR chunk format - JNG header.} - TJHDR = packed record - Width: LongWord; // Image width - Height: LongWord; // Image height - ColorType: Byte; // 8 = grayscale (Y), 10 = color (YCbCr), - // 12 = gray + alpha (Y-alpha), 14 = color + alpha (YCbCr-alpha) - SampleDepth: Byte; // 8, 12 or 20 (8 and 12 samples together) bit - Compression: Byte; // Compression type: 8 = Huffman coding - Interlacing: Byte; // 0 = single scan, 8 = progressive - AlphaSampleDepth: Byte; // 0, 1, 2, 4, 8, 16 if alpha compression is 0 (PNG) - // 8 if alpha compression is 8 (JNG) - AlphaCompression: Byte; // 0 = PNG graysscale IDAT, 8 = grayscale 8-bit JPEG - AlphaFilter: Byte; // 0 = PNG filter or no filter (JPEG) - AlphaInterlacing: Byte; // 0 = non interlaced - end; - PJHDR = ^TJHDR; - - { acTL chunk format - APNG animation control.} - TacTL = packed record - NumFrames: LongWord; // Number of frames - NumPlay: LongWord; // Number of times to loop the animation (0 = inf) - end; - PacTL =^TacTL; - - { fcTL chunk format - APNG frame control.} - TfcTL = packed record - SeqNumber: LongWord; // Sequence number of the animation chunk, starting from 0 - Width: LongWord; // Width of the following frame - Height: LongWord; // Height of the following frame - XOffset: LongWord; // X position at which to render the following frame - YOffset: LongWord; // Y position at which to render the following frame - DelayNumer: Word; // Frame delay fraction numerator - DelayDenom: Word; // Frame delay fraction denominator - DisposeOp: Byte; // Type of frame area disposal to be done after rendering this frame - BlendOp: Byte; // Type of frame area rendering for this frame - end; - PfcTL = ^TfcTL; - -const - { PNG file identifier.} - PNGSignature: TChar8 = #$89'PNG'#$0D#$0A#$1A#$0A; - { MNG file identifier.} - MNGSignature: TChar8 = #$8A'MNG'#$0D#$0A#$1A#$0A; - { JNG file identifier.} - JNGSignature: TChar8 = #$8B'JNG'#$0D#$0A#$1A#$0A; - - { Constants for chunk identifiers and signature identifiers. - They are in big-endian format.} - IHDRChunk: TChar4 = 'IHDR'; - IENDChunk: TChar4 = 'IEND'; - MHDRChunk: TChar4 = 'MHDR'; - MENDChunk: TChar4 = 'MEND'; - JHDRChunk: TChar4 = 'JHDR'; - IDATChunk: TChar4 = 'IDAT'; - JDATChunk: TChar4 = 'JDAT'; - JDAAChunk: TChar4 = 'JDAA'; - JSEPChunk: TChar4 = 'JSEP'; - PLTEChunk: TChar4 = 'PLTE'; - BACKChunk: TChar4 = 'BACK'; - DEFIChunk: TChar4 = 'DEFI'; - TERMChunk: TChar4 = 'TERM'; - tRNSChunk: TChar4 = 'tRNS'; - bKGDChunk: TChar4 = 'bKGD'; - gAMAChunk: TChar4 = 'gAMA'; - acTLChunk: TChar4 = 'acTL'; - fcTLChunk: TChar4 = 'fcTL'; - fdATChunk: TChar4 = 'fdAT'; - - { APNG frame dispose operations.} - DisposeOpNone = 0; - DisposeOpBackground = 1; - DisposeOpPrevious = 2; - - { APNG frame blending modes} - BlendOpSource = 0; - BlendOpOver = 1; - - { Interlace start and offsets.} - RowStart: array[0..6] of LongInt = (0, 0, 4, 0, 2, 0, 1); - ColumnStart: array[0..6] of LongInt = (0, 4, 0, 2, 0, 1, 0); - RowIncrement: array[0..6] of LongInt = (8, 8, 8, 4, 4, 2, 2); - ColumnIncrement: array[0..6] of LongInt = (8, 8, 4, 4, 2, 2, 1); - -type - { Helper class that holds information about MNG frame in PNG or JNG format.} - TFrameInfo = class(TObject) - public - FrameWidth, FrameHeight: LongInt; - IsJpegFrame: Boolean; - IHDR: TIHDR; - JHDR: TJHDR; - fcTL: TfcTL; - Palette: PPalette24; - PaletteEntries: LongInt; - Transparency: Pointer; - TransparencySize: LongInt; - Background: Pointer; - BackgroundSize: LongInt; - IDATMemory: TMemoryStream; - JDATMemory: TMemoryStream; - JDAAMemory: TMemoryStream; - constructor Create; - destructor Destroy; override; - procedure AssignSharedProps(Source: TFrameInfo); - end; - - { Defines type of Network Graphics file.} - TNGFileType = (ngPNG, ngAPNG, ngMNG, ngJNG); - - TNGFileHandler = class(TObject) - public - FileType: TNGFileType; - Frames: array of TFrameInfo; - MHDR: TMHDR; // Main header for MNG files - acTL: TacTL; // Global anim control for APNG files - GlobalPalette: PPalette24; - GlobalPaletteEntries: LongInt; - GlobalTransparency: Pointer; - GlobalTransparencySize: LongInt; - destructor Destroy; override; - procedure Clear; - function GetLastFrame: TFrameInfo; - function AddFrameInfo: TFrameInfo; - end; - - { Network Graphics file parser and frame converter.} - TNGFileLoader = class(TNGFileHandler) - public - function LoadFile(Handle: TImagingHandle): Boolean; - procedure LoadImageFromPNGFrame(FrameWidth, FrameHeight: LongInt; const IHDR: TIHDR; IDATStream: TMemoryStream; var Image: TImageData); -{$IFNDEF DONT_LINK_JNG} - procedure LoadImageFromJNGFrame(FrameWidth, FrameHeight: LongInt; const JHDR: TJHDR; IDATStream, JDATStream, JDAAStream: TMemoryStream; var Image: TImageData); -{$ENDIF} - procedure ApplyFrameSettings(Frame: TFrameInfo; var Image: TImageData); - end; - - TNGFileSaver = class(TNGFileHandler) - public - PreFilter: LongInt; - CompressLevel: LongInt; - LossyAlpha: Boolean; - Quality: LongInt; - Progressive: Boolean; - function SaveFile(Handle: TImagingHandle): Boolean; - procedure AddFrame(const Image: TImageData; IsJpegFrame: Boolean); - procedure StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer; FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream); -{$IFNDEF DONT_LINK_JNG} - procedure StoreImageToJNGFrame(const JHDR: TJHDR; const Image: TImageData; IDATStream, JDATStream, JDAAStream: TMemoryStream); -{$ENDIF} - procedure SetFileOptions(FileFormat: TNetworkGraphicsFileFormat); - end; - -{$IFNDEF DONT_LINK_JNG} - TCustomIOJpegFileFormat = class(TJpegFileFormat) - protected - FCustomIO: TIOFunctions; - procedure SetJpegIO(const JpegIO: TIOFunctions); override; - procedure SetCustomIO(const CustomIO: TIOFunctions); - end; -{$ENDIF} - - TAPNGAnimator = class - public - class procedure Animate(var Images: TDynImageDataArray; const acTL: TacTL; const SrcFrames: array of TFrameInfo); - end; - -{ Helper routines } - -function PaethPredictor(A, B, C: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -var - P, PA, PB, PC: LongInt; -begin - P := A + B - C; - PA := Abs(P - A); - PB := Abs(P - B); - PC := Abs(P - C); - if (PA <= PB) and (PA <= PC) then - Result := A - else - if PB <= PC then - Result := B - else - Result := C; -end; - -procedure SwapRGB(Line: PByte; Width, SampleDepth, BytesPerPixel: LongInt); -var - I: LongInt; - Tmp: Word; -begin - case SampleDepth of - 8: - for I := 0 to Width - 1 do - with PColor24Rec(Line)^ do - begin - Tmp := R; - R := B; - B := Tmp; - Inc(Line, BytesPerPixel); - end; - 16: - for I := 0 to Width - 1 do - with PColor48Rec(Line)^ do - begin - Tmp := R; - R := B; - B := Tmp; - Inc(Line, BytesPerPixel); - end; - end; - end; - -const - { Helper constants for 1/2/4 bit to 8 bit conversions.} - Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01); - Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0); - Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03); - Shift2: array[0..3] of Byte = (6, 4, 2, 0); - Mask4: array[0..1] of Byte = ($F0, $0F); - Shift4: array[0..1] of Byte = (4, 0); - -function Get1BitPixel(Line: PByteArray; X: LongInt): Byte; -begin - Result := (Line[X shr 3] and Mask1[X and 7]) shr - Shift1[X and 7]; -end; - -function Get2BitPixel(Line: PByteArray; X: LongInt): Byte; -begin - Result := (Line[X shr 2] and Mask2[X and 3]) shr - Shift2[X and 3]; -end; - -function Get4BitPixel(Line: PByteArray; X: LongInt): Byte; -begin - Result := (Line[X shr 1] and Mask4[X and 1]) shr - Shift4[X and 1]; -end; - -{$IFNDEF DONT_LINK_JNG} - -{ TCustomIOJpegFileFormat class implementation } - -procedure TCustomIOJpegFileFormat.SetCustomIO(const CustomIO: TIOFunctions); -begin - FCustomIO := CustomIO; -end; - -procedure TCustomIOJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions); -begin - inherited SetJpegIO(FCustomIO); -end; - -{$ENDIF} - -{ TFrameInfo class implementation } - -constructor TFrameInfo.Create; -begin - IDATMemory := TMemoryStream.Create; - JDATMemory := TMemoryStream.Create; - JDAAMemory := TMemoryStream.Create; -end; - -destructor TFrameInfo.Destroy; -begin - FreeMem(Palette); - FreeMem(Transparency); - FreeMem(Background); - IDATMemory.Free; - JDATMemory.Free; - JDAAMemory.Free; - inherited Destroy; -end; - -procedure TFrameInfo.AssignSharedProps(Source: TFrameInfo); -begin - IHDR := Source.IHDR; - JHDR := Source.JHDR; - PaletteEntries := Source.PaletteEntries; - GetMem(Palette, PaletteEntries * SizeOf(TColor24Rec)); - Move(Source.Palette^, Palette^, PaletteEntries * SizeOf(TColor24Rec)); - TransparencySize := Source.TransparencySize; - GetMem(Transparency, TransparencySize); - Move(Source.Transparency^, Transparency^, TransparencySize); -end; - -{ TNGFileHandler class implementation} - -destructor TNGFileHandler.Destroy; -begin - Clear; - inherited Destroy; -end; - -procedure TNGFileHandler.Clear; -var - I: LongInt; -begin - for I := 0 to Length(Frames) - 1 do - Frames[I].Free; - SetLength(Frames, 0); - FreeMemNil(GlobalPalette); - GlobalPaletteEntries := 0; - FreeMemNil(GlobalTransparency); - GlobalTransparencySize := 0; -end; - -function TNGFileHandler.GetLastFrame: TFrameInfo; -var - Len: LongInt; -begin - Len := Length(Frames); - if Len > 0 then - Result := Frames[Len - 1] - else - Result := nil; -end; - -function TNGFileHandler.AddFrameInfo: TFrameInfo; -var - Len: LongInt; -begin - Len := Length(Frames); - SetLength(Frames, Len + 1); - Result := TFrameInfo.Create; - Frames[Len] := Result; -end; - -{ TNGFileLoader class implementation} - -function TNGFileLoader.LoadFile(Handle: TImagingHandle): Boolean; -var - Sig: TChar8; - Chunk: TChunkHeader; - ChunkData: Pointer; - ChunkCrc: LongWord; - - procedure ReadChunk; - begin - GetIO.Read(Handle, @Chunk, SizeOf(Chunk)); - Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize); - end; - - procedure ReadChunkData; - var - ReadBytes: LongWord; - begin - FreeMemNil(ChunkData); - GetMem(ChunkData, Chunk.DataSize); - ReadBytes := GetIO.Read(Handle, ChunkData, Chunk.DataSize); - GetIO.Read(Handle, @ChunkCrc, SizeOf(ChunkCrc)); - if ReadBytes <> Chunk.DataSize then - RaiseImaging(SErrorLoadingChunk, [string(Chunk.ChunkID)]); - end; - - procedure SkipChunkData; - begin - GetIO.Seek(Handle, Chunk.DataSize + SizeOf(ChunkCrc), smFromCurrent); - end; - - procedure StartNewPNGImage; - var - Frame: TFrameInfo; - begin - ReadChunkData; - - if Chunk.ChunkID = fcTLChunk then - begin - if (Length(Frames) = 1) and (Frames[0].IDATMemory.Size = 0) then - begin - // First fcTL chunk maybe for first IDAT frame which is alredy created - Frame := Frames[0]; - end - else - begin - // Subsequent APNG frames with data in fdAT - Frame := AddFrameInfo; - // Copy some shared props from first frame (IHDR is the same for all APNG frames, palette etc) - Frame.AssignSharedProps(Frames[0]); - end; - Frame.fcTL := PfcTL(ChunkData)^; - SwapEndianLongWord(@Frame.fcTL, 5); - Frame.fcTL.DelayNumer := SwapEndianWord(Frame.fcTL.DelayNumer); - Frame.fcTL.DelayDenom := SwapEndianWord(Frame.fcTL.DelayDenom); - Frame.FrameWidth := Frame.fcTL.Width; - Frame.FrameHeight := Frame.fcTL.Height; - end - else - begin - // This is frame defined by IHDR chunk - Frame := AddFrameInfo; - Frame.IHDR := PIHDR(ChunkData)^; - SwapEndianLongWord(@Frame.IHDR, 2); - Frame.FrameWidth := Frame.IHDR.Width; - Frame.FrameHeight := Frame.IHDR.Height; - end; - Frame.IsJpegFrame := False; - end; - - procedure StartNewJNGImage; - var - Frame: TFrameInfo; - begin - ReadChunkData; - Frame := AddFrameInfo; - Frame.IsJpegFrame := True; - Frame.JHDR := PJHDR(ChunkData)^; - SwapEndianLongWord(@Frame.JHDR, 2); - Frame.FrameWidth := Frame.JHDR.Width; - Frame.FrameHeight := Frame.JHDR.Height; - end; - - procedure AppendIDAT; - begin - ReadChunkData; - // Append current IDAT/fdAT chunk to storage stream - if Chunk.ChunkID = IDATChunk then - GetLastFrame.IDATMemory.Write(ChunkData^, Chunk.DataSize) - else if Chunk.ChunkID = fdATChunk then - GetLastFrame.IDATMemory.Write(PByteArray(ChunkData)[4], Chunk.DataSize - SizeOf(LongWord)); - end; - - procedure AppendJDAT; - begin - ReadChunkData; - // Append current JDAT chunk to storage stream - GetLastFrame.JDATMemory.Write(ChunkData^, Chunk.DataSize); - end; - - procedure AppendJDAA; - begin - ReadChunkData; - // Append current JDAA chunk to storage stream - GetLastFrame.JDAAMemory.Write(ChunkData^, Chunk.DataSize); - end; - - procedure LoadPLTE; - begin - ReadChunkData; - if GetLastFrame = nil then - begin - // Load global palette - GetMem(GlobalPalette, Chunk.DataSize); - Move(ChunkData^, GlobalPalette^, Chunk.DataSize); - GlobalPaletteEntries := Chunk.DataSize div 3; - end - else if GetLastFrame.Palette = nil then - begin - if (Chunk.DataSize = 0) and (GlobalPalette <> nil) then - begin - // Use global palette - GetMem(GetLastFrame.Palette, GlobalPaletteEntries * SizeOf(TColor24Rec)); - Move(GlobalPalette^, GetLastFrame.Palette^, GlobalPaletteEntries * SizeOf(TColor24Rec)); - GetLastFrame.PaletteEntries := GlobalPaletteEntries; - end - else - begin - // Load pal from PLTE chunk - GetMem(GetLastFrame.Palette, Chunk.DataSize); - Move(ChunkData^, GetLastFrame.Palette^, Chunk.DataSize); - GetLastFrame.PaletteEntries := Chunk.DataSize div 3; - end; - end; - end; - - procedure LoadtRNS; - begin - ReadChunkData; - if GetLastFrame = nil then - begin - // Load global transparency - GetMem(GlobalTransparency, Chunk.DataSize); - Move(ChunkData^, GlobalTransparency^, Chunk.DataSize); - GlobalTransparencySize := Chunk.DataSize; - end - else if GetLastFrame.Transparency = nil then - begin - if (Chunk.DataSize = 0) and (GlobalTransparency <> nil) then - begin - // Use global transparency - GetMem(GetLastFrame.Transparency, GlobalTransparencySize); - Move(GlobalTransparency^, GetLastFrame.Transparency^, Chunk.DataSize); - GetLastFrame.TransparencySize := GlobalTransparencySize; - end - else - begin - // Load pal from tRNS chunk - GetMem(GetLastFrame.Transparency, Chunk.DataSize); - Move(ChunkData^, GetLastFrame.Transparency^, Chunk.DataSize); - GetLastFrame.TransparencySize := Chunk.DataSize; - end; - end; - end; - - procedure LoadbKGD; - begin - ReadChunkData; - if GetLastFrame.Background = nil then - begin - GetMem(GetLastFrame.Background, Chunk.DataSize); - Move(ChunkData^, GetLastFrame.Background^, Chunk.DataSize); - GetLastFrame.BackgroundSize := Chunk.DataSize; - end; - end; - - procedure HandleacTL; - begin - FileType := ngAPNG; - ReadChunkData; - acTL := PacTL(ChunkData)^; - SwapEndianLongWord(@acTL, SizeOf(acTL) div SizeOf(LongWord)); - end; - -begin - Result := False; - Clear; - ChunkData := nil; - with GetIO do - try - Read(Handle, @Sig, SizeOf(Sig)); - // Set file type according to the signature - if Sig = PNGSignature then FileType := ngPNG - else if Sig = MNGSignature then FileType := ngMNG - else if Sig = JNGSignature then FileType := ngJNG - else Exit; - - if FileType = ngMNG then - begin - // Store MNG header if present - ReadChunk; - ReadChunkData; - MHDR := PMHDR(ChunkData)^; - SwapEndianLongWord(@MHDR, SizeOf(MHDR) div SizeOf(LongWord)); - end; - - // Read chunks until ending chunk or EOF is reached - repeat - ReadChunk; - if (Chunk.ChunkID = IHDRChunk) or (Chunk.ChunkID = fcTLChunk) then StartNewPNGImage - else if Chunk.ChunkID = JHDRChunk then StartNewJNGImage - else if (Chunk.ChunkID = IDATChunk) or (Chunk.ChunkID = fdATChunk) then AppendIDAT - else if Chunk.ChunkID = JDATChunk then AppendJDAT - else if Chunk.ChunkID = JDAAChunk then AppendJDAA - else if Chunk.ChunkID = PLTEChunk then LoadPLTE - else if Chunk.ChunkID = tRNSChunk then LoadtRNS - else if Chunk.ChunkID = bKGDChunk then LoadbKGD - else if Chunk.ChunkID = acTLChunk then HandleacTL - else SkipChunkData; - until Eof(Handle) or (Chunk.ChunkID = MENDChunk) or - ((FileType <> ngMNG) and (Chunk.ChunkID = IENDChunk)); - - Result := True; - finally - FreeMemNil(ChunkData); - end; -end; - -procedure TNGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight: LongInt; const IHDR: TIHDR; - IDATStream: TMemoryStream; var Image: TImageData); -type - TGetPixelFunc = function(Line: PByteArray; X: LongInt): Byte; -var - LineBuffer: array[Boolean] of PByteArray; - ActLine: Boolean; - Data, TotalBuffer, ZeroLine, PrevLine: Pointer; - BitCount, TotalSize, TotalPos, BytesPerPixel, I, Pass, - SrcDataSize, BytesPerLine, InterlaceLineBytes, InterlaceWidth: LongInt; - - procedure DecodeAdam7; - const - BitTable: array[1..8] of LongInt = ($1, $3, 0, $F, 0, 0, 0, $FF); - StartBit: array[1..8] of LongInt = (7, 6, 0, 4, 0, 0, 0, 0); - var - Src, Dst, Dst2: PByte; - CurBit, Col: LongInt; - begin - Src := @LineBuffer[ActLine][1]; - Col := ColumnStart[Pass]; - with Image do - case BitCount of - 1, 2, 4: - begin - Dst := @PByteArray(Data)[I * BytesPerLine]; - repeat - CurBit := StartBit[BitCount]; - repeat - Dst2 := @PByteArray(Dst)[(BitCount * Col) shr 3]; - Dst2^ := Dst2^ or ((Src^ shr CurBit) and BitTable[BitCount]) - shl (StartBit[BitCount] - (Col * BitCount mod 8)); - Inc(Col, ColumnIncrement[Pass]); - Dec(CurBit, BitCount); - until CurBit < 0; - Inc(Src); - until Col >= Width; - end; - else - begin - Dst := @PByteArray(Data)[I * BytesPerLine + Col * BytesPerPixel]; - repeat - CopyPixel(Src, Dst, BytesPerPixel); - Inc(Dst, BytesPerPixel); - Inc(Src, BytesPerPixel); - Inc(Dst, ColumnIncrement[Pass] * BytesPerPixel - BytesPerPixel); - Inc(Col, ColumnIncrement[Pass]); - until Col >= Width; - end; - end; - end; - - procedure FilterScanline(Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray; - BytesPerLine: LongInt); - var - I: LongInt; - begin - case Filter of - 0: - begin - // No filter - Move(Line^, Target^, BytesPerLine); - end; - 1: - begin - // Sub filter - Move(Line^, Target^, BytesPerPixel); - for I := BytesPerPixel to BytesPerLine - 1 do - Target[I] := (Line[I] + Target[I - BytesPerPixel]) and $FF; - end; - 2: - begin - // Up filter - for I := 0 to BytesPerLine - 1 do - Target[I] := (Line[I] + PrevLine[I]) and $FF; - end; - 3: - begin - // Average filter - for I := 0 to BytesPerPixel - 1 do - Target[I] := (Line[I] + PrevLine[I] shr 1) and $FF; - for I := BytesPerPixel to BytesPerLine - 1 do - Target[I] := (Line[I] + (Target[I - BytesPerPixel] + PrevLine[I]) shr 1) and $FF; - end; - 4: - begin - // Paeth filter - for I := 0 to BytesPerPixel - 1 do - Target[I] := (Line[I] + PaethPredictor(0, PrevLine[I], 0)) and $FF; - for I := BytesPerPixel to BytesPerLine - 1 do - Target[I] := (Line[I] + PaethPredictor(Target[I - BytesPerPixel], PrevLine[I], PrevLine[I - BytesPerPixel])) and $FF; - end; - end; - end; - - procedure Convert124To8(DataIn: Pointer; DataOut: Pointer; Width, Height, - WidthBytes: LongInt; Indexed: Boolean); - var - X, Y, Mul: LongInt; - GetPixel: TGetPixelFunc; - begin - GetPixel := Get1BitPixel; - Mul := 255; - case IHDR.BitDepth of - 2: - begin - Mul := 85; - GetPixel := Get2BitPixel; - end; - 4: - begin - Mul := 17; - GetPixel := Get4BitPixel; - end; - end; - if Indexed then Mul := 1; - - for Y := 0 to Height - 1 do - for X := 0 to Width - 1 do - PByteArray(DataOut)[Y * Width + X] := - GetPixel(@PByteArray(DataIn)[Y * WidthBytes], X) * Mul; - end; - - procedure TransformLOCOToRGB(Data: PByte; NumPixels, BytesPerPixel: LongInt); - var - I: LongInt; - begin - for I := 0 to NumPixels - 1 do - begin - if IHDR.BitDepth = 8 then - begin - PColor32Rec(Data).R := Byte(PColor32Rec(Data).R + PColor32Rec(Data).G); - PColor32Rec(Data).B := Byte(PColor32Rec(Data).B + PColor32Rec(Data).G); - end - else - begin - PColor64Rec(Data).R := Word(PColor64Rec(Data).R + PColor64Rec(Data).G); - PColor64Rec(Data).B := Word(PColor64Rec(Data).B + PColor64Rec(Data).G); - end; - Inc(Data, BytesPerPixel); - end; - end; - -begin - Image.Width := FrameWidth; - Image.Height := FrameHeight; - Image.Format := ifUnknown; - - case IHDR.ColorType of - 0: - begin - // Gray scale image - case IHDR.BitDepth of - 1, 2, 4, 8: Image.Format := ifGray8; - 16: Image.Format := ifGray16; - end; - BitCount := IHDR.BitDepth; - end; - 2: - begin - // RGB image - case IHDR.BitDepth of - 8: Image.Format := ifR8G8B8; - 16: Image.Format := ifR16G16B16; - end; - BitCount := IHDR.BitDepth * 3; - end; - 3: - begin - // Indexed image - case IHDR.BitDepth of - 1, 2, 4, 8: Image.Format := ifIndex8; - end; - BitCount := IHDR.BitDepth; - end; - 4: - begin - // Grayscale + alpha image - case IHDR.BitDepth of - 8: Image.Format := ifA8Gray8; - 16: Image.Format := ifA16Gray16; - end; - BitCount := IHDR.BitDepth * 2; - end; - 6: - begin - // ARGB image - case IHDR.BitDepth of - 8: Image.Format := ifA8R8G8B8; - 16: Image.Format := ifA16R16G16B16; - end; - BitCount := IHDR.BitDepth * 4; - end; - end; - - // Start decoding - LineBuffer[True] := nil; - LineBuffer[False] := nil; - TotalBuffer := nil; - ZeroLine := nil; - BytesPerPixel := (BitCount + 7) div 8; - ActLine := True; - with Image do - try - BytesPerLine := (Width * BitCount + 7) div 8; - SrcDataSize := Height * BytesPerLine; - GetMem(Data, SrcDataSize); - FillChar(Data^, SrcDataSize, 0); - GetMem(ZeroLine, BytesPerLine); - FillChar(ZeroLine^, BytesPerLine, 0); - - if IHDR.Interlacing = 1 then - begin - // Decode interlaced images - TotalPos := 0; - DecompressBuf(IDATStream.Memory, IDATStream.Size, 0, - Pointer(TotalBuffer), TotalSize); - GetMem(LineBuffer[True], BytesPerLine + 1); - GetMem(LineBuffer[False], BytesPerLine + 1); - for Pass := 0 to 6 do - begin - // Prepare next interlace run - if Width <= ColumnStart[Pass] then - Continue; - InterlaceWidth := (Width + ColumnIncrement[Pass] - 1 - - ColumnStart[Pass]) div ColumnIncrement[Pass]; - InterlaceLineBytes := (InterlaceWidth * BitCount + 7) shr 3; - I := RowStart[Pass]; - FillChar(LineBuffer[True][0], BytesPerLine + 1, 0); - FillChar(LineBuffer[False][0], BytesPerLine + 1, 0); - while I < Height do - begin - // Copy line from decompressed data to working buffer - Move(PByteArray(TotalBuffer)[TotalPos], - LineBuffer[ActLine][0], InterlaceLineBytes + 1); - Inc(TotalPos, InterlaceLineBytes + 1); - // Swap red and blue channels if necessary - if (IHDR.ColorType in [2, 6]) then - SwapRGB(@LineBuffer[ActLine][1], InterlaceWidth, IHDR.BitDepth, BytesPerPixel); - // Reverse-filter current scanline - FilterScanline(LineBuffer[ActLine][0], BytesPerPixel, - @LineBuffer[ActLine][1], @LineBuffer[not ActLine][1], - @LineBuffer[ActLine][1], InterlaceLineBytes); - // Decode Adam7 interlacing - DecodeAdam7; - ActLine := not ActLine; - // Continue with next row in interlaced order - Inc(I, RowIncrement[Pass]); - end; - end; - end - else - begin - // Decode non-interlaced images - PrevLine := ZeroLine; - DecompressBuf(IDATStream.Memory, IDATStream.Size, SrcDataSize + Height, - Pointer(TotalBuffer), TotalSize); - for I := 0 to Height - 1 do - begin - // Swap red and blue channels if necessary - if IHDR.ColorType in [2, 6] then - SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], Width, - IHDR.BitDepth, BytesPerPixel); - // reverse-filter current scanline - FilterScanline(PByteArray(TotalBuffer)[I * (BytesPerLine + 1)], - BytesPerPixel, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], - PrevLine, @PByteArray(Data)[I * BytesPerLine], BytesPerLine); - PrevLine := @PByteArray(Data)[I * BytesPerLine]; - end; - end; - - Size := Width * Height * BytesPerPixel; - - if Size <> SrcDataSize then - begin - // If source data size is different from size of image in assigned - // format we must convert it (it is in 1/2/4 bit count) - GetMem(Bits, Size); - case IHDR.ColorType of - 0: Convert124To8(Data, Bits, Width, Height, BytesPerLine, False); - 3: Convert124To8(Data, Bits, Width, Height, BytesPerLine, True); - end; - FreeMem(Data); - end - else - begin - // If source data size is the same as size of - // image Bits in assigned format we simply copy pointer reference - Bits := Data; - end; - - // LOCO transformation was used too (only for color types 2 and 6) - if (IHDR.Filter = 64) and (IHDR.ColorType in [2, 6]) then - TransformLOCOToRGB(Bits, Width * Height, BytesPerPixel); - - // Images with 16 bit channels must be swapped because of PNG's big endianity - if IHDR.BitDepth = 16 then - SwapEndianWord(Bits, Width * Height * BytesPerPixel div SizeOf(Word)); - finally - FreeMem(LineBuffer[True]); - FreeMem(LineBuffer[False]); - FreeMem(TotalBuffer); - FreeMem(ZeroLine); - end; -end; - -{$IFNDEF DONT_LINK_JNG} - -procedure TNGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight: LongInt; const JHDR: TJHDR; IDATStream, - JDATStream, JDAAStream: TMemoryStream; var Image: TImageData); -var - AlphaImage: TImageData; - FakeIHDR: TIHDR; - FmtInfo: TImageFormatInfo; - I: LongInt; - AlphaPtr: PByte; - GrayPtr: PWordRec; - ColorPtr: PColor32Rec; - - procedure LoadJpegFromStream(Stream: TStream; var DestImage: TImageData); - var - JpegFormat: TCustomIOJpegFileFormat; - Handle: TImagingHandle; - DynImages: TDynImageDataArray; - begin - if JHDR.SampleDepth <> 12 then - begin - JpegFormat := TCustomIOJpegFileFormat.Create; - JpegFormat.SetCustomIO(StreamIO); - Stream.Position := 0; - Handle := StreamIO.OpenRead(Pointer(Stream)); - try - JpegFormat.LoadData(Handle, DynImages, True); - DestImage := DynImages[0]; - finally - StreamIO.Close(Handle); - JpegFormat.Free; - SetLength(DynImages, 0); - end; - end - else - NewImage(FrameWidth, FrameHeight, ifR8G8B8, DestImage); - end; - -begin - LoadJpegFromStream(JDATStream, Image); - - // If present separate alpha channel is processed - if (JHDR.ColorType in [12, 14]) and (Image.Format in [ifGray8, ifR8G8B8]) then - begin - InitImage(AlphaImage); - if JHDR.AlphaCompression = 0 then - begin - // Alpha channel is PNG compressed - FakeIHDR.Width := JHDR.Width; - FakeIHDR.Height := JHDR.Height; - FakeIHDR.ColorType := 0; - FakeIHDR.BitDepth := JHDR.AlphaSampleDepth; - FakeIHDR.Filter := JHDR.AlphaFilter; - FakeIHDR.Interlacing := JHDR.AlphaInterlacing; - - LoadImageFromPNGFrame(FrameWidth, FrameHeight, FakeIHDR, IDATStream, AlphaImage); - end - else - begin - // Alpha channel is JPEG compressed - LoadJpegFromStream(JDAAStream, AlphaImage); - end; - - // Check if alpha channel is the same size as image - if (Image.Width <> AlphaImage.Width) and (Image.Height <> AlphaImage.Height) then - ResizeImage(AlphaImage, Image.Width, Image.Height, rfNearest); - - // Check alpha channels data format - GetImageFormatInfo(AlphaImage.Format, FmtInfo); - if (FmtInfo.BytesPerPixel > 1) or (not FmtInfo.HasGrayChannel) then - ConvertImage(AlphaImage, ifGray8); - - // Convert image to fromat with alpha channel - if Image.Format = ifGray8 then - ConvertImage(Image, ifA8Gray8) - else - ConvertImage(Image, ifA8R8G8B8); - - // Combine alpha channel with image - AlphaPtr := AlphaImage.Bits; - if Image.Format = ifA8Gray8 then - begin - GrayPtr := Image.Bits; - for I := 0 to Image.Width * Image.Height - 1 do - begin - GrayPtr.High := AlphaPtr^; - Inc(GrayPtr); - Inc(AlphaPtr); - end; - end - else - begin - ColorPtr := Image.Bits; - for I := 0 to Image.Width * Image.Height - 1 do - begin - ColorPtr.A := AlphaPtr^; - Inc(ColorPtr); - Inc(AlphaPtr); - end; - end; - - FreeImage(AlphaImage); - end; -end; - -{$ENDIF} - -procedure TNGFileLoader.ApplyFrameSettings(Frame: TFrameInfo; var Image: TImageData); -var - FmtInfo: TImageFormatInfo; - BackGroundColor: TColor64Rec; - ColorKey: TColor64Rec; - Alphas: PByteArray; - AlphasSize: LongInt; - IsColorKeyPresent: Boolean; - IsBackGroundPresent: Boolean; - IsColorFormat: Boolean; - - procedure ConverttRNS; - begin - if FmtInfo.IsIndexed then - begin - if Alphas = nil then - begin - GetMem(Alphas, Frame.TransparencySize); - Move(Frame.Transparency^, Alphas^, Frame.TransparencySize); - AlphasSize := Frame.TransparencySize; - end; - end - else if not FmtInfo.HasAlphaChannel then - begin - FillChar(ColorKey, SizeOf(ColorKey), 0); - Move(Frame.Transparency^, ColorKey, Min(Frame.TransparencySize, SizeOf(ColorKey))); - if IsColorFormat then - SwapValues(ColorKey.R, ColorKey.B); - SwapEndianWord(@ColorKey, 3); - // 1/2/4 bit images were converted to 8 bit so we must convert color key too - if (not Frame.IsJpegFrame) and (Frame.IHDR.ColorType in [0, 4]) then - case Frame.IHDR.BitDepth of - 1: ColorKey.B := Word(ColorKey.B * 255); - 2: ColorKey.B := Word(ColorKey.B * 85); - 4: ColorKey.B := Word(ColorKey.B * 17); - end; - IsColorKeyPresent := True; - end; - end; - - procedure ConvertbKGD; - begin - FillChar(BackGroundColor, SizeOf(BackGroundColor), 0); - Move(Frame.Background^, BackGroundColor, Min(Frame.BackgroundSize, - SizeOf(BackGroundColor))); - if IsColorFormat then - SwapValues(BackGroundColor.R, BackGroundColor.B); - SwapEndianWord(@BackGroundColor, 3); - // 1/2/4 bit images were converted to 8 bit so we must convert back color too - if (not Frame.IsJpegFrame) and (Frame.IHDR.ColorType in [0, 4]) then - case Frame.IHDR.BitDepth of - 1: BackGroundColor.B := Word(BackGroundColor.B * 255); - 2: BackGroundColor.B := Word(BackGroundColor.B * 85); - 4: BackGroundColor.B := Word(BackGroundColor.B * 17); - end; - IsBackGroundPresent := True; - end; - - procedure ReconstructPalette; - var - I: LongInt; - begin - with Image do - begin - GetMem(Palette, FmtInfo.PaletteEntries * SizeOf(TColor32Rec)); - FillChar(Palette^, FmtInfo.PaletteEntries * SizeOf(TColor32Rec), $FF); - // if RGB palette was loaded from file then use it - if Frame.Palette <> nil then - for I := 0 to Min(Frame.PaletteEntries, FmtInfo.PaletteEntries) - 1 do - with Palette[I] do - begin - R := Frame.Palette[I].B; - G := Frame.Palette[I].G; - B := Frame.Palette[I].R; - end; - // if palette alphas were loaded from file then use them - if Alphas <> nil then - for I := 0 to Min(AlphasSize, FmtInfo.PaletteEntries) - 1 do - Palette[I].A := Alphas[I]; - end; - end; - - procedure ApplyColorKey; - var - DestFmt: TImageFormat; - OldPixel, NewPixel: Pointer; - begin - case Image.Format of - ifGray8: DestFmt := ifA8Gray8; - ifGray16: DestFmt := ifA16Gray16; - ifR8G8B8: DestFmt := ifA8R8G8B8; - ifR16G16B16: DestFmt := ifA16R16G16B16; - else - DestFmt := ifUnknown; - end; - if DestFmt <> ifUnknown then - begin - if not IsBackGroundPresent then - BackGroundColor := ColorKey; - ConvertImage(Image, DestFmt); - OldPixel := @ColorKey; - NewPixel := @BackGroundColor; - // Now back color and color key must be converted to image's data format, looks ugly - case Image.Format of - ifA8Gray8: - begin - TColor32Rec(TInt64Rec(ColorKey).Low).B := Byte(ColorKey.B); - TColor32Rec(TInt64Rec(ColorKey).Low).G := $FF; - TColor32Rec(TInt64Rec(BackGroundColor).Low).B := Byte(BackGroundColor.B); - end; - ifA16Gray16: - begin - ColorKey.G := $FFFF; - end; - ifA8R8G8B8: - begin - TColor32Rec(TInt64Rec(ColorKey).Low).R := Byte(ColorKey.R); - TColor32Rec(TInt64Rec(ColorKey).Low).G := Byte(ColorKey.G); - TColor32Rec(TInt64Rec(ColorKey).Low).B := Byte(ColorKey.B); - TColor32Rec(TInt64Rec(ColorKey).Low).A := $FF; - TColor32Rec(TInt64Rec(BackGroundColor).Low).R := Byte(BackGroundColor.R); - TColor32Rec(TInt64Rec(BackGroundColor).Low).G := Byte(BackGroundColor.G); - TColor32Rec(TInt64Rec(BackGroundColor).Low).B := Byte(BackGroundColor.B); - end; - ifA16R16G16B16: - begin - ColorKey.A := $FFFF; - end; - end; - ReplaceColor(Image, 0, 0, Image.Width, Image.Height, OldPixel, NewPixel); - end; - end; - -begin - Alphas := nil; - IsColorKeyPresent := False; - IsBackGroundPresent := False; - GetImageFormatInfo(Image.Format, FmtInfo); - - IsColorFormat := (Frame.IsJpegFrame and (Frame.JHDR.ColorType in [10, 14])) or - (not Frame.IsJpegFrame and (Frame.IHDR.ColorType in [2, 6])); - - // Convert some chunk data to useful format - if Frame.Transparency <> nil then - ConverttRNS; - if Frame.Background <> nil then - ConvertbKGD; - - // Build palette for indexed images - if FmtInfo.IsIndexed then - ReconstructPalette; - - // Apply color keying - if IsColorKeyPresent and not FmtInfo.HasAlphaChannel then - ApplyColorKey; - - FreeMemNil(Alphas); -end; - -{ TNGFileSaver class implementation } - -procedure TNGFileSaver.StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer; - FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream); -var - TotalBuffer, CompBuffer, ZeroLine, PrevLine: Pointer; - FilterLines: array[0..4] of PByteArray; - TotalSize, CompSize, I, BytesPerLine, BytesPerPixel: LongInt; - Filter: Byte; - Adaptive: Boolean; - - procedure FilterScanline(Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray); - var - I: LongInt; - begin - case Filter of - 0: - begin - // No filter - Move(Line^, Target^, BytesPerLine); - end; - 1: - begin - // Sub filter - Move(Line^, Target^, BytesPerPixel); - for I := BytesPerPixel to BytesPerLine - 1 do - Target[I] := (Line[I] - Line[I - BytesPerPixel]) and $FF; - end; - 2: - begin - // Up filter - for I := 0 to BytesPerLine - 1 do - Target[I] := (Line[I] - PrevLine[I]) and $FF; - end; - 3: - begin - // Average filter - for I := 0 to BytesPerPixel - 1 do - Target[I] := (Line[I] - PrevLine[I] shr 1) and $FF; - for I := BytesPerPixel to BytesPerLine - 1 do - Target[I] := (Line[I] - (Line[I - BytesPerPixel] + PrevLine[I]) shr 1) and $FF; - end; - 4: - begin - // Paeth filter - for I := 0 to BytesPerPixel - 1 do - Target[I] := (Line[I] - PaethPredictor(0, PrevLine[I], 0)) and $FF; - for I := BytesPerPixel to BytesPerLine - 1 do - Target[I] := (Line[I] - PaethPredictor(Line[I - BytesPerPixel], PrevLine[I], PrevLine[I - BytesPerPixel])) and $FF; - end; - end; - end; - - procedure AdaptiveFilter(var Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray); - var - I, J, BestTest: LongInt; - Sums: array[0..4] of LongInt; - begin - // Compute the output scanline using all five filters, - // and select the filter that gives the smallest sum of - // absolute values of outputs - FillChar(Sums, SizeOf(Sums), 0); - BestTest := MaxInt; - for I := 0 to 4 do - begin - FilterScanline(I, BytesPerPixel, Line, PrevLine, FilterLines[I]); - for J := 0 to BytesPerLine - 1 do - Sums[I] := Sums[I] + Abs(ShortInt(FilterLines[I][J])); - if Sums[I] < BestTest then - begin - Filter := I; - BestTest := Sums[I]; - end; - end; - Move(FilterLines[Filter]^, Target^, BytesPerLine); - end; - -begin - // Select precompression filter and compression level - Adaptive := False; - Filter := 0; - case PreFilter of - 6: - if not ((IHDR.BitDepth < 8) or (IHDR.ColorType = 3)) - then Adaptive := True; - 0..4: Filter := PreFilter; - else - if IHDR.ColorType in [2, 6] then - Filter := 4 - end; - // Prepare data for compression - CompBuffer := nil; - FillChar(FilterLines, SizeOf(FilterLines), 0); - BytesPerPixel := FmtInfo.BytesPerPixel; - BytesPerLine := LongInt(IHDR.Width) * BytesPerPixel; - TotalSize := (BytesPerLine + 1) * LongInt(IHDR.Height); - GetMem(TotalBuffer, TotalSize); - GetMem(ZeroLine, BytesPerLine); - FillChar(ZeroLine^, BytesPerLine, 0); - if Adaptive then - for I := 0 to 4 do - GetMem(FilterLines[I], BytesPerLine); - PrevLine := ZeroLine; - try - // Process next scanlines - for I := 0 to IHDR.Height - 1 do - begin - // Filter scanline - if Adaptive then - AdaptiveFilter(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine], - PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1]) - else - FilterScanline(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine], - PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1]); - PrevLine := @PByteArray(Bits)[I * BytesPerLine]; - // Swap red and blue if necessary - if (IHDR.ColorType in [2, 6]) and not FmtInfo.IsRBSwapped then - SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], - IHDR.Width, IHDR.BitDepth, FmtInfo.BytesPerPixel); - // Images with 16 bit channels must be swapped because of PNG's big endianess - if IHDR.BitDepth = 16 then - SwapEndianWord(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], - BytesPerLine div SizeOf(Word)); - // Set filter used for this scanline - PByteArray(TotalBuffer)[I * (BytesPerLine + 1)] := Filter; - end; - // Compress IDAT data - CompressBuf(TotalBuffer, TotalSize, CompBuffer, CompSize, CompressLevel); - // Write IDAT data to stream - IDATStream.WriteBuffer(CompBuffer^, CompSize); - finally - FreeMem(TotalBuffer); - FreeMem(CompBuffer); - FreeMem(ZeroLine); - if Adaptive then - for I := 0 to 4 do - FreeMem(FilterLines[I]); - end; -end; - -{$IFNDEF DONT_LINK_JNG} - -procedure TNGFileSaver.StoreImageToJNGFrame(const JHDR: TJHDR; - const Image: TImageData; IDATStream, JDATStream, - JDAAStream: TMemoryStream); -var - ColorImage, AlphaImage: TImageData; - FmtInfo: TImageFormatInfo; - AlphaPtr: PByte; - GrayPtr: PWordRec; - ColorPtr: PColor32Rec; - I: LongInt; - FakeIHDR: TIHDR; - - procedure SaveJpegToStream(Stream: TStream; const Image: TImageData); - var - JpegFormat: TCustomIOJpegFileFormat; - Handle: TImagingHandle; - DynImages: TDynImageDataArray; - begin - JpegFormat := TCustomIOJpegFileFormat.Create; - JpegFormat.SetCustomIO(StreamIO); - // Only JDAT stream can be saved progressive - if Stream = JDATStream then - JpegFormat.FProgressive := Progressive - else - JpegFormat.FProgressive := False; - JpegFormat.FQuality := Quality; - SetLength(DynImages, 1); - DynImages[0] := Image; - Handle := StreamIO.OpenWrite(Pointer(Stream)); - try - JpegFormat.SaveData(Handle, DynImages, 0); - finally - StreamIO.Close(Handle); - SetLength(DynImages, 0); - JpegFormat.Free; - end; - end; - -begin - GetImageFormatInfo(Image.Format, FmtInfo); - InitImage(ColorImage); - InitImage(AlphaImage); - - if FmtInfo.HasAlphaChannel then - begin - // Create new image for alpha channel and color image without alpha - CloneImage(Image, ColorImage); - NewImage(Image.Width, Image.Height, ifGray8, AlphaImage); - case Image.Format of - ifA8Gray8: ConvertImage(ColorImage, ifGray8); - ifA8R8G8B8: ConvertImage(ColorImage, ifR8G8B8); - end; - - // Store source image's alpha to separate image - AlphaPtr := AlphaImage.Bits; - if Image.Format = ifA8Gray8 then - begin - GrayPtr := Image.Bits; - for I := 0 to Image.Width * Image.Height - 1 do - begin - AlphaPtr^ := GrayPtr.High; - Inc(GrayPtr); - Inc(AlphaPtr); - end; - end - else - begin - ColorPtr := Image.Bits; - for I := 0 to Image.Width * Image.Height - 1 do - begin - AlphaPtr^ := ColorPtr.A; - Inc(ColorPtr); - Inc(AlphaPtr); - end; - end; - - // Write color image to stream as JPEG - SaveJpegToStream(JDATStream, ColorImage); - - if LossyAlpha then - begin - // Write alpha image to stream as JPEG - SaveJpegToStream(JDAAStream, AlphaImage); - end - else - begin - // Alpha channel is PNG compressed - FakeIHDR.Width := JHDR.Width; - FakeIHDR.Height := JHDR.Height; - FakeIHDR.ColorType := 0; - FakeIHDR.BitDepth := JHDR.AlphaSampleDepth; - FakeIHDR.Filter := JHDR.AlphaFilter; - FakeIHDR.Interlacing := JHDR.AlphaInterlacing; - - GetImageFormatInfo(AlphaImage.Format, FmtInfo); - StoreImageToPNGFrame(FakeIHDR, AlphaImage.Bits, FmtInfo, IDATStream); - end; - - FreeImage(ColorImage); - FreeImage(AlphaImage); - end - else - begin - // Simply write JPEG to stream - SaveJpegToStream(JDATStream, Image); - end; -end; - -{$ENDIF} - -procedure TNGFileSaver.AddFrame(const Image: TImageData; IsJpegFrame: Boolean); -var - Frame: TFrameInfo; - FmtInfo: TImageFormatInfo; - - procedure StorePalette; - var - Pal: PPalette24; - Alphas: PByteArray; - I, PalBytes: LongInt; - AlphasDiffer: Boolean; - begin - // Fill and save RGB part of palette to PLTE chunk - PalBytes := FmtInfo.PaletteEntries * SizeOf(TColor24Rec); - GetMem(Pal, PalBytes); - AlphasDiffer := False; - for I := 0 to FmtInfo.PaletteEntries - 1 do - begin - Pal[I].B := Image.Palette[I].R; - Pal[I].G := Image.Palette[I].G; - Pal[I].R := Image.Palette[I].B; - if Image.Palette[I].A < 255 then - AlphasDiffer := True; - end; - Frame.Palette := Pal; - Frame.PaletteEntries := FmtInfo.PaletteEntries; - // Fill and save alpha part (if there are any alphas < 255) of palette to tRNS chunk - if AlphasDiffer then - begin - PalBytes := FmtInfo.PaletteEntries * SizeOf(Byte); - GetMem(Alphas, PalBytes); - for I := 0 to FmtInfo.PaletteEntries - 1 do - Alphas[I] := Image.Palette[I].A; - Frame.Transparency := Alphas; - Frame.TransparencySize := PalBytes; - end; - end; - -begin - // Add new frame - Frame := AddFrameInfo; - Frame.IsJpegFrame := IsJpegFrame; - - with Frame do - begin - GetImageFormatInfo(Image.Format, FmtInfo); - - if IsJpegFrame then - begin -{$IFNDEF DONT_LINK_JNG} - // Fill JNG header - JHDR.Width := Image.Width; - JHDR.Height := Image.Height; - case Image.Format of - ifGray8: JHDR.ColorType := 8; - ifR8G8B8: JHDR.ColorType := 10; - ifA8Gray8: JHDR.ColorType := 12; - ifA8R8G8B8: JHDR.ColorType := 14; - end; - JHDR.SampleDepth := 8; // 8-bit samples and quantization tables - JHDR.Compression := 8; // Huffman coding - JHDR.Interlacing := Iff(Progressive, 8, 0); - JHDR.AlphaSampleDepth := Iff(FmtInfo.HasAlphaChannel, 8, 0); - JHDR.AlphaCompression := Iff(LossyAlpha, 8, 0); - JHDR.AlphaFilter := 0; - JHDR.AlphaInterlacing := 0; - - StoreImageToJNGFrame(JHDR, Image, IDATMemory, JDATMemory, JDAAMemory); - - // Finally swap endian - SwapEndianLongWord(@JHDR, 2); -{$ENDIF} - end - else - begin - // Fill PNG header - IHDR.Width := Image.Width; - IHDR.Height := Image.Height; - IHDR.Compression := 0; - IHDR.Filter := 0; - IHDR.Interlacing := 0; - IHDR.BitDepth := FmtInfo.BytesPerPixel * 8; - - // Select appropiate PNG color type and modify bitdepth - if FmtInfo.HasGrayChannel then - begin - IHDR.ColorType := 0; - if FmtInfo.HasAlphaChannel then - begin - IHDR.ColorType := 4; - IHDR.BitDepth := IHDR.BitDepth div 2; - end; - end - else - begin - if FmtInfo.IsIndexed then - IHDR.ColorType := 3 - else - if FmtInfo.HasAlphaChannel then - begin - IHDR.ColorType := 6; - IHDR.BitDepth := IHDR.BitDepth div 4; - end - else - begin - IHDR.ColorType := 2; - IHDR.BitDepth := IHDR.BitDepth div 3; - end; - end; - - if FileType = ngAPNG then - begin - // Fill fcTL chunk of APNG file - fcTL.SeqNumber := 0; // Decided when writing to file - fcTL.Width := IHDR.Width; - fcTL.Height := IHDR.Height; - fcTL.XOffset := 0; - fcTL.YOffset := 0; - fcTL.DelayNumer := 1; - fcTL.DelayDenom := 3; - fcTL.DisposeOp := DisposeOpNone; - fcTL.BlendOp := BlendOpSource; - SwapEndianLongWord(@fcTL, 5); - fcTL.DelayNumer := SwapEndianWord(fcTL.DelayNumer); - fcTL.DelayDenom := SwapEndianWord(fcTL.DelayDenom); - end; - - // Compress PNG image and store it to stream - StoreImageToPNGFrame(IHDR, Image.Bits, FmtInfo, IDATMemory); - // Store palette if necesary - if FmtInfo.IsIndexed then - StorePalette; - - // Finally swap endian - SwapEndianLongWord(@IHDR, 2); - end; - end; -end; - -function TNGFileSaver.SaveFile(Handle: TImagingHandle): Boolean; -var - I: LongInt; - Chunk: TChunkHeader; - SeqNo: LongWord; - - function GetNextSeqNo: LongWord; - begin - // Seq numbers of fcTL and fdAT are "interleaved" as they share the counter. - // Example: first fcTL for IDAT has seq=0, next is fcTL for seond frame with - // seq=1, then first fdAT with seq=2, fcTL seq=3, fdAT=4, ... - Result := SwapEndianLongWord(SeqNo); - Inc(SeqNo); - end; - - function CalcChunkCrc(const ChunkHdr: TChunkHeader; Data: Pointer; - Size: LongInt): LongWord; - begin - Result := $FFFFFFFF; - CalcCrc32(Result, @ChunkHdr.ChunkID, SizeOf(ChunkHdr.ChunkID)); - CalcCrc32(Result, Data, Size); - Result := SwapEndianLongWord(Result xor $FFFFFFFF); - end; - - procedure WriteChunk(var Chunk: TChunkHeader; ChunkData: Pointer); - var - ChunkCrc: LongWord; - SizeToWrite: LongInt; - begin - SizeToWrite := Chunk.DataSize; - Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize); - ChunkCrc := CalcChunkCrc(Chunk, ChunkData, SizeToWrite); - GetIO.Write(Handle, @Chunk, SizeOf(Chunk)); - if SizeToWrite <> 0 then - GetIO.Write(Handle, ChunkData, SizeToWrite); - GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc)); - end; - - procedure WritefdAT(Frame: TFrameInfo); - var - ChunkCrc: LongWord; - ChunkSeqNo: LongWord; - begin - Chunk.ChunkID := fdATChunk; - ChunkSeqNo := GetNextSeqNo; - // fdAT saves seq number LongWord before compressed pixels - Chunk.DataSize := Frame.IDATMemory.Size + SizeOf(LongWord); - Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize); - // Calc CRC - ChunkCrc := $FFFFFFFF; - CalcCrc32(ChunkCrc, @Chunk.ChunkID, SizeOf(Chunk.ChunkID)); - CalcCrc32(ChunkCrc, @ChunkSeqNo, SizeOf(ChunkSeqNo)); - CalcCrc32(ChunkCrc, Frame.IDATMemory.Memory, Frame.IDATMemory.Size); - ChunkCrc := SwapEndianLongWord(ChunkCrc xor $FFFFFFFF); - // Write out all fdAT data - GetIO.Write(Handle, @Chunk, SizeOf(Chunk)); - GetIO.Write(Handle, @ChunkSeqNo, SizeOf(ChunkSeqNo)); - GetIO.Write(Handle, Frame.IDATMemory.Memory, Frame.IDATMemory.Size); - GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc)); - end; - - procedure WritePNGMainImageChunks(Frame: TFrameInfo); - begin - with Frame do - begin - // Write IHDR chunk - Chunk.DataSize := SizeOf(IHDR); - Chunk.ChunkID := IHDRChunk; - WriteChunk(Chunk, @IHDR); - // Write PLTE chunk if data is present - if Palette <> nil then - begin - Chunk.DataSize := PaletteEntries * SizeOf(TColor24Rec); - Chunk.ChunkID := PLTEChunk; - WriteChunk(Chunk, Palette); - end; - // Write tRNS chunk if data is present - if Transparency <> nil then - begin - Chunk.DataSize := TransparencySize; - Chunk.ChunkID := tRNSChunk; - WriteChunk(Chunk, Transparency); - end; - end; - end; - -begin - Result := False; - SeqNo := 0; - - case FileType of - ngPNG, ngAPNG: GetIO.Write(Handle, @PNGSignature, SizeOf(TChar8)); - ngMNG: GetIO.Write(Handle, @MNGSignature, SizeOf(TChar8)); - ngJNG: GetIO.Write(Handle, @JNGSignature, SizeOf(TChar8)); - end; - - if FileType = ngMNG then - begin - SwapEndianLongWord(@MHDR, SizeOf(MHDR) div SizeOf(LongWord)); - Chunk.DataSize := SizeOf(MHDR); - Chunk.ChunkID := MHDRChunk; - WriteChunk(Chunk, @MHDR); - end; - - for I := 0 to Length(Frames) - 1 do - with Frames[I] do - begin - if IsJpegFrame then - begin - // Write JHDR chunk - Chunk.DataSize := SizeOf(JHDR); - Chunk.ChunkID := JHDRChunk; - WriteChunk(Chunk, @JHDR); - // Write JNG image data - Chunk.DataSize := JDATMemory.Size; - Chunk.ChunkID := JDATChunk; - WriteChunk(Chunk, JDATMemory.Memory); - // Write alpha channel if present - if JHDR.AlphaSampleDepth > 0 then - begin - if JHDR.AlphaCompression = 0 then - begin - // Alpha is PNG compressed - Chunk.DataSize := IDATMemory.Size; - Chunk.ChunkID := IDATChunk; - WriteChunk(Chunk, IDATMemory.Memory); - end - else - begin - // Alpha is JNG compressed - Chunk.DataSize := JDAAMemory.Size; - Chunk.ChunkID := JDAAChunk; - WriteChunk(Chunk, JDAAMemory.Memory); - end; - end; - // Write image end - Chunk.DataSize := 0; - Chunk.ChunkID := IENDChunk; - WriteChunk(Chunk, nil); - end - else if FileType <> ngAPNG then - begin - // Regular PNG frame (single PNG image or MNG frame) - WritePNGMainImageChunks(Frames[I]); - // Write PNG image data - Chunk.DataSize := IDATMemory.Size; - Chunk.ChunkID := IDATChunk; - WriteChunk(Chunk, IDATMemory.Memory); - // Write image end - Chunk.DataSize := 0; - Chunk.ChunkID := IENDChunk; - WriteChunk(Chunk, nil); - end - else if FileType = ngAPNG then - begin - // APNG frame - first frame must have acTL and fcTL before IDAT, - // subsequent frames have fcTL and fdAT. - if I = 0 then - begin - WritePNGMainImageChunks(Frames[I]); - Chunk.DataSize := SizeOf(acTL); - Chunk.ChunkID := acTLChunk; - WriteChunk(Chunk, @acTL); - end; - // Write fcTL before frame data - Chunk.DataSize := SizeOf(fcTL); - Chunk.ChunkID := fcTLChunk; - fcTl.SeqNumber := GetNextSeqNo; - WriteChunk(Chunk, @fcTL); - // Write data - IDAT for first frame and fdAT for following ones - if I = 0 then - begin - Chunk.DataSize := IDATMemory.Size; - Chunk.ChunkID := IDATChunk; - WriteChunk(Chunk, IDATMemory.Memory); - end - else - WritefdAT(Frames[I]); - // Write image end after last frame - if I = Length(Frames) - 1 then - begin - Chunk.DataSize := 0; - Chunk.ChunkID := IENDChunk; - WriteChunk(Chunk, nil); - end; - end; - end; - - if FileType = ngMNG then - begin - Chunk.DataSize := 0; - Chunk.ChunkID := MENDChunk; - WriteChunk(Chunk, nil); - end; -end; - -procedure TNGFileSaver.SetFileOptions(FileFormat: TNetworkGraphicsFileFormat); -begin - PreFilter := FileFormat.FPreFilter; - CompressLevel := FileFormat.FCompressLevel; - LossyAlpha := FileFormat.FLossyAlpha; - Quality := FileFormat.FQuality; - Progressive := FileFormat.FProgressive; -end; - -{ TAPNGAnimator class implemnetation } - -class procedure TAPNGAnimator.Animate(var Images: TDynImageDataArray; - const acTL: TacTL; const SrcFrames: array of TFrameInfo); -var - I, SrcIdx, Offset, Len: Integer; - DestFrames: TDynImageDataArray; - SrcCanvas, DestCanvas: TImagingCanvas; - PreviousCache: TImageData; - - function AnimatingNeeded: Boolean; - var - I: Integer; - begin - Result := False; - for I := 0 to Len - 1 do - with SrcFrames[I] do - begin - if (FrameWidth <> IHDR.Width) or (FrameHeight <> IHDR.Height) or (Len <> acTL.NumFrames) or - (not ((fcTL.DisposeOp = DisposeOpNone) and (fcTL.BlendOp = BlendOpSource)) and - not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpSource)) and - not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpOver))) then - begin - Result := True; - Exit; - end; - end; - end; - -begin - Len := Length(SrcFrames); - if (Len = 0) or not AnimatingNeeded then - Exit; - - if (Len = acTL.NumFrames + 1) and (SrcFrames[0].fcTL.Width = 0) then - begin - // If default image (stored in IDAT chunk) isn't part of animation we ignore it - Offset := 1; - Len := Len - 1; - end - else - Offset := 0; - - SetLength(DestFrames, Len); - DestCanvas := ImagingCanvases.FindBestCanvasForImage(Images[0]).Create; - SrcCanvas := ImagingCanvases.FindBestCanvasForImage(Images[0]).Create; - InitImage(PreviousCache); - NewImage(SrcFrames[0].IHDR.Width, SrcFrames[0].IHDR.Height, Images[0].Format, PreviousCache); - - for I := 0 to Len - 1 do - begin - SrcIdx := I + Offset; - NewImage(SrcFrames[SrcIdx].IHDR.Width, SrcFrames[SrcIdx].IHDR.Height, - Images[SrcIdx].Format, DestFrames[I]); - if DestFrames[I].Format = ifIndex8 then - Move(Images[SrcIdx].Palette^, DestFrames[I].Palette^, 256 * SizeOf(TColor32)); - DestCanvas.CreateForData(@DestFrames[I]); - - if (SrcFrames[SrcIdx].fcTL.DisposeOp = DisposeOpPrevious) and (SrcFrames[SrcIdx - 1].fcTL.DisposeOp <> DisposeOpPrevious) then - begin - // Cache current output buffer so we may return to it later (previous dispose op) - CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height, - PreviousCache, 0, 0); - end; - - if (I = 0) or (SrcIdx = 0) then - begin - // Clear whole frame with transparent black color (default for first frame) - DestCanvas.FillColor32 := pcClear; - DestCanvas.Clear; - end - else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpBackground then - begin - // Restore background color (clear) on previous frame's area and leave previous content outside of it - CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height, - DestFrames[I], 0, 0); - DestCanvas.FillColor32 := pcClear; - DestCanvas.FillRect(BoundsToRect(SrcFrames[SrcIdx - 1].fcTL.XOffset, SrcFrames[SrcIdx - 1].fcTL.YOffset, - SrcFrames[SrcIdx - 1].FrameWidth, SrcFrames[SrcIdx - 1].FrameHeight)); - end - else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpNone then - begin - // Clone previous frame - no change to output buffer - CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height, - DestFrames[I], 0, 0); - end - else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpPrevious then - begin - // Revert to previous frame (cached, can't just restore DestFrames[I - 2]) - CopyRect(PreviousCache, 0, 0, PreviousCache.Width, PreviousCache.Height, - DestFrames[I], 0, 0); - end; - - // Copy pixels or alpha blend them over - if SrcFrames[SrcIdx].fcTL.BlendOp = BlendOpSource then - begin - CopyRect(Images[SrcIdx], 0, 0, Images[SrcIdx].Width, Images[SrcIdx].Height, - DestFrames[I], SrcFrames[SrcIdx].fcTL.XOffset, SrcFrames[SrcIdx].fcTL.YOffset); - end - else if SrcFrames[SrcIdx].fcTL.BlendOp = BlendOpOver then - begin - SrcCanvas.CreateForData(@Images[SrcIdx]); - SrcCanvas.DrawAlpha(SrcCanvas.ClipRect, DestCanvas, - SrcFrames[SrcIdx].fcTL.XOffset, SrcFrames[SrcIdx].fcTL.YOffset); - end; - - FreeImage(Images[SrcIdx]); - end; - - DestCanvas.Free; - SrcCanvas.Free; - FreeImage(PreviousCache); - - // Assign dest frames to final output images - Images := DestFrames; -end; - -{ TNetworkGraphicsFileFormat class implementation } - -constructor TNetworkGraphicsFileFormat.Create; -begin - inherited Create; - FCanLoad := True; - FCanSave := True; - FIsMultiImageFormat := False; - - FPreFilter := NGDefaultPreFilter; - FCompressLevel := NGDefaultCompressLevel; - FLossyAlpha := NGDefaultLossyAlpha; - FLossyCompression := NGDefaultLossyCompression; - FQuality := NGDefaultQuality; - FProgressive := NGDefaultProgressive; -end; - -procedure TNetworkGraphicsFileFormat.CheckOptionsValidity; -begin - // Just check if save options has valid values - if not (FPreFilter in [0..6]) then - FPreFilter := NGDefaultPreFilter; - if not (FCompressLevel in [0..9]) then - FCompressLevel := NGDefaultCompressLevel; - if not (FQuality in [1..100]) then - FQuality := NGDefaultQuality; -end; - -function TNetworkGraphicsFileFormat.GetSupportedFormats: TImageFormats; -begin - if FLossyCompression then - Result := NGLossyFormats - else - Result := NGLosslessFormats; -end; - -procedure TNetworkGraphicsFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -var - ConvFormat: TImageFormat; -begin - if not FLossyCompression then - begin - // Convert formats for lossless compression - if Info.HasGrayChannel then - begin - if Info.HasAlphaChannel then - begin - if Info.BytesPerPixel <= 2 then - // Convert <= 16bit grayscale images with alpha to ifA8Gray8 - ConvFormat := ifA8Gray8 - else - // Convert > 16bit grayscale images with alpha to ifA16Gray16 - ConvFormat := ifA16Gray16 - end - else - // Convert grayscale images without alpha to ifGray16 - ConvFormat := ifGray16; - end - else - if Info.IsFloatingPoint then - // Convert floating point images to 64 bit ARGB (or RGB if no alpha) - ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16B16G16R16, ifB16G16R16) - else if Info.HasAlphaChannel or Info.IsSpecial then - // Convert all other images with alpha or special images to A8R8G8B8 - ConvFormat := ifA8R8G8B8 - else - // Convert images without alpha to R8G8B8 - ConvFormat := ifR8G8B8; - end - else - begin - // Convert formats for lossy compression - if Info.HasGrayChannel then - ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8Gray8, ifGray8) - else - ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8); - end; - - ConvertImage(Image, ConvFormat); -end; - -function TNetworkGraphicsFileFormat.TestFormat(Handle: TImagingHandle): Boolean; -var - ReadCount: LongInt; - Sig: TChar8; -begin - Result := False; - if Handle <> nil then - with GetIO do - begin - FillChar(Sig, SizeOf(Sig), 0); - ReadCount := Read(Handle, @Sig, SizeOf(Sig)); - Seek(Handle, -ReadCount, smFromCurrent); - Result := (ReadCount = SizeOf(Sig)) and (Sig = FSignature); - end; -end; - -{ TPNGFileFormat class implementation } - -constructor TPNGFileFormat.Create; -begin - inherited Create; - FName := SPNGFormatName; - FIsMultiImageFormat := True; - FLoadAnimated := PNGDefaultLoadAnimated; - AddMasks(SPNGMasks); - - FSignature := PNGSignature; - - RegisterOption(ImagingPNGPreFilter, @FPreFilter); - RegisterOption(ImagingPNGCompressLevel, @FCompressLevel); - RegisterOption(ImagingPNGLoadAnimated, @FLoadAnimated); -end; - -function TPNGFileFormat.LoadData(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - I, Len: LongInt; - NGFileLoader: TNGFileLoader; -begin - Result := False; - NGFileLoader := TNGFileLoader.Create; - try - // Use NG file parser to load file - if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then - begin - Len := Length(NGFileLoader.Frames); - SetLength(Images, Len); - for I := 0 to Len - 1 do - with NGFileLoader.Frames[I] do - begin - // Build actual image bits - if not IsJpegFrame then - NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]); - // Build palette, aply color key or background - NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]); - Result := True; - end; - // Animate APNG images - if (NGFileLoader.FileType = ngAPNG) and FLoadAnimated then - TAPNGAnimator.Animate(Images, NGFileLoader.acTL, NGFileLoader.Frames); - end; - finally - NGFileLoader.Free; - end; -end; - -function TPNGFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: LongInt): Boolean; -var - I: Integer; - ImageToSave: TImageData; - MustBeFreed: Boolean; - NGFileSaver: TNGFileSaver; - DefaultFormat: TImageFormat; - Screen: TImageData; - AnimWidth, AnimHeight: Integer; -begin - Result := False; - DefaultFormat := ifDefault; - AnimWidth := 0; - AnimHeight := 0; - NGFileSaver := TNGFileSaver.Create; - - // Save images with more frames as APNG format - if Length(Images) > 1 then - begin - NGFileSaver.FileType := ngAPNG; - NGFileSaver.acTL.NumFrames := FLastIdx - FFirstIdx + 1; - NGFileSaver.acTL.NumPlay := 1; - SwapEndianLongWord(@NGFileSaver.acTL, SizeOf(NGFileSaver.acTL) div SizeOf(LongWord)); - // Get max dimensions of frames - AnimWidth := Images[FFirstIdx].Width; - AnimHeight := Images[FFirstIdx].Height; - for I := FFirstIdx + 1 to FLastIdx do - begin - AnimWidth := Max(AnimWidth, Images[I].Width); - AnimHeight := Max(AnimHeight, Images[I].Height); - end; - end - else - NGFileSaver.FileType := ngPNG; - NGFileSaver.SetFileOptions(Self); - - with NGFileSaver do - try - // Store all frames to be saved frames file saver - for I := FFirstIdx to FLastIdx do - begin - if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then - try - if FileType = ngAPNG then - begin - // IHDR chunk is shared for all frames so all frames must have the - // same data format as the first image. - if I = FFirstIdx then - begin - DefaultFormat := ImageToSave.Format; - // Subsequenet frames may be bigger than the first one. - // APNG doens't support this - max allowed size is what's written in - // IHDR - size of main/default/first image. If some frame is - // bigger than the first one we need to resize (create empty bigger - // image and copy) the first frame so all following frames could fit to - // its area. - if (ImageToSave.Width <> AnimWidth) or (ImageToSave.Height <> AnimHeight) then - begin - InitImage(Screen); - NewImage(AnimWidth, AnimHeight, ImageToSave.Format, Screen); - CopyRect(ImageToSave, 0, 0, ImageToSave.Width, ImageToSave.Height, Screen, 0, 0); - if MustBeFreed then - FreeImage(ImageToSave); - ImageToSave := Screen; - end; - end - else if ImageToSave.Format <> DefaultFormat then - begin - if MustBeFreed then - ConvertImage(ImageToSave, DefaultFormat) - else - begin - CloneImage(Images[I], ImageToSave); - ConvertImage(ImageToSave, DefaultFormat); - MustBeFreed := True; - end; - end; - end; - - // Add image as PNG frame - AddFrame(ImageToSave, False); - finally - if MustBeFreed then - FreeImage(ImageToSave); - end - else - Exit; - end; - - // Finally save PNG file - SaveFile(Handle); - Result := True; - finally - NGFileSaver.Free; - end; -end; - -{$IFNDEF DONT_LINK_MNG} - -{ TMNGFileFormat class implementation } - -constructor TMNGFileFormat.Create; -begin - inherited Create; - FName := SMNGFormatName; - FIsMultiImageFormat := True; - AddMasks(SMNGMasks); - - FSignature := MNGSignature; - - RegisterOption(ImagingMNGLossyCompression, @FLossyCompression); - RegisterOption(ImagingMNGLossyAlpha, @FLossyAlpha); - RegisterOption(ImagingMNGPreFilter, @FPreFilter); - RegisterOption(ImagingMNGCompressLevel, @FCompressLevel); - RegisterOption(ImagingMNGQuality, @FQuality); - RegisterOption(ImagingMNGProgressive, @FProgressive); -end; - -function TMNGFileFormat.LoadData(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - NGFileLoader: TNGFileLoader; - I, Len: LongInt; -begin - Result := False; - NGFileLoader := TNGFileLoader.Create; - try - // Use NG file parser to load file - if NGFileLoader.LoadFile(Handle) then - begin - Len := Length(NGFileLoader.Frames); - if Len > 0 then - begin - SetLength(Images, Len); - for I := 0 to Len - 1 do - with NGFileLoader.Frames[I] do - begin - // Build actual image bits - if IsJpegFrame then - NGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight, JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[I]) - else - NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]); - // Build palette, aply color key or background - NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]); - end; - end - else - begin - // Some MNG files (with BASI-IEND streams) dont have actual pixel data - SetLength(Images, 1); - NewImage(NGFileLoader.MHDR.FrameWidth, NGFileLoader.MHDR.FrameWidth, ifDefault, Images[0]); - end; - Result := True; - end; - finally - NGFileLoader.Free; - end; -end; - -function TMNGFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: LongInt): Boolean; -var - NGFileSaver: TNGFileSaver; - I, LargestWidth, LargestHeight: LongInt; - ImageToSave: TImageData; - MustBeFreed: Boolean; -begin - Result := False; - LargestWidth := 0; - LargestHeight := 0; - - NGFileSaver := TNGFileSaver.Create; - NGFileSaver.FileType := ngMNG; - NGFileSaver.SetFileOptions(Self); - - with NGFileSaver do - try - // Store all frames to be saved frames file saver - for I := FFirstIdx to FLastIdx do - begin - if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then - try - // Add image as PNG or JNG frame - AddFrame(ImageToSave, FLossyCompression); - // Remember largest frame width and height - LargestWidth := Iff(LargestWidth < ImageToSave.Width, ImageToSave.Width, LargestWidth); - LargestHeight := Iff(LargestHeight < ImageToSave.Height, ImageToSave.Height, LargestHeight); - finally - if MustBeFreed then - FreeImage(ImageToSave); - end - else - Exit; - end; - - // Fill MNG header - MHDR.FrameWidth := LargestWidth; - MHDR.FrameHeight := LargestHeight; - MHDR.TicksPerSecond := 0; - MHDR.NominalLayerCount := 0; - MHDR.NominalFrameCount := Length(Frames); - MHDR.NominalPlayTime := 0; - MHDR.SimplicityProfile := 473; // 111011001 binary, defines MNG-VLC with transparency and JNG support - - // Finally save MNG file - SaveFile(Handle); - Result := True; - finally - NGFileSaver.Free; - end; -end; - -{$ENDIF} - -{$IFNDEF DONT_LINK_JNG} - -{ TJNGFileFormat class implementation } - -constructor TJNGFileFormat.Create; -begin - inherited Create; - FName := SJNGFormatName; - AddMasks(SJNGMasks); - - FSignature := JNGSignature; - FLossyCompression := True; - - RegisterOption(ImagingJNGLossyAlpha, @FLossyAlpha); - RegisterOption(ImagingJNGAlphaPreFilter, @FPreFilter); - RegisterOption(ImagingJNGAlphaCompressLevel, @FCompressLevel); - RegisterOption(ImagingJNGQuality, @FQuality); - RegisterOption(ImagingJNGProgressive, @FProgressive); -end; - -function TJNGFileFormat.LoadData(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - NGFileLoader: TNGFileLoader; -begin - Result := False; - NGFileLoader := TNGFileLoader.Create; - try - // Use NG file parser to load file - if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then - with NGFileLoader.Frames[0] do - begin - SetLength(Images, 1); - // Build actual image bits - if IsJpegFrame then - NGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight, JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[0]); - // Build palette, aply color key or background - NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[0], Images[0]); - Result := True; - end; - finally - NGFileLoader.Free; - end; -end; - -function TJNGFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: LongInt): Boolean; -var - NGFileSaver: TNGFileSaver; - ImageToSave: TImageData; - MustBeFreed: Boolean; -begin - // Make image JNG compatible, store it in saver, and save it to file - Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed); - if Result then - begin - NGFileSaver := TNGFileSaver.Create; - with NGFileSaver do - try - FileType := ngJNG; - SetFileOptions(Self); - AddFrame(ImageToSave, True); - SaveFile(Handle); - finally - // Free NG saver and compatible image - NGFileSaver.Free; - if MustBeFreed then - FreeImage(ImageToSave); - end; - end; -end; - -{$ENDIF} - -initialization - RegisterImageFileFormat(TPNGFileFormat); -{$IFNDEF DONT_LINK_MNG} - RegisterImageFileFormat(TMNGFileFormat); -{$ENDIF} -{$IFNDEF DONT_LINK_JNG} - RegisterImageFileFormat(TJNGFileFormat); -{$ENDIF} -finalization - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.26.3 Changes/Bug Fixes --------------------------------- - - Added APNG saving support. - - Added APNG support to NG loader and animating to PNG loader. - - -- 0.26.1 Changes/Bug Fixes --------------------------------- - - Changed file format conditional compilation to reflect changes - in LINK symbols. - - -- 0.24.3 Changes/Bug Fixes --------------------------------- - - Changes for better thread safety. - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Added loading of global palettes and transparencies in MNG files - (and by doing so fixed crash when loading images with global PLTE or tRNS). - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Small changes in converting to supported formats. - - MakeCompatible method moved to base class, put ConvertToSupported here. - GetSupportedFormats removed, it is now set in constructor. - - Made public properties for options registered to SetOption/GetOption - functions. - - Changed extensions to filename masks. - - Changed SaveData, LoadData, and MakeCompatible methods according - to changes in base class in Imaging unit. - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - MNG and JNG support added, PNG support redesigned to support NG file handlers - - added classes for working with NG file formats - - stuff from old ImagingPng unit added and that unit was deleted - - unit created and initial stuff added - - -- 0.15 Changes/Bug Fixes ----------------------------------- - - when saving indexed images save alpha to tRNS? - - added some defines and ifdefs to dzlib unit to allow choosing - impaszlib, fpc's paszlib, zlibex or other zlib implementation - - added colorkeying support - - fixed 16bit channel image handling - pixels were not swapped - - fixed arithmetic overflow (in paeth filter) in FPC - - data of unknown chunks are skipped and not needlesly loaded - - -- 0.13 Changes/Bug Fixes ----------------------------------- - - adaptive filtering added to PNG saving - - TPNGFileFormat class added -} - -end. +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains image format loaders/savers for Network Graphics image + file formats PNG, MNG, and JNG.} +unit ImagingNetworkGraphics; + +interface + +{$I ImagingOptions.inc} + +{ If MNG support is enabled we must make sure PNG and JNG are enabled too.} +{$IFNDEF DONT_LINK_MNG} + {$UNDEF DONT_LINK_PNG} + {$UNDEF DONT_LINK_JNG} +{$ENDIF} + +uses + Types, SysUtils, Classes, ImagingTypes, Imaging, ImagingUtility, ImagingFormats, dzlib; + +type + { Basic class for Network Graphics file formats loaders/savers.} + TNetworkGraphicsFileFormat = class(TImageFileFormat) + protected + FSignature: TChar8; + FPreFilter: LongInt; + FCompressLevel: LongInt; + FLossyCompression: LongBool; + FLossyAlpha: LongBool; + FQuality: LongInt; + FProgressive: LongBool; + FZLibStrategy: Integer; + function GetSupportedFormats: TImageFormats; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + procedure Define; override; + public + function TestFormat(Handle: TImagingHandle): Boolean; override; + procedure CheckOptionsValidity; override; + published + { Sets precompression filter used when saving images with lossless compression. + Allowed values are: 0 (none), 1 (sub), 2 (up), 3 (average), 4 (paeth), + 5 (use 0 for indexed/gray images and 4 for RGB/ARGB images), + 6 (adaptive filtering - use best filter for each scanline - very slow). + Note that filters 3 and 4 are much slower than filters 1 and 2. + Default value is 5.} + property PreFilter: LongInt read FPreFilter write FPreFilter; + { Sets ZLib compression level used when saving images with lossless compression. + Allowed values are in range 0 (no compression) to 9 (best compression). + Default value is 5.} + property CompressLevel: LongInt read FCompressLevel write FCompressLevel; + { Specifies whether MNG animation frames are saved with lossy or lossless + compression. Lossless frames are saved as PNG images and lossy frames are + saved as JNG images. Allowed values are 0 (False) and 1 (True). + Default value is 0.} + property LossyCompression: LongBool read FLossyCompression write FLossyCompression; + { Defines whether alpha channel of lossy MNG frames or JNG images + is lossy compressed too. Allowed values are 0 (False) and 1 (True). + Default value is 0.} + property LossyAlpha: LongBool read FLossyAlpha write FLossyAlpha; + { Specifies compression quality used when saving lossy MNG frames or JNG images. + For details look at ImagingJpegQuality option.} + property Quality: LongInt read FQuality write FQuality; + { Specifies whether images are saved in progressive format when saving lossy + MNG frames or JNG images. For details look at ImagingJpegProgressive.} + property Progressive: LongBool read FProgressive write FProgressive; + end; + + { Class for loading Portable Network Graphics Images. + Loads all types of this image format (all images in png test suite) + and saves all types with bitcount >= 8 (non-interlaced only). + Compression level and filtering can be set by options interface. + + Supported ancillary chunks (loading): + tRNS, bKGD + (for indexed images transparency contains alpha values for palette, + RGB/Gray images with transparency are converted to formats with alpha + and pixels with transparent color are replaced with background color + with alpha = 0).} + TPNGFileFormat = class(TNetworkGraphicsFileFormat) + private + FLoadAnimated: LongBool; + protected + procedure Define; override; + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean): Boolean; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + published + property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated; + end; + +{$IFNDEF DONT_LINK_MNG} + { Class for loading Multiple Network Graphics files. + This format has complex animation capabilities but Imaging only + extracts frames. Individual frames are stored as standard PNG or JNG + images. Loads all types of these frames stored in IHDR-IEND and + JHDR-IEND streams (Note that there are MNG chunks + like BASI which define images but does not contain image data itself, + those are ignored). + Imaging saves MNG files as MNG-VLC (very low complexity) so it is basically + an array of image frames without MNG animation chunks. Frames can be saved + as lossless PNG or lossy JNG images (look at TPNGFileFormat and + TJNGFileFormat for info). Every frame can be in different data format. + + Many frame compression settings can be modified by options interface.} + TMNGFileFormat = class(TNetworkGraphicsFileFormat) + protected + procedure Define; override; + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean): Boolean; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + end; +{$ENDIF} + +{$IFNDEF DONT_LINK_JNG} + { Class for loading JPEG Network Graphics Images. + Loads all types of this image format (all images in jng test suite) + and saves all types except 12 bit JPEGs. + Alpha channel in JNG images is stored separately from color/gray data and + can be lossy (as JPEG image) or lossless (as PNG image) compressed. + Type of alpha compression, compression level and quality, + and filtering can be set by options interface. + + Supported ancillary chunks (loading): + tRNS, bKGD + (Images with transparency are converted to formats with alpha + and pixels with transparent color are replaced with background color + with alpha = 0).} + TJNGFileFormat = class(TNetworkGraphicsFileFormat) + protected + procedure Define; override; + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean): Boolean; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + end; +{$ENDIF} + + +implementation + +uses +{$IFNDEF DONT_LINK_JNG} + ImagingJpeg, ImagingIO, +{$ENDIF} + ImagingCanvases; + +const + NGDefaultPreFilter = 5; + NGDefaultCompressLevel = 5; + NGDefaultLossyAlpha = False; + NGDefaultLossyCompression = False; + NGDefaultProgressive = False; + NGDefaultQuality = 90; + NGLosslessFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8, ifGray16, + ifA16Gray16, ifR8G8B8, ifA8R8G8B8, ifR16G16B16, ifA16R16G16B16, ifB16G16R16, + ifA16B16G16R16, ifBinary]; + NGLossyFormats: TImageFormats = [ifGray8, ifA8Gray8, ifR8G8B8, ifA8R8G8B8]; + PNGDefaultLoadAnimated = True; + NGDefaultZLibStrategy = 1; // Z_FILTERED + + SPNGFormatName = 'Portable Network Graphics'; + SPNGMasks = '*.png'; + SMNGFormatName = 'Multiple Network Graphics'; + SMNGMasks = '*.mng'; + SJNGFormatName = 'JPEG Network Graphics'; + SJNGMasks = '*.jng'; + +resourcestring + SErrorLoadingChunk = 'Error when reading %s chunk data. File may be corrupted.'; + +type + { Chunk header.} + TChunkHeader = packed record + DataSize: UInt32; + ChunkID: TChar4; + end; + + { IHDR chunk format - PNG header.} + TIHDR = packed record + Width: UInt32; // Image width + Height: UInt32; // Image height + BitDepth: Byte; // Bits per pixel or bits per sample (for truecolor) + ColorType: Byte; // 0 = grayscale, 2 = truecolor, 3 = palette, + // 4 = gray + alpha, 6 = truecolor + alpha + Compression: Byte; // Compression type: 0 = ZLib + Filter: Byte; // Used precompress filter + Interlacing: Byte; // Used interlacing: 0 = no int, 1 = Adam7 + end; + PIHDR = ^TIHDR; + + { MHDR chunk format - MNG header.} + TMHDR = packed record + FrameWidth: UInt32; // Frame width + FrameHeight: UInt32; // Frame height + TicksPerSecond: UInt32; // FPS of animation + NominalLayerCount: UInt32; // Number of layers in file + NominalFrameCount: UInt32; // Number of frames in file + NominalPlayTime: UInt32; // Play time of animation in ticks + SimplicityProfile: UInt32; // Defines which MNG features are used in this file + end; + PMHDR = ^TMHDR; + + { JHDR chunk format - JNG header.} + TJHDR = packed record + Width: UInt32; // Image width + Height: UInt32; // Image height + ColorType: Byte; // 8 = grayscale (Y), 10 = color (YCbCr), + // 12 = gray + alpha (Y-alpha), 14 = color + alpha (YCbCr-alpha) + SampleDepth: Byte; // 8, 12 or 20 (8 and 12 samples together) bit + Compression: Byte; // Compression type: 8 = Huffman coding + Interlacing: Byte; // 0 = single scan, 8 = progressive + AlphaSampleDepth: Byte; // 0, 1, 2, 4, 8, 16 if alpha compression is 0 (PNG) + // 8 if alpha compression is 8 (JNG) + AlphaCompression: Byte; // 0 = PNG grayscale IDAT, 8 = grayscale 8-bit JPEG + AlphaFilter: Byte; // 0 = PNG filter or no filter (JPEG) + AlphaInterlacing: Byte; // 0 = non interlaced + end; + PJHDR = ^TJHDR; + + { acTL chunk format - APNG animation control.} + TacTL = packed record + NumFrames: UInt32; // Number of frames + NumPlay: UInt32; // Number of times to loop the animation (0 = inf) + end; + PacTL =^TacTL; + + { fcTL chunk format - APNG frame control.} + TfcTL = packed record + SeqNumber: UInt32; // Sequence number of the animation chunk, starting from 0 + Width: UInt32; // Width of the following frame + Height: UInt32; // Height of the following frame + XOffset: UInt32; // X position at which to render the following frame + YOffset: UInt32; // Y position at which to render the following frame + DelayNumer: Word; // Frame delay fraction numerator + DelayDenom: Word; // Frame delay fraction denominator + DisposeOp: Byte; // Type of frame area disposal to be done after rendering this frame + BlendOp: Byte; // Type of frame area rendering for this frame + end; + PfcTL = ^TfcTL; + + { pHYs chunk format - encodes the absolute or relative dimensions of pixels.} + TpHYs = packed record + PixelsPerUnitX: UInt32; + PixelsPerUnitY: UInt32; + UnitSpecifier: Byte; + end; + PpHYs = ^TpHYs; + +const + { PNG file identifier.} + PNGSignature: TChar8 = #$89'PNG'#$0D#$0A#$1A#$0A; + { MNG file identifier.} + MNGSignature: TChar8 = #$8A'MNG'#$0D#$0A#$1A#$0A; + { JNG file identifier.} + JNGSignature: TChar8 = #$8B'JNG'#$0D#$0A#$1A#$0A; + + { Constants for chunk identifiers and signature identifiers. + They are in big-endian format.} + IHDRChunk: TChar4 = 'IHDR'; + IENDChunk: TChar4 = 'IEND'; + MHDRChunk: TChar4 = 'MHDR'; + MENDChunk: TChar4 = 'MEND'; + JHDRChunk: TChar4 = 'JHDR'; + IDATChunk: TChar4 = 'IDAT'; + JDATChunk: TChar4 = 'JDAT'; + JDAAChunk: TChar4 = 'JDAA'; + JSEPChunk: TChar4 = 'JSEP'; + PLTEChunk: TChar4 = 'PLTE'; + BACKChunk: TChar4 = 'BACK'; + DEFIChunk: TChar4 = 'DEFI'; + TERMChunk: TChar4 = 'TERM'; + tRNSChunk: TChar4 = 'tRNS'; + bKGDChunk: TChar4 = 'bKGD'; + gAMAChunk: TChar4 = 'gAMA'; + acTLChunk: TChar4 = 'acTL'; + fcTLChunk: TChar4 = 'fcTL'; + fdATChunk: TChar4 = 'fdAT'; + pHYsChunk: TChar4 = 'pHYs'; + + { APNG frame dispose operations.} + DisposeOpNone = 0; + DisposeOpBackground = 1; + DisposeOpPrevious = 2; + + { APNG frame blending modes} + BlendOpSource = 0; + BlendOpOver = 1; + + { Interlace start and offsets.} + RowStart: array[0..6] of LongInt = (0, 0, 4, 0, 2, 0, 1); + ColumnStart: array[0..6] of LongInt = (0, 4, 0, 2, 0, 1, 0); + RowIncrement: array[0..6] of LongInt = (8, 8, 8, 4, 4, 2, 2); + ColumnIncrement: array[0..6] of LongInt = (8, 8, 4, 4, 2, 2, 1); + +type + { Helper class that holds information about MNG frame in PNG or JNG format.} + TFrameInfo = class + public + Index: Integer; + FrameWidth, FrameHeight: LongInt; + IsJpegFrame: Boolean; + IHDR: TIHDR; + JHDR: TJHDR; + fcTL: TfcTL; + pHYs: TpHYs; + Palette: PPalette24; + PaletteEntries: LongInt; + Transparency: Pointer; + TransparencySize: LongInt; + Background: Pointer; + BackgroundSize: LongInt; + IDATMemory: TMemoryStream; + JDATMemory: TMemoryStream; + JDAAMemory: TMemoryStream; + constructor Create(AIndex: Integer); + destructor Destroy; override; + procedure AssignSharedProps(Source: TFrameInfo); + end; + + { Defines type of Network Graphics file.} + TNGFileType = (ngPNG, ngAPNG, ngMNG, ngJNG); + + TNGFileHandler = class + public + FileFormat: TNetworkGraphicsFileFormat; + FileType: TNGFileType; + Frames: array of TFrameInfo; + MHDR: TMHDR; // Main header for MNG files + acTL: TacTL; // Global anim control for APNG files + GlobalPalette: PPalette24; + GlobalPaletteEntries: LongInt; + GlobalTransparency: Pointer; + GlobalTransparencySize: LongInt; + constructor Create(AFileFormat: TNetworkGraphicsFileFormat); + destructor Destroy; override; + procedure Clear; + function GetLastFrame: TFrameInfo; + function AddFrameInfo: TFrameInfo; + procedure LoadMetaData; + end; + + { Network Graphics file parser and frame converter.} + TNGFileLoader = class(TNGFileHandler) + public + function LoadFile(Handle: TImagingHandle): Boolean; + procedure LoadImageFromPNGFrame(FrameWidth, FrameHeight: LongInt; const IHDR: TIHDR; IDATStream: TMemoryStream; var Image: TImageData); +{$IFNDEF DONT_LINK_JNG} + procedure LoadImageFromJNGFrame(FrameWidth, FrameHeight: LongInt; const JHDR: TJHDR; IDATStream, JDATStream, JDAAStream: TMemoryStream; var Image: TImageData); +{$ENDIF} + procedure ApplyFrameSettings(Frame: TFrameInfo; var Image: TImageData); + end; + + TNGFileSaver = class(TNGFileHandler) + public + PreFilter: LongInt; + CompressLevel: LongInt; + LossyAlpha: Boolean; + Quality: LongInt; + Progressive: Boolean; + ZLibStrategy: Integer; + function SaveFile(Handle: TImagingHandle): Boolean; + procedure AddFrame(const Image: TImageData; IsJpegFrame: Boolean); + procedure StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer; FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream); +{$IFNDEF DONT_LINK_JNG} + procedure StoreImageToJNGFrame(const JHDR: TJHDR; const Image: TImageData; IDATStream, JDATStream, JDAAStream: TMemoryStream); +{$ENDIF} + procedure SetFileOptions; + end; + +{$IFNDEF DONT_LINK_JNG} + TCustomIOJpegFileFormat = class(TJpegFileFormat) + protected + FCustomIO: TIOFunctions; + procedure SetJpegIO(const JpegIO: TIOFunctions); override; + procedure SetCustomIO(const CustomIO: TIOFunctions); + end; +{$ENDIF} + + TAPNGAnimator = class + public + class procedure Animate(var Images: TDynImageDataArray; const acTL: TacTL; const SrcFrames: array of TFrameInfo); + end; + +{ Helper routines } + +function PaethPredictor(A, B, C: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +var + P, PA, PB, PC: LongInt; +begin + P := A + B - C; + PA := Abs(P - A); + PB := Abs(P - B); + PC := Abs(P - C); + if (PA <= PB) and (PA <= PC) then + Result := A + else + if PB <= PC then + Result := B + else + Result := C; +end; + +procedure SwapRGB(Line: PByte; Width, SampleDepth, BytesPerPixel: LongInt); +var + I: LongInt; + Tmp: Word; +begin + case SampleDepth of + 8: + for I := 0 to Width - 1 do + with PColor24Rec(Line)^ do + begin + Tmp := R; + R := B; + B := Tmp; + Inc(Line, BytesPerPixel); + end; + 16: + for I := 0 to Width - 1 do + with PColor48Rec(Line)^ do + begin + Tmp := R; + R := B; + B := Tmp; + Inc(Line, BytesPerPixel); + end; + end; + end; + +{$IFNDEF DONT_LINK_JNG} + +{ TCustomIOJpegFileFormat class implementation } + +procedure TCustomIOJpegFileFormat.SetCustomIO(const CustomIO: TIOFunctions); +begin + FCustomIO := CustomIO; +end; + +procedure TCustomIOJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions); +begin + inherited SetJpegIO(FCustomIO); +end; + +{$ENDIF} + +{ TFrameInfo class implementation } + +constructor TFrameInfo.Create(AIndex: Integer); +begin + Index := AIndex; + IDATMemory := TMemoryStream.Create; + JDATMemory := TMemoryStream.Create; + JDAAMemory := TMemoryStream.Create; +end; + +destructor TFrameInfo.Destroy; +begin + FreeMem(Palette); + FreeMem(Transparency); + FreeMem(Background); + IDATMemory.Free; + JDATMemory.Free; + JDAAMemory.Free; + inherited Destroy; +end; + +procedure TFrameInfo.AssignSharedProps(Source: TFrameInfo); +begin + IHDR := Source.IHDR; + JHDR := Source.JHDR; + PaletteEntries := Source.PaletteEntries; + GetMem(Palette, PaletteEntries * SizeOf(TColor24Rec)); + Move(Source.Palette^, Palette^, PaletteEntries * SizeOf(TColor24Rec)); + TransparencySize := Source.TransparencySize; + GetMem(Transparency, TransparencySize); + Move(Source.Transparency^, Transparency^, TransparencySize); +end; + +{ TNGFileHandler class implementation} + +destructor TNGFileHandler.Destroy; +begin + Clear; + inherited Destroy; +end; + +procedure TNGFileHandler.Clear; +var + I: LongInt; +begin + for I := 0 to Length(Frames) - 1 do + Frames[I].Free; + SetLength(Frames, 0); + FreeMemNil(GlobalPalette); + GlobalPaletteEntries := 0; + FreeMemNil(GlobalTransparency); + GlobalTransparencySize := 0; +end; + +constructor TNGFileHandler.Create(AFileFormat: TNetworkGraphicsFileFormat); +begin + FileFormat := AFileFormat; +end; + +function TNGFileHandler.GetLastFrame: TFrameInfo; +var + Len: LongInt; +begin + Len := Length(Frames); + if Len > 0 then + Result := Frames[Len - 1] + else + Result := nil; +end; + +procedure TNGFileHandler.LoadMetaData; +var + I: Integer; + Delay, Denom: Integer; +begin + if FileType = ngAPNG then + begin + // Num plays of APNG animation + FileFormat.FMetadata.SetMetaItem(SMetaAnimationLoops, acTL.NumPlay); + end; + + for I := 0 to High(Frames) do + begin + if Frames[I].pHYs.UnitSpecifier = 1 then + begin + // Store physical pixel dimensions, in PNG stored as pixels per meter DPM + FileFormat.FMetadata.SetPhysicalPixelSize(ruDpm, Frames[I].pHYs.PixelsPerUnitX, + Frames[I].pHYs.PixelsPerUnitY); + end; + if FileType = ngAPNG then + begin + // Store frame delay of APNG file frame + Denom := Frames[I].fcTL.DelayDenom; + if Denom = 0 then + Denom := 100; + Delay := Round(1000 * (Frames[I].fcTL.DelayNumer / Denom)); + FileFormat.FMetadata.SetMetaItem(SMetaFrameDelay, Delay, I); + end; + end; +end; + +function TNGFileHandler.AddFrameInfo: TFrameInfo; +var + Len: LongInt; +begin + Len := Length(Frames); + SetLength(Frames, Len + 1); + Result := TFrameInfo.Create(Len); + Frames[Len] := Result; +end; + +{ TNGFileLoader class implementation} + +function TNGFileLoader.LoadFile(Handle: TImagingHandle): Boolean; +var + Sig: TChar8; + Chunk: TChunkHeader; + ChunkData: Pointer; + ChunkCrc: UInt32; + + procedure ReadChunk; + begin + GetIO.Read(Handle, @Chunk, SizeOf(Chunk)); + Chunk.DataSize := SwapEndianUInt32(Chunk.DataSize); + end; + + procedure ReadChunkData; + var + ReadBytes: UInt32; + begin + FreeMemNil(ChunkData); + GetMem(ChunkData, Chunk.DataSize); + ReadBytes := GetIO.Read(Handle, ChunkData, Chunk.DataSize); + GetIO.Read(Handle, @ChunkCrc, SizeOf(ChunkCrc)); + if ReadBytes <> Chunk.DataSize then + RaiseImaging(SErrorLoadingChunk, [string(Chunk.ChunkID)]); + end; + + procedure SkipChunkData; + begin + GetIO.Seek(Handle, Chunk.DataSize + SizeOf(ChunkCrc), smFromCurrent); + end; + + procedure StartNewPNGImage; + var + Frame: TFrameInfo; + begin + ReadChunkData; + + if Chunk.ChunkID = fcTLChunk then + begin + if (Length(Frames) = 1) and (Frames[0].IDATMemory.Size = 0) then + begin + // First fcTL chunk maybe for first IDAT frame which is alredy created + Frame := Frames[0]; + end + else + begin + // Subsequent APNG frames with data in fdAT + Frame := AddFrameInfo; + // Copy some shared props from first frame (IHDR is the same for all APNG frames, palette etc) + Frame.AssignSharedProps(Frames[0]); + end; + Frame.fcTL := PfcTL(ChunkData)^; + SwapEndianUInt32(@Frame.fcTL, 5); + Frame.fcTL.DelayNumer := SwapEndianWord(Frame.fcTL.DelayNumer); + Frame.fcTL.DelayDenom := SwapEndianWord(Frame.fcTL.DelayDenom); + Frame.FrameWidth := Frame.fcTL.Width; + Frame.FrameHeight := Frame.fcTL.Height; + end + else + begin + // This is frame defined by IHDR chunk + Frame := AddFrameInfo; + Frame.IHDR := PIHDR(ChunkData)^; + SwapEndianUInt32(@Frame.IHDR, 2); + Frame.FrameWidth := Frame.IHDR.Width; + Frame.FrameHeight := Frame.IHDR.Height; + end; + Frame.IsJpegFrame := False; + end; + + procedure StartNewJNGImage; + var + Frame: TFrameInfo; + begin + ReadChunkData; + Frame := AddFrameInfo; + Frame.IsJpegFrame := True; + Frame.JHDR := PJHDR(ChunkData)^; + SwapEndianUInt32(@Frame.JHDR, 2); + Frame.FrameWidth := Frame.JHDR.Width; + Frame.FrameHeight := Frame.JHDR.Height; + end; + + procedure AppendIDAT; + begin + ReadChunkData; + // Append current IDAT/fdAT chunk to storage stream + if Chunk.ChunkID = IDATChunk then + GetLastFrame.IDATMemory.Write(ChunkData^, Chunk.DataSize) + else if Chunk.ChunkID = fdATChunk then + GetLastFrame.IDATMemory.Write(PByteArray(ChunkData)[4], Chunk.DataSize - SizeOf(UInt32)); + end; + + procedure AppendJDAT; + begin + ReadChunkData; + // Append current JDAT chunk to storage stream + GetLastFrame.JDATMemory.Write(ChunkData^, Chunk.DataSize); + end; + + procedure AppendJDAA; + begin + ReadChunkData; + // Append current JDAA chunk to storage stream + GetLastFrame.JDAAMemory.Write(ChunkData^, Chunk.DataSize); + end; + + procedure LoadPLTE; + begin + ReadChunkData; + if GetLastFrame = nil then + begin + // Load global palette + GetMem(GlobalPalette, Chunk.DataSize); + Move(ChunkData^, GlobalPalette^, Chunk.DataSize); + GlobalPaletteEntries := Chunk.DataSize div 3; + end + else if GetLastFrame.Palette = nil then + begin + if (Chunk.DataSize = 0) and (GlobalPalette <> nil) then + begin + // Use global palette + GetMem(GetLastFrame.Palette, GlobalPaletteEntries * SizeOf(TColor24Rec)); + Move(GlobalPalette^, GetLastFrame.Palette^, GlobalPaletteEntries * SizeOf(TColor24Rec)); + GetLastFrame.PaletteEntries := GlobalPaletteEntries; + end + else + begin + // Load pal from PLTE chunk + GetMem(GetLastFrame.Palette, Chunk.DataSize); + Move(ChunkData^, GetLastFrame.Palette^, Chunk.DataSize); + GetLastFrame.PaletteEntries := Chunk.DataSize div 3; + end; + end; + end; + + procedure LoadtRNS; + begin + ReadChunkData; + if GetLastFrame = nil then + begin + // Load global transparency + GetMem(GlobalTransparency, Chunk.DataSize); + Move(ChunkData^, GlobalTransparency^, Chunk.DataSize); + GlobalTransparencySize := Chunk.DataSize; + end + else if GetLastFrame.Transparency = nil then + begin + if (Chunk.DataSize = 0) and (GlobalTransparency <> nil) then + begin + // Use global transparency + GetMem(GetLastFrame.Transparency, GlobalTransparencySize); + Move(GlobalTransparency^, GetLastFrame.Transparency^, Chunk.DataSize); + GetLastFrame.TransparencySize := GlobalTransparencySize; + end + else + begin + // Load pal from tRNS chunk + GetMem(GetLastFrame.Transparency, Chunk.DataSize); + Move(ChunkData^, GetLastFrame.Transparency^, Chunk.DataSize); + GetLastFrame.TransparencySize := Chunk.DataSize; + end; + end; + end; + + procedure LoadbKGD; + begin + ReadChunkData; + if GetLastFrame.Background = nil then + begin + GetMem(GetLastFrame.Background, Chunk.DataSize); + Move(ChunkData^, GetLastFrame.Background^, Chunk.DataSize); + GetLastFrame.BackgroundSize := Chunk.DataSize; + end; + end; + + procedure HandleacTL; + begin + FileType := ngAPNG; + ReadChunkData; + acTL := PacTL(ChunkData)^; + SwapEndianUInt32(@acTL, SizeOf(acTL) div SizeOf(UInt32)); + end; + + procedure LoadpHYs; + begin + ReadChunkData; + with GetLastFrame do + begin + pHYs := PpHYs(ChunkData)^; + SwapEndianUInt32(@pHYs, SizeOf(pHYs) div SizeOf(UInt32)); + end; + end; + +begin + Result := False; + Clear; + ChunkData := nil; + with GetIO do + try + Read(Handle, @Sig, SizeOf(Sig)); + // Set file type according to the signature + if Sig = PNGSignature then FileType := ngPNG + else if Sig = MNGSignature then FileType := ngMNG + else if Sig = JNGSignature then FileType := ngJNG + else Exit; + + if FileType = ngMNG then + begin + // Store MNG header if present + ReadChunk; + ReadChunkData; + MHDR := PMHDR(ChunkData)^; + SwapEndianUInt32(@MHDR, SizeOf(MHDR) div SizeOf(UInt32)); + end; + + // Read chunks until ending chunk or EOF is reached + repeat + ReadChunk; + if (Chunk.ChunkID = IHDRChunk) or (Chunk.ChunkID = fcTLChunk) then StartNewPNGImage + else if Chunk.ChunkID = JHDRChunk then StartNewJNGImage + else if (Chunk.ChunkID = IDATChunk) or (Chunk.ChunkID = fdATChunk) then AppendIDAT + else if Chunk.ChunkID = JDATChunk then AppendJDAT + else if Chunk.ChunkID = JDAAChunk then AppendJDAA + else if Chunk.ChunkID = PLTEChunk then LoadPLTE + else if Chunk.ChunkID = tRNSChunk then LoadtRNS + else if Chunk.ChunkID = bKGDChunk then LoadbKGD + else if Chunk.ChunkID = acTLChunk then HandleacTL + else if Chunk.ChunkID = pHYsChunk then LoadpHYs + else SkipChunkData; + until Eof(Handle) or (Chunk.ChunkID = MENDChunk) or + ((FileType <> ngMNG) and (Chunk.ChunkID = IENDChunk)); + + Result := True; + finally + FreeMemNil(ChunkData); + end; +end; + +procedure TNGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight: LongInt; const IHDR: TIHDR; + IDATStream: TMemoryStream; var Image: TImageData); +type + TGetPixelFunc = function(Line: PByteArray; X: LongInt): Byte; +var + LineBuffer: array[Boolean] of PByteArray; + ActLine: Boolean; + Data, TotalBuffer, ZeroLine, PrevLine: Pointer; + BitCount, TotalPos, BytesPerPixel, I, Pass, + SrcDataSize, BytesPerLine, InterlaceLineBytes, InterlaceWidth: LongInt; + TotalSize: Integer; + Info: TImageFormatInfo; + + procedure DecodeAdam7; + const + BitTable: array[1..8] of LongInt = ($1, $3, 0, $F, 0, 0, 0, $FF); + StartBit: array[1..8] of LongInt = (7, 6, 0, 4, 0, 0, 0, 0); + var + Src, Dst, Dst2: PByte; + CurBit, Col: LongInt; + begin + Src := @LineBuffer[ActLine][1]; + Col := ColumnStart[Pass]; + with Image do + case BitCount of + 1, 2, 4: + begin + Dst := @PByteArray(Data)[I * BytesPerLine]; + repeat + CurBit := StartBit[BitCount]; + repeat + Dst2 := @PByteArray(Dst)[(BitCount * Col) shr 3]; + Dst2^ := Dst2^ or ((Src^ shr CurBit) and BitTable[BitCount]) + shl (StartBit[BitCount] - (Col * BitCount mod 8)); + Inc(Col, ColumnIncrement[Pass]); + Dec(CurBit, BitCount); + until CurBit < 0; + Inc(Src); + until Col >= Width; + end; + else + begin + Dst := @PByteArray(Data)[I * BytesPerLine + Col * BytesPerPixel]; + repeat + CopyPixel(Src, Dst, BytesPerPixel); + Inc(Dst, BytesPerPixel); + Inc(Src, BytesPerPixel); + Inc(Dst, ColumnIncrement[Pass] * BytesPerPixel - BytesPerPixel); + Inc(Col, ColumnIncrement[Pass]); + until Col >= Width; + end; + end; + end; + + procedure FilterScanline(Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray; + BytesPerLine: LongInt); + var + I: LongInt; + begin + case Filter of + 0: + begin + // No filter + Move(Line^, Target^, BytesPerLine); + end; + 1: + begin + // Sub filter + Move(Line^, Target^, BytesPerPixel); + for I := BytesPerPixel to BytesPerLine - 1 do + Target[I] := (Line[I] + Target[I - BytesPerPixel]) and $FF; + end; + 2: + begin + // Up filter + for I := 0 to BytesPerLine - 1 do + Target[I] := (Line[I] + PrevLine[I]) and $FF; + end; + 3: + begin + // Average filter + for I := 0 to BytesPerPixel - 1 do + Target[I] := (Line[I] + PrevLine[I] shr 1) and $FF; + for I := BytesPerPixel to BytesPerLine - 1 do + Target[I] := (Line[I] + (Target[I - BytesPerPixel] + PrevLine[I]) shr 1) and $FF; + end; + 4: + begin + // Paeth filter + for I := 0 to BytesPerPixel - 1 do + Target[I] := (Line[I] + PaethPredictor(0, PrevLine[I], 0)) and $FF; + for I := BytesPerPixel to BytesPerLine - 1 do + Target[I] := (Line[I] + PaethPredictor(Target[I - BytesPerPixel], PrevLine[I], PrevLine[I - BytesPerPixel])) and $FF; + end; + end; + end; + + procedure TransformLOCOToRGB(Data: PByte; NumPixels, BytesPerPixel: LongInt); + var + I: LongInt; + begin + for I := 0 to NumPixels - 1 do + begin + if IHDR.BitDepth = 8 then + begin + PColor32Rec(Data).R := Byte(PColor32Rec(Data).R + PColor32Rec(Data).G); + PColor32Rec(Data).B := Byte(PColor32Rec(Data).B + PColor32Rec(Data).G); + end + else + begin + PColor64Rec(Data).R := Word(PColor64Rec(Data).R + PColor64Rec(Data).G); + PColor64Rec(Data).B := Word(PColor64Rec(Data).B + PColor64Rec(Data).G); + end; + Inc(Data, BytesPerPixel); + end; + end; + + function CheckBinaryPalette: Boolean; + begin + with GetLastFrame do + Result := (PaletteEntries = 2) and + (Palette[0].R = 0) and (Palette[0].G = 0) and (Palette[0].B = 0) and + (Palette[1].R = 255) and (Palette[1].G = 255) and (Palette[1].B = 255); + end; + +begin + Image.Width := FrameWidth; + Image.Height := FrameHeight; + Image.Format := ifUnknown; + + case IHDR.ColorType of + 0: + begin + // Gray scale image + case IHDR.BitDepth of + 1: Image.Format := ifBinary; + 2, 4, 8: Image.Format := ifGray8; + 16: Image.Format := ifGray16; + end; + BitCount := IHDR.BitDepth; + end; + 2: + begin + // RGB image + case IHDR.BitDepth of + 8: Image.Format := ifR8G8B8; + 16: Image.Format := ifR16G16B16; + end; + BitCount := IHDR.BitDepth * 3; + end; + 3: + begin + // Indexed image + if (IHDR.BitDepth = 1) and CheckBinaryPalette then + Image.Format := ifBinary + else + Image.Format := ifIndex8; + BitCount := IHDR.BitDepth; + end; + 4: + begin + // Grayscale + alpha image + case IHDR.BitDepth of + 8: Image.Format := ifA8Gray8; + 16: Image.Format := ifA16Gray16; + end; + BitCount := IHDR.BitDepth * 2; + end; + 6: + begin + // ARGB image + case IHDR.BitDepth of + 8: Image.Format := ifA8R8G8B8; + 16: Image.Format := ifA16R16G16B16; + end; + BitCount := IHDR.BitDepth * 4; + end; + end; + + GetImageFormatInfo(Image.Format, Info); + BytesPerPixel := (BitCount + 7) div 8; + + LineBuffer[True] := nil; + LineBuffer[False] := nil; + TotalBuffer := nil; + ZeroLine := nil; + ActLine := True; + + // Start decoding + with Image do + try + BytesPerLine := (Width * BitCount + 7) div 8; + SrcDataSize := Height * BytesPerLine; + GetMem(Data, SrcDataSize); + FillChar(Data^, SrcDataSize, 0); + GetMem(ZeroLine, BytesPerLine); + FillChar(ZeroLine^, BytesPerLine, 0); + + if IHDR.Interlacing = 1 then + begin + // Decode interlaced images + TotalPos := 0; + DecompressBuf(IDATStream.Memory, IDATStream.Size, 0, + Pointer(TotalBuffer), TotalSize); + GetMem(LineBuffer[True], BytesPerLine + 1); + GetMem(LineBuffer[False], BytesPerLine + 1); + for Pass := 0 to 6 do + begin + // Prepare next interlace run + if Width <= ColumnStart[Pass] then + Continue; + InterlaceWidth := (Width + ColumnIncrement[Pass] - 1 - + ColumnStart[Pass]) div ColumnIncrement[Pass]; + InterlaceLineBytes := (InterlaceWidth * BitCount + 7) shr 3; + I := RowStart[Pass]; + FillChar(LineBuffer[True][0], BytesPerLine + 1, 0); + FillChar(LineBuffer[False][0], BytesPerLine + 1, 0); + while I < Height do + begin + // Copy line from decompressed data to working buffer + Move(PByteArray(TotalBuffer)[TotalPos], + LineBuffer[ActLine][0], InterlaceLineBytes + 1); + Inc(TotalPos, InterlaceLineBytes + 1); + // Swap red and blue channels if necessary + if (IHDR.ColorType in [2, 6]) then + SwapRGB(@LineBuffer[ActLine][1], InterlaceWidth, IHDR.BitDepth, BytesPerPixel); + // Reverse-filter current scanline + FilterScanline(LineBuffer[ActLine][0], BytesPerPixel, + @LineBuffer[ActLine][1], @LineBuffer[not ActLine][1], + @LineBuffer[ActLine][1], InterlaceLineBytes); + // Decode Adam7 interlacing + DecodeAdam7; + ActLine := not ActLine; + // Continue with next row in interlaced order + Inc(I, RowIncrement[Pass]); + end; + end; + end + else + begin + // Decode non-interlaced images + PrevLine := ZeroLine; + DecompressBuf(IDATStream.Memory, IDATStream.Size, SrcDataSize + Height, + Pointer(TotalBuffer), TotalSize); + for I := 0 to Height - 1 do + begin + // Swap red and blue channels if necessary + if IHDR.ColorType in [2, 6] then + SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], Width, + IHDR.BitDepth, BytesPerPixel); + // reverse-filter current scanline + FilterScanline(PByteArray(TotalBuffer)[I * (BytesPerLine + 1)], + BytesPerPixel, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], + PrevLine, @PByteArray(Data)[I * BytesPerLine], BytesPerLine); + PrevLine := @PByteArray(Data)[I * BytesPerLine]; + end; + end; + + Size := Info.GetPixelsSize(Info.Format, Width, Height); + + if Size <> SrcDataSize then + begin + // If source data size is different from size of image in assigned + // format we must convert it (it is in 1/2/4 bit count) + GetMem(Bits, Size); + case IHDR.BitDepth of + 1: + begin + // Convert only indexed, keep black and white in ifBinary + if IHDR.ColorType <> 0 then + Convert1To8(Data, Bits, Width, Height, BytesPerLine, False); + end; + 2: Convert2To8(Data, Bits, Width, Height, BytesPerLine, IHDR.ColorType = 0); + 4: Convert4To8(Data, Bits, Width, Height, BytesPerLine, IHDR.ColorType = 0); + end; + FreeMem(Data); + end + else + begin + // If source data size is the same as size of + // image Bits in assigned format we simply copy pointer reference + Bits := Data; + end; + + // LOCO transformation was used too (only for color types 2 and 6) + if (IHDR.Filter = 64) and (IHDR.ColorType in [2, 6]) then + TransformLOCOToRGB(Bits, Width * Height, BytesPerPixel); + + // Images with 16 bit channels must be swapped because of PNG's big endianity + if IHDR.BitDepth = 16 then + SwapEndianWord(Bits, Width * Height * BytesPerPixel div SizeOf(Word)); + finally + FreeMem(LineBuffer[True]); + FreeMem(LineBuffer[False]); + FreeMem(TotalBuffer); + FreeMem(ZeroLine); + end; +end; + +{$IFNDEF DONT_LINK_JNG} + +procedure TNGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight: LongInt; const JHDR: TJHDR; IDATStream, + JDATStream, JDAAStream: TMemoryStream; var Image: TImageData); +var + AlphaImage: TImageData; + FakeIHDR: TIHDR; + FmtInfo: TImageFormatInfo; + I: LongInt; + AlphaPtr: PByte; + GrayPtr: PWordRec; + ColorPtr: PColor32Rec; + + procedure LoadJpegFromStream(Stream: TStream; var DestImage: TImageData); + var + JpegFormat: TCustomIOJpegFileFormat; + Handle: TImagingHandle; + DynImages: TDynImageDataArray; + begin + if JHDR.SampleDepth <> 12 then + begin + JpegFormat := TCustomIOJpegFileFormat.Create; + JpegFormat.SetCustomIO(StreamIO); + Stream.Position := 0; + Handle := StreamIO.Open(Pointer(Stream), omReadOnly); + try + JpegFormat.LoadData(Handle, DynImages, True); + DestImage := DynImages[0]; + finally + StreamIO.Close(Handle); + JpegFormat.Free; + SetLength(DynImages, 0); + end; + end + else + NewImage(FrameWidth, FrameHeight, ifR8G8B8, DestImage); + end; + +begin + LoadJpegFromStream(JDATStream, Image); + + // If present separate alpha channel is processed + if (JHDR.ColorType in [12, 14]) and (Image.Format in [ifGray8, ifR8G8B8]) then + begin + InitImage(AlphaImage); + if JHDR.AlphaCompression = 0 then + begin + // Alpha channel is PNG compressed + FakeIHDR.Width := JHDR.Width; + FakeIHDR.Height := JHDR.Height; + FakeIHDR.ColorType := 0; + FakeIHDR.BitDepth := JHDR.AlphaSampleDepth; + FakeIHDR.Filter := JHDR.AlphaFilter; + FakeIHDR.Interlacing := JHDR.AlphaInterlacing; + + LoadImageFromPNGFrame(FrameWidth, FrameHeight, FakeIHDR, IDATStream, AlphaImage); + end + else + begin + // Alpha channel is JPEG compressed + LoadJpegFromStream(JDAAStream, AlphaImage); + end; + + // Check if alpha channel is the same size as image + if (Image.Width <> AlphaImage.Width) and (Image.Height <> AlphaImage.Height) then + ResizeImage(AlphaImage, Image.Width, Image.Height, rfNearest); + + // Check alpha channels data format + GetImageFormatInfo(AlphaImage.Format, FmtInfo); + if (FmtInfo.BytesPerPixel > 1) or (not FmtInfo.HasGrayChannel) then + ConvertImage(AlphaImage, ifGray8); + + // Convert image to fromat with alpha channel + if Image.Format = ifGray8 then + ConvertImage(Image, ifA8Gray8) + else + ConvertImage(Image, ifA8R8G8B8); + + // Combine alpha channel with image + AlphaPtr := AlphaImage.Bits; + if Image.Format = ifA8Gray8 then + begin + GrayPtr := Image.Bits; + for I := 0 to Image.Width * Image.Height - 1 do + begin + GrayPtr.High := AlphaPtr^; + Inc(GrayPtr); + Inc(AlphaPtr); + end; + end + else + begin + ColorPtr := Image.Bits; + for I := 0 to Image.Width * Image.Height - 1 do + begin + ColorPtr.A := AlphaPtr^; + Inc(ColorPtr); + Inc(AlphaPtr); + end; + end; + + FreeImage(AlphaImage); + end; +end; + +{$ENDIF} + +procedure TNGFileLoader.ApplyFrameSettings(Frame: TFrameInfo; var Image: TImageData); +var + FmtInfo: TImageFormatInfo; + BackGroundColor: TColor64Rec; + ColorKey: TColor64Rec; + Alphas: PByteArray; + AlphasSize: LongInt; + IsColorKeyPresent: Boolean; + IsBackGroundPresent: Boolean; + IsColorFormat: Boolean; + + procedure ConverttRNS; + begin + if FmtInfo.IsIndexed then + begin + if Alphas = nil then + begin + GetMem(Alphas, Frame.TransparencySize); + Move(Frame.Transparency^, Alphas^, Frame.TransparencySize); + AlphasSize := Frame.TransparencySize; + end; + end + else if not FmtInfo.HasAlphaChannel then + begin + FillChar(ColorKey, SizeOf(ColorKey), 0); + Move(Frame.Transparency^, ColorKey, Min(Frame.TransparencySize, SizeOf(ColorKey))); + if IsColorFormat then + SwapValues(ColorKey.R, ColorKey.B); + SwapEndianWord(@ColorKey, 3); + // 1/2/4 bit images were converted to 8 bit so we must convert color key too + if (not Frame.IsJpegFrame) and (Frame.IHDR.ColorType in [0, 4]) then + case Frame.IHDR.BitDepth of + 1: ColorKey.B := Word(ColorKey.B * 255); + 2: ColorKey.B := Word(ColorKey.B * 85); + 4: ColorKey.B := Word(ColorKey.B * 17); + end; + IsColorKeyPresent := True; + end; + end; + + procedure ConvertbKGD; + begin + FillChar(BackGroundColor, SizeOf(BackGroundColor), 0); + Move(Frame.Background^, BackGroundColor, Min(Frame.BackgroundSize, SizeOf(BackGroundColor))); + if IsColorFormat then + SwapValues(BackGroundColor.R, BackGroundColor.B); + SwapEndianWord(@BackGroundColor, 3); + // 1/2/4 bit images were converted to 8 bit so we must convert back color too + if (not Frame.IsJpegFrame) and (Frame.IHDR.ColorType in [0, 4]) then + case Frame.IHDR.BitDepth of + 1: BackGroundColor.B := Word(BackGroundColor.B * 255); + 2: BackGroundColor.B := Word(BackGroundColor.B * 85); + 4: BackGroundColor.B := Word(BackGroundColor.B * 17); + end; + IsBackGroundPresent := True; + end; + + procedure ReconstructPalette; + var + I: LongInt; + begin + with Image do + begin + GetMem(Palette, FmtInfo.PaletteEntries * SizeOf(TColor32Rec)); + FillChar(Palette^, FmtInfo.PaletteEntries * SizeOf(TColor32Rec), $FF); + // if RGB palette was loaded from file then use it + if Frame.Palette <> nil then + for I := 0 to Min(Frame.PaletteEntries, FmtInfo.PaletteEntries) - 1 do + with Palette[I] do + begin + R := Frame.Palette[I].B; + G := Frame.Palette[I].G; + B := Frame.Palette[I].R; + end; + // if palette alphas were loaded from file then use them + if Alphas <> nil then + begin + for I := 0 to Min(AlphasSize, FmtInfo.PaletteEntries) - 1 do + Palette[I].A := Alphas[I]; + end; + end; + end; + + procedure ApplyColorKey; + var + DestFmt: TImageFormat; + Col32, Bkg32: TColor32Rec; + OldPixel, NewPixel: Pointer; + begin + case Image.Format of + ifGray8: DestFmt := ifA8Gray8; + ifGray16: DestFmt := ifA16Gray16; + ifR8G8B8: DestFmt := ifA8R8G8B8; + ifR16G16B16: DestFmt := ifA16R16G16B16; + else + DestFmt := ifUnknown; + end; + + if DestFmt <> ifUnknown then + begin + if not IsBackGroundPresent then + BackGroundColor := ColorKey; + ConvertImage(Image, DestFmt); + + // Now back color and color key must be converted to image's data format, looks ugly + case Image.Format of + ifA8Gray8: + begin + Col32 := Color32(0, 0, $FF, Byte(ColorKey.B)); + Bkg32 := Color32(0, 0, 0, Byte(BackGroundColor.B)); + end; + ifA16Gray16: + begin + ColorKey.G := $FFFF; + end; + ifA8R8G8B8: + begin + Col32 := Color32($FF, Byte(ColorKey.R), Byte(ColorKey.G), Byte(ColorKey.B)); + Bkg32 := Color32(0, Byte(BackGroundColor.R), Byte(BackGroundColor.G), Byte(BackGroundColor.B)); + end; + ifA16R16G16B16: + begin + ColorKey.A := $FFFF; + end; + end; + + if Image.Format in [ifA8Gray8, ifA8R8G8B8] then + begin + OldPixel := @Col32; + NewPixel := @Bkg32; + end + else + begin + OldPixel := @ColorKey; + NewPixel := @BackGroundColor; + end; + + ReplaceColor(Image, 0, 0, Image.Width, Image.Height, OldPixel, NewPixel); + end; + end; + +begin + Alphas := nil; + IsColorKeyPresent := False; + IsBackGroundPresent := False; + GetImageFormatInfo(Image.Format, FmtInfo); + + IsColorFormat := (Frame.IsJpegFrame and (Frame.JHDR.ColorType in [10, 14])) or + (not Frame.IsJpegFrame and (Frame.IHDR.ColorType in [2, 6])); + + // Convert some chunk data to useful format + if Frame.TransparencySize > 0 then + ConverttRNS; + if Frame.BackgroundSize > 0 then + ConvertbKGD; + + // Build palette for indexed images + if FmtInfo.IsIndexed then + ReconstructPalette; + + // Apply color keying + if IsColorKeyPresent and not FmtInfo.HasAlphaChannel then + ApplyColorKey; + + FreeMemNil(Alphas); +end; + +{ TNGFileSaver class implementation } + +procedure TNGFileSaver.StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer; + FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream); +var + TotalBuffer, CompBuffer, ZeroLine, PrevLine: Pointer; + FilterLines: array[0..4] of PByteArray; + TotalSize, CompSize, I, BytesPerLine, BytesPerPixel: Integer; + Filter: Byte; + Adaptive: Boolean; + + procedure FilterScanline(Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray); + var + I: LongInt; + begin + case Filter of + 0: + begin + // No filter + Move(Line^, Target^, BytesPerLine); + end; + 1: + begin + // Sub filter + Move(Line^, Target^, BytesPerPixel); + for I := BytesPerPixel to BytesPerLine - 1 do + Target[I] := (Line[I] - Line[I - BytesPerPixel]) and $FF; + end; + 2: + begin + // Up filter + for I := 0 to BytesPerLine - 1 do + Target[I] := (Line[I] - PrevLine[I]) and $FF; + end; + 3: + begin + // Average filter + for I := 0 to BytesPerPixel - 1 do + Target[I] := (Line[I] - PrevLine[I] shr 1) and $FF; + for I := BytesPerPixel to BytesPerLine - 1 do + Target[I] := (Line[I] - (Line[I - BytesPerPixel] + PrevLine[I]) shr 1) and $FF; + end; + 4: + begin + // Paeth filter + for I := 0 to BytesPerPixel - 1 do + Target[I] := (Line[I] - PaethPredictor(0, PrevLine[I], 0)) and $FF; + for I := BytesPerPixel to BytesPerLine - 1 do + Target[I] := (Line[I] - PaethPredictor(Line[I - BytesPerPixel], PrevLine[I], PrevLine[I - BytesPerPixel])) and $FF; + end; + end; + end; + + procedure AdaptiveFilter(var Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray); + var + I, J, BestTest: LongInt; + Sums: array[0..4] of LongInt; + begin + // Compute the output scanline using all five filters, + // and select the filter that gives the smallest sum of + // absolute values of outputs + FillChar(Sums, SizeOf(Sums), 0); + BestTest := MaxInt; + for I := 0 to 4 do + begin + FilterScanline(I, BytesPerPixel, Line, PrevLine, FilterLines[I]); + for J := 0 to BytesPerLine - 1 do + Sums[I] := Sums[I] + Abs(ShortInt(FilterLines[I][J])); + if Sums[I] < BestTest then + begin + Filter := I; + BestTest := Sums[I]; + end; + end; + Move(FilterLines[Filter]^, Target^, BytesPerLine); + end; + +begin + // Select precompression filter and compression level + Adaptive := False; + Filter := 0; + case PreFilter of + 6: + if not ((IHDR.BitDepth < 8) or (IHDR.ColorType = 3)) then + Adaptive := True; + 0..4: Filter := PreFilter; + else + if IHDR.ColorType in [2, 6] then + Filter := 4 + end; + + // Prepare data for compression + CompBuffer := nil; + FillChar(FilterLines, SizeOf(FilterLines), 0); + BytesPerPixel := Max(1, FmtInfo.BytesPerPixel); + BytesPerLine := FmtInfo.GetPixelsSize(FmtInfo.Format, LongInt(IHDR.Width), 1); + TotalSize := (BytesPerLine + 1) * LongInt(IHDR.Height); + GetMem(TotalBuffer, TotalSize); + GetMem(ZeroLine, BytesPerLine); + FillChar(ZeroLine^, BytesPerLine, 0); + PrevLine := ZeroLine; + + if Adaptive then + begin + for I := 0 to 4 do + GetMem(FilterLines[I], BytesPerLine); + end; + + try + // Process next scanlines + for I := 0 to IHDR.Height - 1 do + begin + // Filter scanline + if Adaptive then + begin + AdaptiveFilter(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine], + PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1]); + end + else + begin + FilterScanline(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine], + PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1]); + end; + PrevLine := @PByteArray(Bits)[I * BytesPerLine]; + // Swap red and blue if necessary + if (IHDR.ColorType in [2, 6]) and not FmtInfo.IsRBSwapped then + begin + SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], + IHDR.Width, IHDR.BitDepth, BytesPerPixel); + end; + // Images with 16 bit channels must be swapped because of PNG's big endianess + if IHDR.BitDepth = 16 then + begin + SwapEndianWord(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], + BytesPerLine div SizeOf(Word)); + end; + // Set filter used for this scanline + PByteArray(TotalBuffer)[I * (BytesPerLine + 1)] := Filter; + end; + // Compress IDAT data + CompressBuf(TotalBuffer, TotalSize, CompBuffer, CompSize, + CompressLevel, ZLibStrategy); + // Write IDAT data to stream + IDATStream.WriteBuffer(CompBuffer^, CompSize); + finally + FreeMem(TotalBuffer); + FreeMem(CompBuffer); + FreeMem(ZeroLine); + if Adaptive then + for I := 0 to 4 do + FreeMem(FilterLines[I]); + end; +end; + +{$IFNDEF DONT_LINK_JNG} + +procedure TNGFileSaver.StoreImageToJNGFrame(const JHDR: TJHDR; + const Image: TImageData; IDATStream, JDATStream, + JDAAStream: TMemoryStream); +var + ColorImage, AlphaImage: TImageData; + FmtInfo: TImageFormatInfo; + AlphaPtr: PByte; + GrayPtr: PWordRec; + ColorPtr: PColor32Rec; + I: LongInt; + FakeIHDR: TIHDR; + + procedure SaveJpegToStream(Stream: TStream; const Image: TImageData); + var + JpegFormat: TCustomIOJpegFileFormat; + Handle: TImagingHandle; + DynImages: TDynImageDataArray; + begin + JpegFormat := TCustomIOJpegFileFormat.Create; + JpegFormat.SetCustomIO(StreamIO); + // Only JDAT stream can be saved progressive + if Stream = JDATStream then + JpegFormat.FProgressive := Progressive + else + JpegFormat.FProgressive := False; + JpegFormat.FQuality := Quality; + SetLength(DynImages, 1); + DynImages[0] := Image; + Handle := StreamIO.Open(Pointer(Stream), omCreate); + try + JpegFormat.SaveData(Handle, DynImages, 0); + finally + StreamIO.Close(Handle); + SetLength(DynImages, 0); + JpegFormat.Free; + end; + end; + +begin + GetImageFormatInfo(Image.Format, FmtInfo); + InitImage(ColorImage); + InitImage(AlphaImage); + + if FmtInfo.HasAlphaChannel then + begin + // Create new image for alpha channel and color image without alpha + CloneImage(Image, ColorImage); + NewImage(Image.Width, Image.Height, ifGray8, AlphaImage); + case Image.Format of + ifA8Gray8: ConvertImage(ColorImage, ifGray8); + ifA8R8G8B8: ConvertImage(ColorImage, ifR8G8B8); + end; + + // Store source image's alpha to separate image + AlphaPtr := AlphaImage.Bits; + if Image.Format = ifA8Gray8 then + begin + GrayPtr := Image.Bits; + for I := 0 to Image.Width * Image.Height - 1 do + begin + AlphaPtr^ := GrayPtr.High; + Inc(GrayPtr); + Inc(AlphaPtr); + end; + end + else + begin + ColorPtr := Image.Bits; + for I := 0 to Image.Width * Image.Height - 1 do + begin + AlphaPtr^ := ColorPtr.A; + Inc(ColorPtr); + Inc(AlphaPtr); + end; + end; + + // Write color image to stream as JPEG + SaveJpegToStream(JDATStream, ColorImage); + + if LossyAlpha then + begin + // Write alpha image to stream as JPEG + SaveJpegToStream(JDAAStream, AlphaImage); + end + else + begin + // Alpha channel is PNG compressed + FakeIHDR.Width := JHDR.Width; + FakeIHDR.Height := JHDR.Height; + FakeIHDR.ColorType := 0; + FakeIHDR.BitDepth := JHDR.AlphaSampleDepth; + FakeIHDR.Filter := JHDR.AlphaFilter; + FakeIHDR.Interlacing := JHDR.AlphaInterlacing; + + GetImageFormatInfo(AlphaImage.Format, FmtInfo); + StoreImageToPNGFrame(FakeIHDR, AlphaImage.Bits, FmtInfo, IDATStream); + end; + + FreeImage(ColorImage); + FreeImage(AlphaImage); + end + else + begin + // Simply write JPEG to stream + SaveJpegToStream(JDATStream, Image); + end; +end; + +{$ENDIF} + +procedure TNGFileSaver.AddFrame(const Image: TImageData; IsJpegFrame: Boolean); +var + Frame: TFrameInfo; + FmtInfo: TImageFormatInfo; + Index: Integer; + + procedure StorePalette; + var + Pal: PPalette24; + Alphas: PByteArray; + I, PalBytes: LongInt; + AlphasDiffer: Boolean; + begin + // Fill and save RGB part of palette to PLTE chunk + PalBytes := FmtInfo.PaletteEntries * SizeOf(TColor24Rec); + GetMem(Pal, PalBytes); + AlphasDiffer := False; + for I := 0 to FmtInfo.PaletteEntries - 1 do + begin + Pal[I].B := Image.Palette[I].R; + Pal[I].G := Image.Palette[I].G; + Pal[I].R := Image.Palette[I].B; + if Image.Palette[I].A < 255 then + AlphasDiffer := True; + end; + Frame.Palette := Pal; + Frame.PaletteEntries := FmtInfo.PaletteEntries; + // Fill and save alpha part (if there are any alphas < 255) of palette to tRNS chunk + if AlphasDiffer then + begin + PalBytes := FmtInfo.PaletteEntries * SizeOf(Byte); + GetMem(Alphas, PalBytes); + for I := 0 to FmtInfo.PaletteEntries - 1 do + Alphas[I] := Image.Palette[I].A; + Frame.Transparency := Alphas; + Frame.TransparencySize := PalBytes; + end; + end; + + procedure FillFrameControlChunk(const IHDR: TIHDR; var fcTL: TfcTL); + var + Delay: Integer; + begin + fcTL.SeqNumber := 0; // Decided when writing to file + fcTL.Width := IHDR.Width; + fcTL.Height := IHDR.Height; + fcTL.XOffset := 0; + fcTL.YOffset := 0; + fcTL.DelayNumer := 1; + fcTL.DelayDenom := 3; + if FileFormat.FMetadata.HasMetaItemForSaving(SMetaFrameDelay, Index) then + begin + // Metadata contains frame delay information in milliseconds + Delay := FileFormat.FMetadata.MetaItemsForSavingMulti[SMetaFrameDelay, Index]; + fcTL.DelayNumer := Delay; + fcTL.DelayDenom := 1000; + end; + fcTL.DisposeOp := DisposeOpNone; + fcTL.BlendOp := BlendOpSource; + SwapEndianUInt32(@fcTL, 5); + fcTL.DelayNumer := SwapEndianWord(fcTL.DelayNumer); + fcTL.DelayDenom := SwapEndianWord(fcTL.DelayDenom); + end; + +begin + // Add new frame + Frame := AddFrameInfo; + Frame.IsJpegFrame := IsJpegFrame; + Index := Length(Frames) - 1; + + with Frame do + begin + GetImageFormatInfo(Image.Format, FmtInfo); + + if IsJpegFrame then + begin +{$IFNDEF DONT_LINK_JNG} + // Fill JNG header + JHDR.Width := Image.Width; + JHDR.Height := Image.Height; + case Image.Format of + ifGray8: JHDR.ColorType := 8; + ifR8G8B8: JHDR.ColorType := 10; + ifA8Gray8: JHDR.ColorType := 12; + ifA8R8G8B8: JHDR.ColorType := 14; + end; + JHDR.SampleDepth := 8; // 8-bit samples and quantization tables + JHDR.Compression := 8; // Huffman coding + JHDR.Interlacing := Iff(Progressive, 8, 0); + JHDR.AlphaSampleDepth := Iff(FmtInfo.HasAlphaChannel, 8, 0); + JHDR.AlphaCompression := Iff(LossyAlpha, 8, 0); + JHDR.AlphaFilter := 0; + JHDR.AlphaInterlacing := 0; + + StoreImageToJNGFrame(JHDR, Image, IDATMemory, JDATMemory, JDAAMemory); + + // Finally swap endian + SwapEndianUInt32(@JHDR, 2); +{$ENDIF} + end + else + begin + // Fill PNG header + IHDR.Width := Image.Width; + IHDR.Height := Image.Height; + IHDR.Compression := 0; + IHDR.Filter := 0; + IHDR.Interlacing := 0; + IHDR.BitDepth := FmtInfo.BytesPerPixel * 8; + + // Select appropiate PNG color type and modify bitdepth + if FmtInfo.HasGrayChannel then + begin + IHDR.ColorType := 0; + if FmtInfo.HasAlphaChannel then + begin + IHDR.ColorType := 4; + IHDR.BitDepth := IHDR.BitDepth div 2; + end; + end + else if FmtInfo.Format = ifBinary then + begin + IHDR.ColorType := 0; + IHDR.BitDepth := 1; + end + else if FmtInfo.IsIndexed then + IHDR.ColorType := 3 + else if FmtInfo.HasAlphaChannel then + begin + IHDR.ColorType := 6; + IHDR.BitDepth := IHDR.BitDepth div 4; + end + else + begin + IHDR.ColorType := 2; + IHDR.BitDepth := IHDR.BitDepth div 3; + end; + + if FileType = ngAPNG then + begin + // Fill fcTL chunk of APNG file + FillFrameControlChunk(IHDR, fcTL); + end; + + // Compress PNG image and store it to stream + StoreImageToPNGFrame(IHDR, Image.Bits, FmtInfo, IDATMemory); + // Store palette if necesary + if FmtInfo.IsIndexed then + StorePalette; + + // Finally swap endian + SwapEndianUInt32(@IHDR, 2); + end; + end; +end; + +function TNGFileSaver.SaveFile(Handle: TImagingHandle): Boolean; +var + I: LongInt; + Chunk: TChunkHeader; + SeqNo: UInt32; + + function GetNextSeqNo: UInt32; + begin + // Seq numbers of fcTL and fdAT are "interleaved" as they share the counter. + // Example: first fcTL for IDAT has seq=0, next is fcTL for seond frame with + // seq=1, then first fdAT with seq=2, fcTL seq=3, fdAT=4, ... + Result := SwapEndianUInt32(SeqNo); + Inc(SeqNo); + end; + + function CalcChunkCrc(const ChunkHdr: TChunkHeader; Data: Pointer; + Size: LongInt): UInt32; + begin + Result := $FFFFFFFF; + CalcCrc32(Result, @ChunkHdr.ChunkID, SizeOf(ChunkHdr.ChunkID)); + CalcCrc32(Result, Data, Size); + Result := SwapEndianUInt32(Result xor $FFFFFFFF); + end; + + procedure WriteChunk(var Chunk: TChunkHeader; ChunkData: Pointer); + var + ChunkCrc: UInt32; + SizeToWrite: LongInt; + begin + SizeToWrite := Chunk.DataSize; + Chunk.DataSize := SwapEndianUInt32(Chunk.DataSize); + ChunkCrc := CalcChunkCrc(Chunk, ChunkData, SizeToWrite); + GetIO.Write(Handle, @Chunk, SizeOf(Chunk)); + if SizeToWrite <> 0 then + GetIO.Write(Handle, ChunkData, SizeToWrite); + GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc)); + end; + + procedure WritefdAT(Frame: TFrameInfo); + var + ChunkCrc: UInt32; + ChunkSeqNo: UInt32; + begin + Chunk.ChunkID := fdATChunk; + ChunkSeqNo := GetNextSeqNo; + // fdAT saves seq number UInt32 before compressed pixels + Chunk.DataSize := Frame.IDATMemory.Size + SizeOf(UInt32); + Chunk.DataSize := SwapEndianUInt32(Chunk.DataSize); + // Calc CRC + ChunkCrc := $FFFFFFFF; + CalcCrc32(ChunkCrc, @Chunk.ChunkID, SizeOf(Chunk.ChunkID)); + CalcCrc32(ChunkCrc, @ChunkSeqNo, SizeOf(ChunkSeqNo)); + CalcCrc32(ChunkCrc, Frame.IDATMemory.Memory, Frame.IDATMemory.Size); + ChunkCrc := SwapEndianUInt32(ChunkCrc xor $FFFFFFFF); + // Write out all fdAT data + GetIO.Write(Handle, @Chunk, SizeOf(Chunk)); + GetIO.Write(Handle, @ChunkSeqNo, SizeOf(ChunkSeqNo)); + GetIO.Write(Handle, Frame.IDATMemory.Memory, Frame.IDATMemory.Size); + GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc)); + end; + + procedure WriteGlobalMetaDataChunks(Frame: TFrameInfo); + var + XRes, YRes: Double; + begin + if FileFormat.FMetadata.GetPhysicalPixelSize(ruDpm, XRes, YRes, True) then + begin + // Save pHYs chunk + Frame.pHYs.UnitSpecifier := 1; + // PNG stores physical resolution as dots per meter + Frame.pHYs.PixelsPerUnitX := Round(XRes); + Frame.pHYs.PixelsPerUnitY := Round(YRes); + + Chunk.DataSize := SizeOf(Frame.pHYs); + Chunk.ChunkID := pHYsChunk; + SwapEndianUInt32(@Frame.pHYs, SizeOf(Frame.pHYs) div SizeOf(UInt32)); + WriteChunk(Chunk, @Frame.pHYs); + end; + end; + + procedure WritePNGMainImageChunks(Frame: TFrameInfo); + begin + with Frame do + begin + // Write IHDR chunk + Chunk.DataSize := SizeOf(IHDR); + Chunk.ChunkID := IHDRChunk; + WriteChunk(Chunk, @IHDR); + // Write PLTE chunk if data is present + if Palette <> nil then + begin + Chunk.DataSize := PaletteEntries * SizeOf(TColor24Rec); + Chunk.ChunkID := PLTEChunk; + WriteChunk(Chunk, Palette); + end; + // Write tRNS chunk if data is present + if Transparency <> nil then + begin + Chunk.DataSize := TransparencySize; + Chunk.ChunkID := tRNSChunk; + WriteChunk(Chunk, Transparency); + end; + end; + // Write metadata related chunks + WriteGlobalMetaDataChunks(Frame); + end; + +begin + Result := False; + SeqNo := 0; + + case FileType of + ngPNG, ngAPNG: GetIO.Write(Handle, @PNGSignature, SizeOf(TChar8)); + ngMNG: GetIO.Write(Handle, @MNGSignature, SizeOf(TChar8)); + ngJNG: GetIO.Write(Handle, @JNGSignature, SizeOf(TChar8)); + end; + + if FileType = ngMNG then + begin + // MNG - main header before frames + SwapEndianUInt32(@MHDR, SizeOf(MHDR) div SizeOf(UInt32)); + Chunk.DataSize := SizeOf(MHDR); + Chunk.ChunkID := MHDRChunk; + WriteChunk(Chunk, @MHDR); + end + else if FileType = ngAPNG then + begin + // APNG - IHDR and global chunks for all frames, then acTL chunk, then frames + // (fcTL+IDAT, fcTL+fdAT, fcTL+fdAT, fcTL+fdAT, ....) + WritePNGMainImageChunks(Frames[0]); + + // Animation control chunk + acTL.NumFrames := Length(Frames); + if FileFormat.FMetadata.HasMetaItemForSaving(SMetaAnimationLoops) then + begin + // Number of plays of APNG animation + acTL.NumPlay:= FileFormat.FMetadata.MetaItemsForSaving[SMetaAnimationLoops]; + end + else + acTL.NumPlay := 0; + SwapEndianUInt32(@acTL, SizeOf(acTL) div SizeOf(UInt32)); + + Chunk.DataSize := SizeOf(acTL); + Chunk.ChunkID := acTLChunk; + WriteChunk(Chunk, @acTL); + end; + + for I := 0 to Length(Frames) - 1 do + with Frames[I] do + begin + if IsJpegFrame then + begin + // Write JHDR chunk + Chunk.DataSize := SizeOf(JHDR); + Chunk.ChunkID := JHDRChunk; + WriteChunk(Chunk, @JHDR); + // Write metadata related chunks + WriteGlobalMetaDataChunks(Frames[I]); + // Write JNG image data + Chunk.DataSize := JDATMemory.Size; + Chunk.ChunkID := JDATChunk; + WriteChunk(Chunk, JDATMemory.Memory); + // Write alpha channel if present + if JHDR.AlphaSampleDepth > 0 then + begin + if JHDR.AlphaCompression = 0 then + begin + // Alpha is PNG compressed + Chunk.DataSize := IDATMemory.Size; + Chunk.ChunkID := IDATChunk; + WriteChunk(Chunk, IDATMemory.Memory); + end + else + begin + // Alpha is JNG compressed + Chunk.DataSize := JDAAMemory.Size; + Chunk.ChunkID := JDAAChunk; + WriteChunk(Chunk, JDAAMemory.Memory); + end; + end; + // Write image end + Chunk.DataSize := 0; + Chunk.ChunkID := IENDChunk; + WriteChunk(Chunk, nil); + end + else if FileType <> ngAPNG then + begin + // Regular PNG frame (single PNG image or MNG frame) + WritePNGMainImageChunks(Frames[I]); + // Write PNG image data + Chunk.DataSize := IDATMemory.Size; + Chunk.ChunkID := IDATChunk; + WriteChunk(Chunk, IDATMemory.Memory); + // Write image end + Chunk.DataSize := 0; + Chunk.ChunkID := IENDChunk; + WriteChunk(Chunk, nil); + end + else if FileType = ngAPNG then + begin + // APNG frame - Write fcTL before frame data + Chunk.DataSize := SizeOf(fcTL); + Chunk.ChunkID := fcTLChunk; + fcTl.SeqNumber := GetNextSeqNo; + WriteChunk(Chunk, @fcTL); + // Write data - IDAT for first frame and fdAT for following ones + if I = 0 then + begin + Chunk.DataSize := IDATMemory.Size; + Chunk.ChunkID := IDATChunk; + WriteChunk(Chunk, IDATMemory.Memory); + end + else + WritefdAT(Frames[I]); + // Write image end after last frame + if I = Length(Frames) - 1 then + begin + Chunk.DataSize := 0; + Chunk.ChunkID := IENDChunk; + WriteChunk(Chunk, nil); + end; + end; + end; + + if FileType = ngMNG then + begin + Chunk.DataSize := 0; + Chunk.ChunkID := MENDChunk; + WriteChunk(Chunk, nil); + end; +end; + +procedure TNGFileSaver.SetFileOptions; +begin + PreFilter := FileFormat.FPreFilter; + CompressLevel := FileFormat.FCompressLevel; + LossyAlpha := FileFormat.FLossyAlpha; + Quality := FileFormat.FQuality; + Progressive := FileFormat.FProgressive; + ZLibStrategy := FileFormat.FZLibStrategy; +end; + +{ TAPNGAnimator class implementation } + +class procedure TAPNGAnimator.Animate(var Images: TDynImageDataArray; + const acTL: TacTL; const SrcFrames: array of TFrameInfo); +var + I, SrcIdx, Offset, Len: Integer; + DestFrames: TDynImageDataArray; + SrcCanvas, DestCanvas: TImagingCanvas; + PreviousCache: TImageData; + DestFormat: TImageFormat; + FormatInfo: TImageFormatInfo; + AnimatingNeeded, BlendingNeeded: Boolean; + + procedure CheckFrames; + var + I: Integer; + begin + for I := 0 to Len - 1 do + with SrcFrames[I] do + begin + if (FrameWidth <> Integer(IHDR.Width)) or (FrameHeight <> Integer(IHDR.Height)) or (Len <> Integer(acTL.NumFrames)) or + (not ((fcTL.DisposeOp = DisposeOpNone) and (fcTL.BlendOp = BlendOpSource)) and + not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpSource)) and + not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpOver))) then + begin + AnimatingNeeded := True; + end; + + if fcTL.BlendOp = BlendOpOver then + BlendingNeeded := True; + + if AnimatingNeeded and BlendingNeeded then + Exit; + end; + end; + +begin + AnimatingNeeded := False; + BlendingNeeded := False; + Len := Length(SrcFrames); + + CheckFrames; + + if (Len = 0) or not AnimatingNeeded then + Exit; + + if (Len = Integer(acTL.NumFrames) + 1) and (SrcFrames[0].fcTL.Width = 0) then + begin + // If default image (stored in IDAT chunk) isn't part of animation we ignore it + Offset := 1; + Len := Len - 1; + end + else + Offset := 0; + + DestFormat := Images[0].Format; + GetImageFormatInfo(DestFormat, FormatInfo); + if BlendingNeeded and FormatInfo.IsIndexed then // alpha blending needed -> destination cannot be indexed + DestFormat := ifA8R8G8B8; + + SetLength(DestFrames, Len); + DestCanvas := ImagingCanvases.FindBestCanvasForImage(DestFormat).Create; + SrcCanvas := ImagingCanvases.FindBestCanvasForImage(Images[0]).Create; + InitImage(PreviousCache); + NewImage(SrcFrames[0].IHDR.Width, SrcFrames[0].IHDR.Height, DestFormat, PreviousCache); + + for I := 0 to Len - 1 do + begin + SrcIdx := I + Offset; + + NewImage(SrcFrames[SrcIdx].IHDR.Width, SrcFrames[SrcIdx].IHDR.Height, + DestFormat, DestFrames[I]); + if DestFrames[I].Format = ifIndex8 then + Move(Images[SrcIdx].Palette^, DestFrames[I].Palette^, 256 * SizeOf(TColor32)); + + DestCanvas.CreateForData(@DestFrames[I]); + + if (SrcFrames[SrcIdx].fcTL.DisposeOp = DisposeOpPrevious) and (SrcFrames[SrcIdx - 1].fcTL.DisposeOp <> DisposeOpPrevious) then + begin + // Cache current output buffer so we may return to it later (previous dispose op) + CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height, + PreviousCache, 0, 0); + end; + + if (I = 0) or (SrcIdx = 0) then + begin + // Clear whole frame with transparent black color (default for first frame) + DestCanvas.FillColor32 := pcClear; + DestCanvas.Clear; + end + else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpBackground then + begin + // Restore background color (clear) on previous frame's area and leave previous content outside of it + CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height, + DestFrames[I], 0, 0); + DestCanvas.FillColor32 := pcClear; + DestCanvas.FillRect(BoundsToRect(SrcFrames[SrcIdx - 1].fcTL.XOffset, SrcFrames[SrcIdx - 1].fcTL.YOffset, + SrcFrames[SrcIdx - 1].FrameWidth, SrcFrames[SrcIdx - 1].FrameHeight)); + end + else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpNone then + begin + // Clone previous frame - no change to output buffer + CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height, + DestFrames[I], 0, 0); + end + else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpPrevious then + begin + // Revert to previous frame (cached, can't just restore DestFrames[I - 2]) + CopyRect(PreviousCache, 0, 0, PreviousCache.Width, PreviousCache.Height, + DestFrames[I], 0, 0); + end; + + // Copy pixels or alpha blend them over + if SrcFrames[SrcIdx].fcTL.BlendOp = BlendOpSource then + begin + CopyRect(Images[SrcIdx], 0, 0, Images[SrcIdx].Width, Images[SrcIdx].Height, + DestFrames[I], SrcFrames[SrcIdx].fcTL.XOffset, SrcFrames[SrcIdx].fcTL.YOffset); + end + else if SrcFrames[SrcIdx].fcTL.BlendOp = BlendOpOver then + begin + SrcCanvas.CreateForData(@Images[SrcIdx]); + SrcCanvas.DrawAlpha(SrcCanvas.ClipRect, DestCanvas, + SrcFrames[SrcIdx].fcTL.XOffset, SrcFrames[SrcIdx].fcTL.YOffset); + end; + + FreeImage(Images[SrcIdx]); + end; + + DestCanvas.Free; + SrcCanvas.Free; + FreeImage(PreviousCache); + + // Assign dest frames to final output images + Images := DestFrames; +end; + +{ TNetworkGraphicsFileFormat class implementation } + +procedure TNetworkGraphicsFileFormat.Define; +begin + inherited; + FFeatures := [ffLoad, ffSave]; + + FPreFilter := NGDefaultPreFilter; + FCompressLevel := NGDefaultCompressLevel; + FLossyAlpha := NGDefaultLossyAlpha; + FLossyCompression := NGDefaultLossyCompression; + FQuality := NGDefaultQuality; + FProgressive := NGDefaultProgressive; + FZLibStrategy := NGDefaultZLibStrategy; +end; + +procedure TNetworkGraphicsFileFormat.CheckOptionsValidity; +begin + // Just check if save options has valid values + if not (FPreFilter in [0..6]) then + FPreFilter := NGDefaultPreFilter; + if not (FCompressLevel in [0..9]) then + FCompressLevel := NGDefaultCompressLevel; + if not (FQuality in [1..100]) then + FQuality := NGDefaultQuality; +end; + +function TNetworkGraphicsFileFormat.GetSupportedFormats: TImageFormats; +begin + if FLossyCompression then + Result := NGLossyFormats + else + Result := NGLosslessFormats; +end; + +procedure TNetworkGraphicsFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +var + ConvFormat: TImageFormat; +begin + if not FLossyCompression then + begin + // Convert formats for lossless compression + if Info.HasGrayChannel then + begin + if Info.HasAlphaChannel then + begin + if Info.BytesPerPixel <= 2 then + // Convert <= 16bit grayscale images with alpha to ifA8Gray8 + ConvFormat := ifA8Gray8 + else + // Convert > 16bit grayscale images with alpha to ifA16Gray16 + ConvFormat := ifA16Gray16 + end + else + // Convert grayscale images without alpha to ifGray16 + ConvFormat := ifGray16; + end + else + if Info.IsFloatingPoint then + // Convert floating point images to 64 bit ARGB (or RGB if no alpha) + ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16B16G16R16, ifB16G16R16) + else if Info.HasAlphaChannel or Info.IsSpecial then + // Convert all other images with alpha or special images to A8R8G8B8 + ConvFormat := ifA8R8G8B8 + else + // Convert images without alpha to R8G8B8 + ConvFormat := ifR8G8B8; + end + else + begin + // Convert formats for lossy compression + if Info.HasGrayChannel then + ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8Gray8, ifGray8) + else + ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8); + end; + + ConvertImage(Image, ConvFormat); +end; + +function TNetworkGraphicsFileFormat.TestFormat(Handle: TImagingHandle): Boolean; +var + ReadCount: LongInt; + Sig: TChar8; +begin + Result := False; + if Handle <> nil then + with GetIO do + begin + FillChar(Sig, SizeOf(Sig), 0); + ReadCount := Read(Handle, @Sig, SizeOf(Sig)); + Seek(Handle, -ReadCount, smFromCurrent); + Result := (ReadCount = SizeOf(Sig)) and (Sig = FSignature); + end; +end; + +{ TPNGFileFormat class implementation } + +procedure TPNGFileFormat.Define; +begin + inherited; + FName := SPNGFormatName; + FFeatures := FFeatures + [ffMultiImage]; + FLoadAnimated := PNGDefaultLoadAnimated; + AddMasks(SPNGMasks); + + FSignature := PNGSignature; + + RegisterOption(ImagingPNGPreFilter, @FPreFilter); + RegisterOption(ImagingPNGCompressLevel, @FCompressLevel); + RegisterOption(ImagingPNGLoadAnimated, @FLoadAnimated); + RegisterOption(ImagingPNGZLibStrategy, @FZLibStrategy); +end; + +function TPNGFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + I, Len: LongInt; + NGFileLoader: TNGFileLoader; +begin + Result := False; + NGFileLoader := TNGFileLoader.Create(Self); + try + // Use NG file parser to load file + if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then + begin + Len := Length(NGFileLoader.Frames); + SetLength(Images, Len); + for I := 0 to Len - 1 do + with NGFileLoader.Frames[I] do + begin + // Build actual image bits + if not IsJpegFrame then + NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]); + // Build palette, aply color key or background + + NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]); + Result := True; + end; + // Animate APNG images + if (NGFileLoader.FileType = ngAPNG) and FLoadAnimated then + TAPNGAnimator.Animate(Images, NGFileLoader.acTL, NGFileLoader.Frames); + end; + finally + NGFileLoader.LoadMetaData; // Store metadata + NGFileLoader.Free; + end; +end; + +function TPNGFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + I: Integer; + ImageToSave: TImageData; + MustBeFreed: Boolean; + NGFileSaver: TNGFileSaver; + DefaultFormat: TImageFormat; + Screen: TImageData; + AnimWidth, AnimHeight: Integer; +begin + Result := False; + DefaultFormat := ifDefault; + AnimWidth := 0; + AnimHeight := 0; + NGFileSaver := TNGFileSaver.Create(Self); + + // Save images with more frames as APNG format + if Length(Images) > 1 then + begin + NGFileSaver.FileType := ngAPNG; + // Get max dimensions of frames + AnimWidth := Images[FFirstIdx].Width; + AnimHeight := Images[FFirstIdx].Height; + for I := FFirstIdx + 1 to FLastIdx do + begin + AnimWidth := Max(AnimWidth, Images[I].Width); + AnimHeight := Max(AnimHeight, Images[I].Height); + end; + end + else + NGFileSaver.FileType := ngPNG; + + NGFileSaver.SetFileOptions; + + with NGFileSaver do + try + // Store all frames to be saved frames file saver + for I := FFirstIdx to FLastIdx do + begin + if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then + try + if FileType = ngAPNG then + begin + // IHDR chunk is shared for all frames so all frames must have the + // same data format as the first image. + if I = FFirstIdx then + begin + DefaultFormat := ImageToSave.Format; + // Subsequenet frames may be bigger than the first one. + // APNG doens't support this - max allowed size is what's written in + // IHDR - size of main/default/first image. If some frame is + // bigger than the first one we need to resize (create empty bigger + // image and copy) the first frame so all following frames could fit to + // its area. + if (ImageToSave.Width <> AnimWidth) or (ImageToSave.Height <> AnimHeight) then + begin + InitImage(Screen); + NewImage(AnimWidth, AnimHeight, ImageToSave.Format, Screen); + CopyRect(ImageToSave, 0, 0, ImageToSave.Width, ImageToSave.Height, Screen, 0, 0); + if MustBeFreed then + FreeImage(ImageToSave); + ImageToSave := Screen; + end; + end + else if ImageToSave.Format <> DefaultFormat then + begin + if MustBeFreed then + ConvertImage(ImageToSave, DefaultFormat) + else + begin + CloneImage(Images[I], ImageToSave); + ConvertImage(ImageToSave, DefaultFormat); + MustBeFreed := True; + end; + end; + end; + + // Add image as PNG frame + AddFrame(ImageToSave, False); + finally + if MustBeFreed then + FreeImage(ImageToSave); + end + else + Exit; + end; + + // Finally save PNG file + SaveFile(Handle); + Result := True; + finally + NGFileSaver.Free; + end; +end; + +{$IFNDEF DONT_LINK_MNG} + +{ TMNGFileFormat class implementation } + +procedure TMNGFileFormat.Define; +begin + inherited; + FName := SMNGFormatName; + FFeatures := FFeatures + [ffMultiImage]; + AddMasks(SMNGMasks); + + FSignature := MNGSignature; + + RegisterOption(ImagingMNGLossyCompression, @FLossyCompression); + RegisterOption(ImagingMNGLossyAlpha, @FLossyAlpha); + RegisterOption(ImagingMNGPreFilter, @FPreFilter); + RegisterOption(ImagingMNGCompressLevel, @FCompressLevel); + RegisterOption(ImagingMNGQuality, @FQuality); + RegisterOption(ImagingMNGProgressive, @FProgressive); +end; + +function TMNGFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + NGFileLoader: TNGFileLoader; + I, Len: LongInt; +begin + Result := False; + NGFileLoader := TNGFileLoader.Create(Self); + try + // Use NG file parser to load file + if NGFileLoader.LoadFile(Handle) then + begin + Len := Length(NGFileLoader.Frames); + if Len > 0 then + begin + SetLength(Images, Len); + for I := 0 to Len - 1 do + with NGFileLoader.Frames[I] do + begin + // Build actual image bits + if IsJpegFrame then + NGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight, JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[I]) + else + NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]); + // Build palette, aply color key or background + NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]); + end; + end + else + begin + // Some MNG files (with BASI-IEND streams) dont have actual pixel data + SetLength(Images, 1); + NewImage(NGFileLoader.MHDR.FrameWidth, NGFileLoader.MHDR.FrameWidth, ifDefault, Images[0]); + end; + Result := True; + end; + finally + NGFileLoader.LoadMetaData; // Store metadata + NGFileLoader.Free; + end; +end; + +function TMNGFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + NGFileSaver: TNGFileSaver; + I, LargestWidth, LargestHeight: LongInt; + ImageToSave: TImageData; + MustBeFreed: Boolean; +begin + Result := False; + LargestWidth := 0; + LargestHeight := 0; + + NGFileSaver := TNGFileSaver.Create(Self); + NGFileSaver.FileType := ngMNG; + NGFileSaver.SetFileOptions; + + with NGFileSaver do + try + // Store all frames to be saved frames file saver + for I := FFirstIdx to FLastIdx do + begin + if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then + try + // Add image as PNG or JNG frame + AddFrame(ImageToSave, FLossyCompression); + // Remember largest frame width and height + LargestWidth := Iff(LargestWidth < ImageToSave.Width, ImageToSave.Width, LargestWidth); + LargestHeight := Iff(LargestHeight < ImageToSave.Height, ImageToSave.Height, LargestHeight); + finally + if MustBeFreed then + FreeImage(ImageToSave); + end + else + Exit; + end; + + // Fill MNG header + MHDR.FrameWidth := LargestWidth; + MHDR.FrameHeight := LargestHeight; + MHDR.TicksPerSecond := 0; + MHDR.NominalLayerCount := 0; + MHDR.NominalFrameCount := Length(Frames); + MHDR.NominalPlayTime := 0; + MHDR.SimplicityProfile := 473; // 111011001 binary, defines MNG-VLC with transparency and JNG support + + // Finally save MNG file + SaveFile(Handle); + Result := True; + finally + NGFileSaver.Free; + end; +end; + +{$ENDIF} + +{$IFNDEF DONT_LINK_JNG} + +{ TJNGFileFormat class implementation } + +procedure TJNGFileFormat.Define; +begin + inherited; + FName := SJNGFormatName; + AddMasks(SJNGMasks); + + FSignature := JNGSignature; + FLossyCompression := True; + + RegisterOption(ImagingJNGLossyAlpha, @FLossyAlpha); + RegisterOption(ImagingJNGAlphaPreFilter, @FPreFilter); + RegisterOption(ImagingJNGAlphaCompressLevel, @FCompressLevel); + RegisterOption(ImagingJNGQuality, @FQuality); + RegisterOption(ImagingJNGProgressive, @FProgressive); + +end; + +function TJNGFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + NGFileLoader: TNGFileLoader; +begin + Result := False; + NGFileLoader := TNGFileLoader.Create(Self); + try + // Use NG file parser to load file + if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then + with NGFileLoader.Frames[0] do + begin + SetLength(Images, 1); + // Build actual image bits + if IsJpegFrame then + NGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight, JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[0]); + // Build palette, aply color key or background + NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[0], Images[0]); + Result := True; + end; + finally + NGFileLoader.LoadMetaData; // Store metadata + NGFileLoader.Free; + end; +end; + +function TJNGFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + NGFileSaver: TNGFileSaver; + ImageToSave: TImageData; + MustBeFreed: Boolean; +begin + // Make image JNG compatible, store it in saver, and save it to file + Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed); + if Result then + begin + NGFileSaver := TNGFileSaver.Create(Self); + with NGFileSaver do + try + FileType := ngJNG; + SetFileOptions; + AddFrame(ImageToSave, True); + SaveFile(Handle); + finally + // Free NG saver and compatible image + NGFileSaver.Free; + if MustBeFreed then + FreeImage(ImageToSave); + end; + end; +end; + +{$ENDIF} + +initialization + RegisterImageFileFormat(TPNGFileFormat); +{$IFNDEF DONT_LINK_MNG} + RegisterImageFileFormat(TMNGFileFormat); +{$ENDIF} +{$IFNDEF DONT_LINK_JNG} + RegisterImageFileFormat(TJNGFileFormat); +{$ENDIF} +finalization + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - nothing now + + -- 0.77 Changes/Bug Fixes ----------------------------------- + - Reads and writes APNG animation loop count metadata. + - Writes frame delays of APNG from metadata. + - Fixed color keys in 8bit depth PNG/MNG loading. + - Fixed needless (and sometimes buggy) conversion to format with alpha + channel in FPC (GetMem(0) <> nil!). + - Added support for optional ZLib compression strategy. + - Added loading and saving of ifBinary (1bit black and white) + format images. During loading grayscale 1bpp and indexed 1bpp + (with only black and white colors in palette) are treated as ifBinary. + ifBinary are saved as 1bpp grayscale PNGs. + + -- 0.26.5 Changes/Bug Fixes --------------------------------- + - Reads frame delays from APNG files into metadata. + - Added loading and saving of metadata from these chunks: pHYs. + - Simplified decoding of 1/2/4 bit images a bit (less code). + + -- 0.26.3 Changes/Bug Fixes --------------------------------- + - Added APNG saving support. + - Added APNG support to NG loader and animating to PNG loader. + + -- 0.26.1 Changes/Bug Fixes --------------------------------- + - Changed file format conditional compilation to reflect changes + in LINK symbols. + + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - Changes for better thread safety. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Added loading of global palettes and transparencies in MNG files + (and by doing so fixed crash when loading images with global PLTE or tRNS). + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Small changes in converting to supported formats. + - MakeCompatible method moved to base class, put ConvertToSupported here. + GetSupportedFormats removed, it is now set in constructor. + - Made public properties for options registered to SetOption/GetOption + functions. + - Changed extensions to filename masks. + - Changed SaveData, LoadData, and MakeCompatible methods according + to changes in base class in Imaging unit. + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - MNG and JNG support added, PNG support redesigned to support NG file handlers + - added classes for working with NG file formats + - stuff from old ImagingPng unit added and that unit was deleted + - unit created and initial stuff added + + -- 0.15 Changes/Bug Fixes ----------------------------------- + - when saving indexed images save alpha to tRNS? + - added some defines and ifdefs to dzlib unit to allow choosing + impaszlib, fpc's paszlib, zlibex or other zlib implementation + - added colorkeying support + - fixed 16bit channel image handling - pixels were not swapped + - fixed arithmetic overflow (in paeth filter) in FPC + - data of unknown chunks are skipped and not needlesly loaded + + -- 0.13 Changes/Bug Fixes ----------------------------------- + - adaptive filtering added to PNG saving + - TPNGFileFormat class added +} + +end. diff --git a/Imaging/ImagingOpenGL.pas b/Imaging/ImagingOpenGL.pas index 2df1fb9..ef7cbd4 100644 --- a/Imaging/ImagingOpenGL.pas +++ b/Imaging/ImagingOpenGL.pas @@ -1,927 +1,944 @@ -{ - $Id: ImagingOpenGL.pas 165 2009-08-14 12:34:40Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains functions for loading and saving OpenGL textures - using Imaging and for converting images to textures and vice versa.} -unit ImagingOpenGL; - -{$I ImagingOptions.inc} - -{ Define this symbol if you want to use dglOpenGL header.} -{ $DEFINE USE_DGL_HEADERS} -{ $DEFINE USE_GLSCENE_HEADERS} - -interface - -uses - SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats, -{$IF Defined(USE_DGL_HEADERS)} - dglOpenGL, -{$ELSEIF Defined(USE_GLSCENE_HEADERS)} - OpenGL1x, -{$ELSE} - gl, glext, -{$IFEND} - ImagingUtility; - -type - { Various texture capabilities of installed OpenGL driver.} - TGLTextureCaps = record - MaxTextureSize: LongInt; // Max size of texture in pixels supported by HW - NonPowerOfTwo: Boolean; // HW has full support for NPOT textures - DXTCompression: Boolean; // HW supports S3TC/DXTC compressed textures - ATI3DcCompression: Boolean; // HW supports ATI 3Dc compressed textures (ATI2N) - LATCCompression: Boolean; // HW supports LATC/RGTC compressed textures (ATI1N+ATI2N) - FloatTextures: Boolean; // HW supports floating point textures - MaxAnisotropy: LongInt; // Max anisotropy for aniso texture filtering - MaxSimultaneousTextures: LongInt; // Number of texture units - ClampToEdge: Boolean; // GL_EXT_texture_edge_clamp - TextureLOD: Boolean; // GL_SGIS_texture_lod - VertexTextureUnits: Integer; // Texture units accessible in vertex programs - end; - -{ Returns texture capabilities of installed OpenGL driver.} -function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean; -{ Function which can be used to retrieve GL extension functions.} -function GetGLProcAddress(const ProcName: string): Pointer; -{ Returns True if the given GL extension is supported.} -function IsGLExtensionSupported(const Extension: string): Boolean; -{ Returns True if the given image format can be represented as GL texture - format. GLFormat, GLType, and GLInternal are parameters for functions like - glTexImage. Note that GLU functions like gluBuildMipmaps cannot handle some - formats returned by this function (i.e. GL_UNSIGNED_SHORT_5_5_5_1 as GLType). - If you are using compressed or floating-point images make sure that they are - supported by hardware using GetGLTextureCaps, ImageFormatToGL does not - check this.} -function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum; - var GLType: GLenum; var GLInternal: GLint; const Caps: TGLTextureCaps): Boolean; - -{ All GL textures created by Imaging functions have default parameters set - - that means that no glTexParameter calls are made so default filtering, - wrapping, and other parameters are used. Created textures - are left bound by glBindTexture when function is exited.} - -{ Creates GL texture from image in file in format supported by Imaging. - You can use CreatedWidth and Height parameters to query dimensions of created textures - (it could differ from dimensions of source image).} -function LoadGLTextureFromFile(const FileName: string; CreatedWidth: PLongInt = nil; - CreatedHeight: PLongInt = nil): GLuint; -{ Creates GL texture from image in stream in format supported by Imaging. - You can use CreatedWidth and Height parameters to query dimensions of created textures - (it could differ from dimensions of source image).} -function LoadGLTextureFromStream(Stream: TStream; CreatedWidth: PLongInt = nil; - CreatedHeight: PLongInt = nil): GLuint; -{ Creates GL texture from image in memory in format supported by Imaging. - You can use CreatedWidth and Height parameters to query dimensions of created textures - (it could differ from dimensions of source image).} -function LoadGLTextureFromMemory(Data: Pointer; Size: LongInt; - CreatedWidth: PLongInt = nil; CreatedHeight: PLongInt = nil): GLuint; - -{ Converts TImageData structure to OpenGL texture. - Input images is used as main mipmap level and additional requested - levels are generated from this one. For the details on parameters - look at CreateGLTextureFromMultiImage function.} -function CreateGLTextureFromImage(const Image: TImageData; - Width: LongInt = 0; Height: LongInt = 0; MipMaps: Boolean = True; - OverrideFormat: TImageFormat = ifUnknown; CreatedWidth: PLongInt = nil; - CreatedHeight: PLongInt = nil): GLuint; -{ Converts images in TDymImageDataArray to one OpenGL texture. - Image at index MainLevelIndex in the array is used as main mipmap level and - additional images are used as subsequent levels. If there is not enough images - in array missing levels are automatically generated (and if there is enough images - but they have wrong dimensions or format then they are resized/converted). - If driver supports only power of two sized textures images are resized. - OverrideFormat can be used to convert image into specific format before - it is passed to OpenGL, ifUnknown means no conversion. - If desired texture format is not supported by hardware default - A8R8G8B8 format is used instead for color images and ifGray8 is used - for luminance images. DXTC (S3TC) compressed and floating point textures - are created if supported by hardware. - Width and Height can be used to set size of main mipmap level according - to your needs, Width and Height of 0 mean use width and height of input - image that will become main level mipmap. - MipMaps set to True mean build all possible levels, False means use only level 0. - You can use CreatedWidth and CreatedHeight parameters to query dimensions of - created texture's largest mipmap level (it could differ from dimensions - of source image).} -function CreateGLTextureFromMultiImage(const Images: TDynImageDataArray; - Width: LongInt = 0; Height: LongInt = 0; MipMaps: Boolean = True; - MainLevelIndex: LongInt = 0; OverrideFormat: TImageFormat = ifUnknown; - CreatedWidth: PLongInt = nil; CreatedHeight: PLongInt = nil): GLuint; - -{ Saves GL texture to file in one of formats supported by Imaging. - Saves all present mipmap levels.} -function SaveGLTextureToFile(const FileName: string; const Texture: GLuint): Boolean; -{ Saves GL texture to stream in one of formats supported by Imaging. - Saves all present mipmap levels.} -function SaveGLTextureToStream(const Ext: string; Stream: TStream; const Texture: GLuint): Boolean; -{ Saves GL texture to memory in one of formats supported by Imaging. - Saves all present mipmap levels.} -function SaveGLTextureToMemory(const Ext: string; Data: Pointer; var Size: LongInt; const Texture: GLuint): Boolean; - -{ Converts main level of the GL texture to TImageData strucrue. OverrideFormat - can be used to convert output image to the specified format rather - than use the format taken from GL texture, ifUnknown means no conversion.} -function CreateImageFromGLTexture(const Texture: GLuint; - var Image: TImageData; OverrideFormat: TImageFormat = ifUnknown): Boolean; -{ Converts GL texture to TDynImageDataArray array of images. You can specify - how many mipmap levels of the input texture you want to be converted - (default is all levels). OverrideFormat can be used to convert output images to - the specified format rather than use the format taken from GL texture, - ifUnknown means no conversion.} -function CreateMultiImageFromGLTexture(const Texture: GLuint; - var Images: TDynImageDataArray; MipLevels: LongInt = 0; - OverrideFormat: TImageFormat = ifUnknown): Boolean; - -var - { Standard behaviour of image->texture functions like CreateGLTextureFrom(Multi)Image is: - If graphic card supports non power of 2 textures and image is nonpow2 then - texture is created directly from image. - If graphic card does not support them input image is rescaled (bilinear) - to power of 2 size. - If you set PasteNonPow2ImagesIntoPow2 to True then instead of rescaling, a new - pow2 texture is created and nonpow2 input image is pasted into it - keeping its original size. This could be useful for some 2D stuff - (and its faster than rescaling of course). Note that this is applied - to all rescaling smaller->bigger operations that might ocurr during - image->texture process (usually only pow2/nonpow2 stuff and when you - set custom Width & Height in CreateGLTextureFrom(Multi)Image).} - PasteNonPow2ImagesIntoPow2: Boolean = False; - { Standard behaviur if GL_ARB_texture_non_power_of_two extension is not supported - is to rescale image to power of 2 dimensions. NPOT extension is exposed only - when HW has full support for NPOT textures but some cards - (ATI Radeons, some other maybe) have partial NPOT support. Namely Radeons - can use NPOT textures but not mipmapped. If you know what you are doing - you can disable NPOT support check so the image won't be rescaled to POT - by seting DisableNPOTSupportCheck to True.} - DisableNPOTSupportCheck: Boolean = False; - -implementation - -const - // cube map consts - GL_TEXTURE_BINDING_CUBE_MAP = $8514; - GL_TEXTURE_CUBE_MAP_POSITIVE_X = $8515; - GL_TEXTURE_CUBE_MAP_NEGATIVE_X = $8516; - GL_TEXTURE_CUBE_MAP_POSITIVE_Y = $8517; - GL_TEXTURE_CUBE_MAP_NEGATIVE_Y = $8518; - GL_TEXTURE_CUBE_MAP_POSITIVE_Z = $8519; - GL_TEXTURE_CUBE_MAP_NEGATIVE_Z = $851A; - - // texture formats - GL_COLOR_INDEX = $1900; - GL_STENCIL_INDEX = $1901; - GL_DEPTH_COMPONENT = $1902; - GL_RED = $1903; - GL_GREEN = $1904; - GL_BLUE = $1905; - GL_ALPHA = $1906; - GL_RGB = $1907; - GL_RGBA = $1908; - GL_LUMINANCE = $1909; - GL_LUMINANCE_ALPHA = $190A; - GL_BGR_EXT = $80E0; - GL_BGRA_EXT = $80E1; - - // texture internal formats - GL_ALPHA4 = $803B; - GL_ALPHA8 = $803C; - GL_ALPHA12 = $803D; - GL_ALPHA16 = $803E; - GL_LUMINANCE4 = $803F; - GL_LUMINANCE8 = $8040; - GL_LUMINANCE12 = $8041; - GL_LUMINANCE16 = $8042; - GL_LUMINANCE4_ALPHA4 = $8043; - GL_LUMINANCE6_ALPHA2 = $8044; - GL_LUMINANCE8_ALPHA8 = $8045; - GL_LUMINANCE12_ALPHA4 = $8046; - GL_LUMINANCE12_ALPHA12 = $8047; - GL_LUMINANCE16_ALPHA16 = $8048; - GL_INTENSITY = $8049; - GL_INTENSITY4 = $804A; - GL_INTENSITY8 = $804B; - GL_INTENSITY12 = $804C; - GL_INTENSITY16 = $804D; - GL_R3_G3_B2 = $2A10; - GL_RGB4 = $804F; - GL_RGB5 = $8050; - GL_RGB8 = $8051; - GL_RGB10 = $8052; - GL_RGB12 = $8053; - GL_RGB16 = $8054; - GL_RGBA2 = $8055; - GL_RGBA4 = $8056; - GL_RGB5_A1 = $8057; - GL_RGBA8 = $8058; - GL_RGB10_A2 = $8059; - GL_RGBA12 = $805A; - GL_RGBA16 = $805B; - - // floating point texture formats - GL_RGBA32F_ARB = $8814; - GL_INTENSITY32F_ARB = $8817; - GL_LUMINANCE32F_ARB = $8818; - GL_RGBA16F_ARB = $881A; - GL_INTENSITY16F_ARB = $881D; - GL_LUMINANCE16F_ARB = $881E; - - // compressed texture formats - GL_COMPRESSED_RGBA_S3TC_DXT1_EXT = $83F1; - GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2; - GL_COMPRESSED_RGBA_S3TC_DXT5_EXT = $83F3; - GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI = $8837; - GL_COMPRESSED_LUMINANCE_LATC1_EXT = $8C70; - GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT = $8C71; - GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT = $8C72; - GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT = $8C73; - - // various GL extension constants - GL_MAX_TEXTURE_UNITS = $84E2; - GL_TEXTURE_MAX_ANISOTROPY_EXT = $84FE; - GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT = $84FF; - - // texture source data formats - GL_UNSIGNED_BYTE_3_3_2 = $8032; - GL_UNSIGNED_SHORT_4_4_4_4 = $8033; - GL_UNSIGNED_SHORT_5_5_5_1 = $8034; - GL_UNSIGNED_INT_8_8_8_8 = $8035; - GL_UNSIGNED_INT_10_10_10_2 = $8036; - GL_UNSIGNED_BYTE_2_3_3_REV = $8362; - GL_UNSIGNED_SHORT_5_6_5 = $8363; - GL_UNSIGNED_SHORT_5_6_5_REV = $8364; - GL_UNSIGNED_SHORT_4_4_4_4_REV = $8365; - GL_UNSIGNED_SHORT_1_5_5_5_REV = $8366; - GL_UNSIGNED_INT_8_8_8_8_REV = $8367; - GL_UNSIGNED_INT_2_10_10_10_REV = $8368; - GL_HALF_FLOAT_ARB = $140B; - - // Other GL constants - GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS = $8B4C; - - -{$IFDEF MSWINDOWS} - GLLibName = 'opengl32.dll'; -{$ENDIF} -{$IFDEF UNIX} - GLLibName = 'libGL.so'; -{$ENDIF} - -type - TglCompressedTexImage2D = procedure (Target: GLenum; Level: GLint; - InternalFormat: GLenum; Width: GLsizei; Height: GLsizei; Border: GLint; - ImageSize: GLsizei; const Data: PGLvoid); - {$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} -var - glCompressedTexImage2D: TglCompressedTexImage2D = nil; - ExtensionBuffer: string = ''; - -{$IFDEF MSWINDOWS} -function wglGetProcAddress(ProcName: PChar): Pointer; stdcall; external GLLibName; -{$ENDIF} -{$IFDEF UNIX} -function glXGetProcAddress(ProcName: PChar): Pointer; cdecl; external GLLibName; -{$ENDIF} - -function IsGLExtensionSupported(const Extension: string): Boolean; -var - ExtPos: LongInt; -begin - if ExtensionBuffer = '' then - ExtensionBuffer := glGetString(GL_EXTENSIONS); - - ExtPos := Pos(Extension, ExtensionBuffer); - Result := ExtPos > 0; - if Result then - begin - Result := ((ExtPos + Length(Extension) - 1) = Length(ExtensionBuffer)) or - not (ExtensionBuffer[ExtPos + Length(Extension)] in ['_', 'A'..'Z', 'a'..'z']); - end; -end; - -function GetGLProcAddress(const ProcName: string): Pointer; -begin -{$IFDEF MSWINDOWS} - Result := wglGetProcAddress(PChar(ProcName)); -{$ENDIF} -{$IFDEF UNIX} - Result := glXGetProcAddress(PChar(ProcName)); -{$ENDIF} -end; - -function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean; -begin - // Check DXTC support and load extension functions if necesary - Caps.DXTCompression := IsGLExtensionSupported('GL_ARB_texture_compression') and - IsGLExtensionSupported('GL_EXT_texture_compression_s3tc'); - if Caps.DXTCompression then - glCompressedTexImage2D := GetGLProcAddress('glCompressedTexImage2D'); - Caps.DXTCompression := Caps.DXTCompression and (@glCompressedTexImage2D <> nil); - Caps.ATI3DcCompression := Caps.DXTCompression and - IsGLExtensionSupported('GL_ATI_texture_compression_3dc'); - Caps.LATCCompression := Caps.DXTCompression and - IsGLExtensionSupported('GL_EXT_texture_compression_latc'); - // Check non power of 2 textures - Caps.NonPowerOfTwo := IsGLExtensionSupported('GL_ARB_texture_non_power_of_two'); - // Check for floating point textures support - Caps.FloatTextures := IsGLExtensionSupported('GL_ARB_texture_float'); - // Get max texture size - glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize); - // Get max anisotropy - if IsGLExtensionSupported('GL_EXT_texture_filter_anisotropic') then - glGetIntegerv(GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT, @Caps.MaxAnisotropy) - else - Caps.MaxAnisotropy := 0; - // Get number of texture units - if IsGLExtensionSupported('GL_ARB_multitexture') then - glGetIntegerv(GL_MAX_TEXTURE_UNITS, @Caps.MaxSimultaneousTextures) - else - Caps.MaxSimultaneousTextures := 1; - // Get number of vertex texture units - if IsGLExtensionSupported('GL_ARB_vertex_shader') then - glGetIntegerv(GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS, @Caps.VertexTextureUnits) - else - Caps.VertexTextureUnits := 1; - // Get max texture size - glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize); - // Clamp texture to edge? - Caps.ClampToEdge := IsGLExtensionSupported('GL_EXT_texture_edge_clamp'); - // Texture LOD extension? - Caps.TextureLOD := IsGLExtensionSupported('GL_SGIS_texture_lod'); - - Result := True; -end; - -function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum; - var GLType: GLenum; var GLInternal: GLint; const Caps: TGLTextureCaps): Boolean; -begin - GLFormat := 0; - GLType := 0; - GLInternal := 0; - case Format of - // Gray formats - ifGray8, ifGray16: - begin - GLFormat := GL_LUMINANCE; - GLType := Iff(Format = ifGray8, GL_UNSIGNED_BYTE, GL_UNSIGNED_SHORT); - GLInternal := Iff(Format = ifGray8, GL_LUMINANCE8, GL_LUMINANCE16); - end; - ifA8Gray8, ifA16Gray16: - begin - GLFormat := GL_LUMINANCE_ALPHA; - GLType := Iff(Format = ifA8Gray8, GL_UNSIGNED_BYTE, GL_UNSIGNED_SHORT); - GLInternal := Iff(Format = ifA8Gray8, GL_LUMINANCE8_ALPHA8, GL_LUMINANCE16_ALPHA16); - end; - // RGBA formats - ifR3G3B2: - begin - GLFormat := GL_RGB; - GLType := GL_UNSIGNED_BYTE_3_3_2; - GLInternal := GL_R3_G3_B2; - end; - ifR5G6B5: - begin - GLFormat := GL_RGB; - GLType := GL_UNSIGNED_SHORT_5_6_5; - GLInternal := GL_RGB5; - end; - ifA1R5G5B5, ifX1R5G5B5: - begin - GLFormat := GL_BGRA_EXT; - GLType := GL_UNSIGNED_SHORT_1_5_5_5_REV; - GLInternal := Iff(Format = ifA1R5G5B5, GL_RGB5_A1, GL_RGB5); - end; - ifA4R4G4B4, ifX4R4G4B4: - begin - GLFormat := GL_BGRA_EXT; - GLType := GL_UNSIGNED_SHORT_4_4_4_4_REV; - GLInternal := Iff(Format = ifA4R4G4B4, GL_RGBA4, GL_RGB4); - end; - ifR8G8B8: - begin - GLFormat := GL_BGR_EXT; - GLType := GL_UNSIGNED_BYTE; - GLInternal := GL_RGB8; - end; - ifA8R8G8B8, ifX8R8G8B8: - begin - GLFormat := GL_BGRA_EXT; - GLType := GL_UNSIGNED_BYTE; - GLInternal := Iff(Format = ifA8R8G8B8, GL_RGBA8, GL_RGB8); - end; - ifR16G16B16, ifB16G16R16: - begin - GLFormat := Iff(Format = ifR16G16B16, GL_BGR_EXT, GL_RGB); - GLType := GL_UNSIGNED_SHORT; - GLInternal := GL_RGB16; - end; - ifA16R16G16B16, ifA16B16G16R16: - begin - GLFormat := Iff(Format = ifA16R16G16B16, GL_BGRA_EXT, GL_RGBA); - GLType := GL_UNSIGNED_SHORT; - GLInternal := GL_RGBA16; - end; - // Floating-Point formats - ifR32F: - begin - GLFormat := GL_RED; - GLType := GL_FLOAT; - GLInternal := GL_LUMINANCE32F_ARB; - end; - ifA32R32G32B32F, ifA32B32G32R32F: - begin - GLFormat := Iff(Format = ifA32R32G32B32F, GL_BGRA_EXT, GL_RGBA); - GLType := GL_FLOAT; - GLInternal := GL_RGBA32F_ARB; - end; - ifR16F: - begin - GLFormat := GL_RED; - GLType := GL_HALF_FLOAT_ARB; - GLInternal := GL_LUMINANCE16F_ARB; - end; - ifA16R16G16B16F, ifA16B16G16R16F: - begin - GLFormat := Iff(Format = ifA16R16G16B16F, GL_BGRA_EXT, GL_RGBA); - GLType := GL_HALF_FLOAT_ARB; - GLInternal := GL_RGBA16F_ARB; - end; - // Special formats - ifDXT1: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT1_EXT; - ifDXT3: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT3_EXT; - ifDXT5: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT5_EXT; - ifATI1N: GLInternal := GL_COMPRESSED_LUMINANCE_LATC1_EXT; - ifATI2N: - begin - GLInternal := GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT; - if not Caps.LATCCompression and Caps.ATI3DcCompression then - GLInternal := GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI; - end; - end; - Result := GLInternal <> 0; -end; - -function LoadGLTextureFromFile(const FileName: string; CreatedWidth, CreatedHeight: PLongInt): GLuint; -var - Images: TDynImageDataArray; -begin - if LoadMultiImageFromFile(FileName, Images) and (Length(Images) > 0) then - begin - Result := CreateGLTextureFromMultiImage(Images, Images[0].Width, - Images[0].Height, True, 0, ifUnknown, CreatedWidth, CreatedHeight); - end - else - Result := 0; - FreeImagesInArray(Images); -end; - -function LoadGLTextureFromStream(Stream: TStream; CreatedWidth, CreatedHeight: PLongInt): GLuint; -var - Images: TDynImageDataArray; -begin - if LoadMultiImageFromStream(Stream, Images) and (Length(Images) > 0) then - begin - Result := CreateGLTextureFromMultiImage(Images, Images[0].Width, - Images[0].Height, True, 0, ifUnknown, CreatedWidth, CreatedHeight); - end - else - Result := 0; - FreeImagesInArray(Images); -end; - -function LoadGLTextureFromMemory(Data: Pointer; Size: LongInt; CreatedWidth, CreatedHeight: PLongInt): GLuint; -var - Images: TDynImageDataArray; -begin - if LoadMultiImageFromMemory(Data, Size, Images) and (Length(Images) > 0) then - begin - Result := CreateGLTextureFromMultiImage(Images, Images[0].Width, - Images[0].Height, True, 0, ifUnknown, CreatedWidth, CreatedHeight); - end - else - Result := 0; - FreeImagesInArray(Images); -end; - -function CreateGLTextureFromImage(const Image: TImageData; - Width, Height: LongInt; MipMaps: Boolean; OverrideFormat: TImageFormat; - CreatedWidth, CreatedHeight: PLongInt): GLuint; -var - Arr: TDynImageDataArray; -begin - // Just calls function operating on image arrays - SetLength(Arr, 1); - Arr[0] := Image; - Result := CreateGLTextureFromMultiImage(Arr, Width, Height, MipMaps, 0, - OverrideFormat, CreatedWidth, CreatedHeight); -end; - -function CreateGLTextureFromMultiImage(const Images: TDynImageDataArray; - Width, Height: LongInt; MipMaps: Boolean; MainLevelIndex: LongInt; OverrideFormat: TImageFormat; - CreatedWidth, CreatedHeight: PLongInt): GLuint; -const - BlockCompressedFormats: TImageFormats = [ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N]; -var - I, MipLevels, PossibleLevels, ExistingLevels, CurrentWidth, CurrentHeight: LongInt; - Caps: TGLTextureCaps; - GLFormat: GLenum; - GLType: GLenum; - GLInternal: GLint; - Desired, ConvTo: TImageFormat; - Info: TImageFormatInfo; - LevelsArray: TDynImageDataArray; - NeedsResize, NeedsConvert: Boolean; - UnpackAlignment, UnpackSkipRows, UnpackSkipPixels, UnpackRowLength: LongInt; - - procedure PasteImage(var Image: TImageData; Width, Height: LongInt); - var - Clone: TImageData; - begin - CloneImage(Image, Clone); - NewImage(Width, Height, Clone.Format, Image); - FillRect(Image, 0, 0, Width, Height, Clone.Bits); - CopyRect(Clone, 0, 0, Clone.Width, Clone.Height, Image, 0, 0); - FreeImage(Clone); - end; - -begin - Result := 0; - ExistingLevels := Length(Images); - - if GetGLTextureCaps(Caps) and (ExistingLevels > 0) then - try - // Check if requested main level is at valid index - if (MainLevelIndex < 0) or (MainLevelIndex > High(Images)) then - MainLevelIndex := 0; - - // First check desired size and modify it if necessary - if Width <= 0 then Width := Images[MainLevelIndex].Width; - if Height <= 0 then Height := Images[MainLevelIndex].Height; - if not Caps.NonPowerOfTwo and not DisableNPOTSupportCheck then - begin - // If device supports only power of 2 texture sizes - Width := NextPow2(Width); - Height := NextPow2(Height); - end; - Width := ClampInt(Width, 1, Caps.MaxTextureSize); - Height := ClampInt(Height, 1, Caps.MaxTextureSize); - - // Get various mipmap level counts and modify - // desired MipLevels if its value is invalid - PossibleLevels := GetNumMipMapLevels(Width, Height); - if MipMaps then - MipLevels := PossibleLevels - else - MipLevels := 1; - - // Prepare array for mipmap levels. Make it larger than necessary - that - // way we can use the same index for input images and levels in the large loop below - SetLength(LevelsArray, MipLevels + MainLevelIndex); - - // Now determine which image format will be used - if OverrideFormat = ifUnknown then - Desired := Images[MainLevelIndex].Format - else - Desired := OverrideFormat; - - // Check if the hardware supports floating point and compressed textures - GetImageFormatInfo(Desired, Info); - if Info.IsFloatingPoint and not Caps.FloatTextures then - Desired := ifA8R8G8B8; - if (Desired in [ifDXT1, ifDXT3, ifDXT5]) and not Caps.DXTCompression then - Desired := ifA8R8G8B8; - if (Desired = ifATI1N) and not Caps.LATCCompression then - Desired := ifGray8; - if (Desired = ifATI2N) and not (Caps.ATI3DcCompression or Caps.LATCCompression) then - Desired := ifA8Gray8; - - // Try to find GL format equivalent to image format and if it is not - // found use one of default formats - if not ImageFormatToGL(Desired, GLFormat, GLType, GLInternal, Caps) then - begin - GetImageFormatInfo(Desired, Info); - if Info.HasGrayChannel then - ConvTo := ifGray8 - else - ConvTo := ifA8R8G8B8; - if not ImageFormatToGL(ConvTo, GLFormat, GLType, GLInternal, Caps) then - Exit; - end - else - ConvTo := Desired; - - CurrentWidth := Width; - CurrentHeight := Height; - // If user is interested in width and height of created texture lets - // give him that - if CreatedWidth <> nil then CreatedWidth^ := CurrentWidth; - if CreatedHeight <> nil then CreatedHeight^ := CurrentHeight; - - // Store old pixel unpacking settings - glGetIntegerv(GL_UNPACK_ALIGNMENT, @UnpackAlignment); - glGetIntegerv(GL_UNPACK_SKIP_ROWS, @UnpackSkipRows); - glGetIntegerv(GL_UNPACK_SKIP_PIXELS, @UnpackSkipPixels); - glGetIntegerv(GL_UNPACK_ROW_LENGTH, @UnpackRowLength); - // Set new pixel unpacking settings - glPixelStorei(GL_UNPACK_ALIGNMENT, 1); - glPixelStorei(GL_UNPACK_SKIP_ROWS, 0); - glPixelStorei(GL_UNPACK_SKIP_PIXELS, 0); - glPixelStorei(GL_UNPACK_ROW_LENGTH, 0); - - // Generate new texture, bind it and set - glGenTextures(1, @Result); - glBindTexture(GL_TEXTURE_2D, Result); - if Byte(glIsTexture(Result)) <> GL_TRUE then - Exit; - - for I := MainLevelIndex to MipLevels - 1 + MainLevelIndex do - begin - // Check if we can use input image array as a source for this mipmap level - if I < ExistingLevels then - begin - // Check if input image for this mipmap level has the right - // size and format - NeedsConvert := not (Images[I].Format = ConvTo); - if ConvTo in BlockCompressedFormats then - begin - // Input images in DXTC will have min dimensions of 4, but we need - // current Width and Height to be lesser (for glCompressedTexImage2D) - NeedsResize := not ((Images[I].Width = Max(4, CurrentWidth)) and - (Images[I].Height = Max(4, CurrentHeight))); - end - else - NeedsResize := not ((Images[I].Width = CurrentWidth) and (Images[I].Height = CurrentHeight)); - - if NeedsResize or NeedsConvert then - begin - // Input image must be resized or converted to different format - // to become valid mipmap level - CloneImage(Images[I], LevelsArray[I]); - if NeedsConvert then - ConvertImage(LevelsArray[I], ConvTo); - if NeedsResize then - begin - if (not PasteNonPow2ImagesIntoPow2) or (LevelsArray[I].Width > CurrentWidth) or - (LevelsArray[I].Height > CurrentHeight)then - begin - // If pasteNP2toP2 is disabled or if source is bigger than target - // we rescale image, otherwise we paste it with the same size - ResizeImage(LevelsArray[I], CurrentWidth, CurrentHeight, rfBilinear) - end - else - PasteImage(LevelsArray[I], CurrentWidth, CurrentHeight); - end; - end - else - // Input image can be used without any changes - LevelsArray[I] := Images[I]; - end - else - begin - // This mipmap level is not present in the input image array - // so we create a new level - FillMipMapLevel(LevelsArray[I - 1], CurrentWidth, CurrentHeight, LevelsArray[I]); - end; - - if ConvTo in BlockCompressedFormats then - begin - // Note: GL DXTC texture snaller than 4x4 must have width and height - // as expected for non-DXTC texture (like 1x1 - we cannot - // use LevelsArray[I].Width and LevelsArray[I].Height - they are - // at least 4 for DXTC images). But Bits and Size passed to - // glCompressedTexImage2D must contain regular 4x4 DXTC block. - glCompressedTexImage2D(GL_TEXTURE_2D, I - MainLevelIndex, GLInternal, CurrentWidth, - CurrentHeight, 0, LevelsArray[I].Size, LevelsArray[I].Bits) - end - else - begin - glTexImage2D(GL_TEXTURE_2D, I - MainLevelIndex, GLInternal, CurrentWidth, - CurrentHeight, 0, GLFormat, GLType, LevelsArray[I].Bits); - end; - - // Calculate width and height of the next mipmap level - CurrentWidth := ClampInt(CurrentWidth div 2, 1, CurrentWidth); - CurrentHeight := ClampInt(CurrentHeight div 2, 1, CurrentHeight); - end; - - // Restore old pixel unpacking settings - glPixelStorei(GL_UNPACK_ALIGNMENT, UnpackAlignment); - glPixelStorei(GL_UNPACK_SKIP_ROWS, UnpackSkipRows); - glPixelStorei(GL_UNPACK_SKIP_PIXELS, UnpackSkipPixels); - glPixelStorei(GL_UNPACK_ROW_LENGTH, UnpackRowLength); - finally - // Free local image copies - for I := 0 to Length(LevelsArray) - 1 do - begin - if ((I < ExistingLevels) and (LevelsArray[I].Bits <> Images[I].Bits)) or - (I >= ExistingLevels) then - FreeImage(LevelsArray[I]); - end; - end; -end; - -function SaveGLTextureToFile(const FileName: string; const Texture: GLuint): Boolean; -var - Arr: TDynImageDataArray; - Fmt: TImageFileFormat; - IsDDS: Boolean; -begin - Result := CreateMultiImageFromGLTexture(Texture, Arr); - if Result then - begin - Fmt := FindImageFileFormatByName(FileName); - if Fmt <> nil then - begin - IsDDS := SameText(Fmt.Extensions[0], 'dds'); - if IsDDS then - begin - PushOptions; - SetOption(ImagingDDSSaveMipMapCount, Length(Arr)); - end; - Result := SaveMultiImageToFile(FileName, Arr); - if IsDDS then - PopOptions; - end; - FreeImagesInArray(Arr); - end; -end; - -function SaveGLTextureToStream(const Ext: string; Stream: TStream; const Texture: GLuint): Boolean; -var - Arr: TDynImageDataArray; - Fmt: TImageFileFormat; - IsDDS: Boolean; -begin - Result := CreateMultiImageFromGLTexture(Texture, Arr); - if Result then - begin - Fmt := FindImageFileFormatByExt(Ext); - if Fmt <> nil then - begin - IsDDS := SameText(Fmt.Extensions[0], 'dds'); - if IsDDS then - begin - PushOptions; - SetOption(ImagingDDSSaveMipMapCount, Length(Arr)); - end; - Result := SaveMultiImageToStream(Ext, Stream, Arr); - if IsDDS then - PopOptions; - end; - FreeImagesInArray(Arr); - end; -end; - -function SaveGLTextureToMemory(const Ext: string; Data: Pointer; var Size: LongInt; const Texture: GLuint): Boolean; -var - Arr: TDynImageDataArray; - Fmt: TImageFileFormat; - IsDDS: Boolean; -begin - Result := CreateMultiImageFromGLTexture(Texture, Arr); - if Result then - begin - Fmt := FindImageFileFormatByExt(Ext); - if Fmt <> nil then - begin - IsDDS := SameText(Fmt.Extensions[0], 'dds'); - if IsDDS then - begin - PushOptions; - SetOption(ImagingDDSSaveMipMapCount, Length(Arr)); - end; - Result := SaveMultiImageToMemory(Ext, Data, Size, Arr); - if IsDDS then - PopOptions; - end; - FreeImagesInArray(Arr); - end; -end; - -function CreateImageFromGLTexture(const Texture: GLuint; - var Image: TImageData; OverrideFormat: TImageFormat): Boolean; -var - Arr: TDynImageDataArray; -begin - // Just calls function operating on image arrays - FreeImage(Image); - SetLength(Arr, 1); - Result := CreateMultiImageFromGLTexture(Texture, Arr, 1, OverrideFormat); - Image := Arr[0]; -end; - -function CreateMultiImageFromGLTexture(const Texture: GLuint; - var Images: TDynImageDataArray; MipLevels: LongInt; OverrideFormat: TImageFormat): Boolean; -var - I, Width, Height, ExistingLevels: LongInt; -begin - FreeImagesInArray(Images); - SetLength(Images, 0); - Result := False; - if Byte(glIsTexture(Texture)) = GL_TRUE then - begin - // Check if desired mipmap level count is valid - glBindTexture(GL_TEXTURE_2D, Texture); - if MipLevels <= 0 then - MipLevels := GetNumMipMapLevels(Width, Height); - SetLength(Images, MipLevels); - ExistingLevels := 0; - - for I := 0 to MipLevels - 1 do - begin - // Get the current level size - glGetTexLevelParameteriv(GL_TEXTURE_2D, I, GL_TEXTURE_WIDTH, @Width); - glGetTexLevelParameteriv(GL_TEXTURE_2D, I, GL_TEXTURE_HEIGHT, @Height); - // Break when the mipmap chain is broken - if (Width = 0) or (Height = 0) then - Break; - // Create new image and copy texture data - NewImage(Width, Height, ifA8R8G8B8, Images[I]); - glGetTexImage(GL_TEXTURE_2D, I, GL_BGRA_EXT, GL_UNSIGNED_BYTE, Images[I].Bits); - Inc(ExistingLevels); - end; - // Resize mipmap array if necessary - if MipLevels <> ExistingLevels then - SetLength(Images, ExistingLevels); - // Convert images to desired format if set - if OverrideFormat <> ifUnknown then - for I := 0 to Length(Images) - 1 do - ConvertImage(Images[I], OverrideFormat); - - Result := True; - end; -end; - -initialization - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - use internal format of texture in CreateMultiImageFromGLTexture - not only A8R8G8B8 - - support for cube and 3D maps - - -- 0.26.1 Changes/Bug Fixes --------------------------------- - - Added support for GLScene's OpenGL header. - - -- 0.25.0 Changes/Bug Fixes --------------------------------- - - Added 3Dc compressed texture formats support. - - Added detection of 3Dc formats to texture caps. - - -- 0.24.3 Changes/Bug Fixes --------------------------------- - - Added DisableNPOTSupportCheck option and related functionality. - - Added some new texture caps detection. - - -- 0.24.1 Changes/Bug Fixes --------------------------------- - - Added PasteNonPow2ImagesIntoPow2 option and related functionality. - - Better NeedsResize determination for small DXTC textures - - avoids needless resizing. - - Added MainLevelIndex to CreateMultiImageFromGLTexture. - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Added CreatedWidth and CreatedHeight parameters to most - LoadGLTextureFromXXX/CreateGLTextureFromXXX functions. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - fixed bug in CreateGLTextureFromMultiImage which caused assert failure - when creating mipmaps (using FillMipMapLevel) for DXTC formats - - changed single channel floating point texture formats from - GL_INTENSITY..._ARB to GL_LUMINANCE..._ARB - - added support for half float texture formats (GL_RGBA16F_ARB etc.) - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - filtered mipmap creation - - more texture caps added - - fixed memory leaks in SaveGLTextureTo... functions - - -- 0.15 Changes/Bug Fixes ----------------------------------- - - unit created and initial stuff added -} - -end. +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains functions for loading and saving OpenGL textures + using Imaging and for converting images to textures and vice versa.} +unit ImagingOpenGL; + +{$I ImagingOptions.inc} + +{ Define this symbol if you want to use dglOpenGL header.} +{$DEFINE OPENGL_USE_DGL_HEADERS} + +{$IFDEF OPENGL_NO_EXT_HEADERS} + {$UNDEF OPENGL_USE_DGL_HEADERS} +{$ENDIF} + +interface + +uses + SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats, +{$IF Defined(OPENGL_USE_DGL_HEADERS)} + dglOpenGL, +{$ELSE} + gl, glext, +{$IFEND} + ImagingUtility; + +type + { Various texture capabilities of installed OpenGL driver.} + TGLTextureCaps = record + MaxTextureSize: LongInt; // Max size of texture in pixels supported by HW + NonPowerOfTwo: Boolean; // HW has full support for NPOT textures + DXTCompression: Boolean; // HW supports S3TC/DXTC compressed textures + ATI3DcCompression: Boolean; // HW supports ATI 3Dc compressed textures (ATI2N) + LATCCompression: Boolean; // HW supports LATC/RGTC compressed textures (ATI1N+ATI2N) + FloatTextures: Boolean; // HW supports floating point textures + MaxAnisotropy: LongInt; // Max anisotropy for aniso texture filtering + MaxSimultaneousTextures: LongInt; // Number of texture units + ClampToEdge: Boolean; // GL_EXT_texture_edge_clamp + TextureLOD: Boolean; // GL_SGIS_texture_lod + VertexTextureUnits: Integer; // Texture units accessible in vertex programs + end; + +{ Returns texture capabilities of installed OpenGL driver.} +function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean; +{ Function which can be used to retrieve GL extension functions.} +function GetGLProcAddress(const ProcName: string): Pointer; +{ Returns True if the given GL extension is supported.} +function IsGLExtensionSupported(const Extension: string): Boolean; +{ Returns True if the given image format can be represented as GL texture + format. GLFormat, GLType, and GLInternal are parameters for functions like + glTexImage. Note that GLU functions like gluBuildMipmaps cannot handle some + formats returned by this function (i.e. GL_UNSIGNED_SHORT_5_5_5_1 as GLType). + If you are using compressed or floating-point images make sure that they are + supported by hardware using GetGLTextureCaps, ImageFormatToGL does not + check this.} +function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum; + var GLType: GLenum; var GLInternal: GLint; const Caps: TGLTextureCaps): Boolean; + +{ All GL textures created by Imaging functions have default parameters set - + that means that no glTexParameter calls are made so default filtering, + wrapping, and other parameters are used. Created textures + are left bound by glBindTexture when function is exited.} + +{ Creates GL texture from image in file in format supported by Imaging. + You can use CreatedWidth and Height parameters to query dimensions of created textures + (it could differ from dimensions of source image).} +function LoadGLTextureFromFile(const FileName: string; CreatedWidth: PLongInt = nil; + CreatedHeight: PLongInt = nil): GLuint; +{ Creates GL texture from image in stream in format supported by Imaging. + You can use CreatedWidth and Height parameters to query dimensions of created textures + (it could differ from dimensions of source image).} +function LoadGLTextureFromStream(Stream: TStream; CreatedWidth: PLongInt = nil; + CreatedHeight: PLongInt = nil): GLuint; +{ Creates GL texture from image in memory in format supported by Imaging. + You can use CreatedWidth and Height parameters to query dimensions of created textures + (it could differ from dimensions of source image).} +function LoadGLTextureFromMemory(Data: Pointer; Size: LongInt; + CreatedWidth: PLongInt = nil; CreatedHeight: PLongInt = nil): GLuint; + +{ Converts TImageData structure to OpenGL texture. + Input images is used as main mipmap level and additional requested + levels are generated from this one. For the details on parameters + look at CreateGLTextureFromMultiImage function.} +function CreateGLTextureFromImage(const Image: TImageData; + Width: LongInt = 0; Height: LongInt = 0; MipMaps: Boolean = True; + OverrideFormat: TImageFormat = ifUnknown; CreatedWidth: PLongInt = nil; + CreatedHeight: PLongInt = nil): GLuint; +{ Converts images in TDymImageDataArray to one OpenGL texture. + Image at index MainLevelIndex in the array is used as main mipmap level and + additional images are used as subsequent levels. If there is not enough images + in array missing levels are automatically generated (and if there is enough images + but they have wrong dimensions or format then they are resized/converted). + If driver supports only power of two sized textures images are resized. + OverrideFormat can be used to convert image into specific format before + it is passed to OpenGL, ifUnknown means no conversion. + If desired texture format is not supported by hardware default + A8R8G8B8 format is used instead for color images and ifGray8 is used + for luminance images. DXTC (S3TC) compressed and floating point textures + are created if supported by hardware. + Width and Height can be used to set size of main mipmap level according + to your needs, Width and Height of 0 mean use width and height of input + image that will become main level mipmap. + MipMaps set to True mean build all possible levels, False means use only level 0. + You can use CreatedWidth and CreatedHeight parameters to query dimensions of + created texture's largest mipmap level (it could differ from dimensions + of source image).} +function CreateGLTextureFromMultiImage(const Images: TDynImageDataArray; + Width: LongInt = 0; Height: LongInt = 0; MipMaps: Boolean = True; + MainLevelIndex: LongInt = 0; OverrideFormat: TImageFormat = ifUnknown; + CreatedWidth: PLongInt = nil; CreatedHeight: PLongInt = nil): GLuint; + +{ Saves GL texture to file in one of formats supported by Imaging. + Saves all present mipmap levels.} +function SaveGLTextureToFile(const FileName: string; const Texture: GLuint): Boolean; +{ Saves GL texture to stream in one of formats supported by Imaging. + Saves all present mipmap levels.} +function SaveGLTextureToStream(const Ext: string; Stream: TStream; const Texture: GLuint): Boolean; +{ Saves GL texture to memory in one of formats supported by Imaging. + Saves all present mipmap levels.} +function SaveGLTextureToMemory(const Ext: string; Data: Pointer; var Size: LongInt; const Texture: GLuint): Boolean; + +{ Converts main level of the GL texture to TImageData structure. OverrideFormat + can be used to convert output image to the specified format rather + than use the format taken from GL texture, ifUnknown means no conversion.} +function CreateImageFromGLTexture(const Texture: GLuint; + var Image: TImageData; OverrideFormat: TImageFormat = ifUnknown): Boolean; +{ Converts GL texture to TDynImageDataArray array of images. You can specify + how many mipmap levels of the input texture you want to be converted + (default is all levels). OverrideFormat can be used to convert output images to + the specified format rather than use the format taken from GL texture, + ifUnknown means no conversion.} +function CreateMultiImageFromGLTexture(const Texture: GLuint; + var Images: TDynImageDataArray; MipLevels: LongInt = 0; + OverrideFormat: TImageFormat = ifUnknown): Boolean; + +var + { Standard behaviour of image->texture functions like CreateGLTextureFrom(Multi)Image is: + If graphic card supports non power of 2 textures and image is nonpow2 then + texture is created directly from image. + If graphic card does not support them input image is rescaled (bilinear) + to power of 2 size. + If you set PasteNonPow2ImagesIntoPow2 to True then instead of rescaling, a new + pow2 texture is created and nonpow2 input image is pasted into it + keeping its original size. This could be useful for some 2D stuff + (and its faster than rescaling of course). Note that this is applied + to all rescaling smaller->bigger operations that might occur during + image->texture process (usually only pow2/nonpow2 stuff and when you + set custom Width & Height in CreateGLTextureFrom(Multi)Image).} + PasteNonPow2ImagesIntoPow2: Boolean = False; + { Standard behavior if GL_ARB_texture_non_power_of_two extension is not supported + is to rescale image to power of 2 dimensions. NPOT extension is exposed only + when HW has full support for NPOT textures but some cards + (pre-DX10 ATI Radeons, some other maybe) have partial NPOT support. + Namely Radeons can use NPOT textures but not mipmapped. If you know what you are doing + you can disable NPOT support check so the image won't be rescaled to POT + by setting DisableNPOTSupportCheck to True.} + DisableNPOTSupportCheck: Boolean = False; + +implementation + +const + // Cube map constants + GL_TEXTURE_BINDING_CUBE_MAP = $8514; + GL_TEXTURE_CUBE_MAP_POSITIVE_X = $8515; + GL_TEXTURE_CUBE_MAP_NEGATIVE_X = $8516; + GL_TEXTURE_CUBE_MAP_POSITIVE_Y = $8517; + GL_TEXTURE_CUBE_MAP_NEGATIVE_Y = $8518; + GL_TEXTURE_CUBE_MAP_POSITIVE_Z = $8519; + GL_TEXTURE_CUBE_MAP_NEGATIVE_Z = $851A; + + // Texture formats + GL_COLOR_INDEX = $1900; + GL_STENCIL_INDEX = $1901; + GL_DEPTH_COMPONENT = $1902; + GL_RED = $1903; + GL_GREEN = $1904; + GL_BLUE = $1905; + GL_ALPHA = $1906; + GL_RGB = $1907; + GL_RGBA = $1908; + GL_LUMINANCE = $1909; + GL_LUMINANCE_ALPHA = $190A; + GL_BGR_EXT = $80E0; + GL_BGRA_EXT = $80E1; + + // Texture internal formats + GL_ALPHA4 = $803B; + GL_ALPHA8 = $803C; + GL_ALPHA12 = $803D; + GL_ALPHA16 = $803E; + GL_LUMINANCE4 = $803F; + GL_LUMINANCE8 = $8040; + GL_LUMINANCE12 = $8041; + GL_LUMINANCE16 = $8042; + GL_LUMINANCE4_ALPHA4 = $8043; + GL_LUMINANCE6_ALPHA2 = $8044; + GL_LUMINANCE8_ALPHA8 = $8045; + GL_LUMINANCE12_ALPHA4 = $8046; + GL_LUMINANCE12_ALPHA12 = $8047; + GL_LUMINANCE16_ALPHA16 = $8048; + GL_INTENSITY = $8049; + GL_INTENSITY4 = $804A; + GL_INTENSITY8 = $804B; + GL_INTENSITY12 = $804C; + GL_INTENSITY16 = $804D; + GL_R3_G3_B2 = $2A10; + GL_RGB4 = $804F; + GL_RGB5 = $8050; + GL_RGB8 = $8051; + GL_RGB10 = $8052; + GL_RGB12 = $8053; + GL_RGB16 = $8054; + GL_RGBA2 = $8055; + GL_RGBA4 = $8056; + GL_RGB5_A1 = $8057; + GL_RGBA8 = $8058; + GL_RGB10_A2 = $8059; + GL_RGBA12 = $805A; + GL_RGBA16 = $805B; + GL_RGB565 = $8D62; + + // Floating point texture formats + GL_RGBA32F_ARB = $8814; + GL_INTENSITY32F_ARB = $8817; + GL_LUMINANCE32F_ARB = $8818; + GL_RGBA16F_ARB = $881A; + GL_INTENSITY16F_ARB = $881D; + GL_LUMINANCE16F_ARB = $881E; + + // Compressed texture formats + // S3TC/DXTC + GL_COMPRESSED_RGB_S3TC_DXT1_EXT = $83F0; + GL_COMPRESSED_RGBA_S3TC_DXT1_EXT = $83F1; + GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2; + GL_COMPRESSED_RGBA_S3TC_DXT5_EXT = $83F3; + // 3Dc LATC + GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI = $8837; + GL_COMPRESSED_LUMINANCE_LATC1_EXT = $8C70; + GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT = $8C71; + GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT = $8C72; + GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT = $8C73; + // ETC1 GL_OES_compressed_ETC1_RGB8_texture + GL_ETC1_RGB_OES = $8D64; + // PVRTC GL_IMG_texture_compression_pvrtc + GL_COMPRESSED_RGB_PVRTC_4BPPV1_IMG = $8C00; + GL_COMPRESSED_RGB_PVRTC_2BPPV1_IMG = $8C01; + GL_COMPRESSED_RGBA_PVRTC_4BPPV1_IMG = $8C02; + GL_COMPRESSED_RGBA_PVRTC_2BPPV1_IMG = $8C03; + // AMD ATC + GL_ATC_RGBA_EXPLICIT_ALPHA_AMD = $8C93; + GL_ATC_RGBA_INTERPOLATED_ALPHA_AMD = $87EE; + // ETC2/EAC + GL_COMPRESSED_R11_EAC = $9270; + GL_COMPRESSED_SIGNED_R11_EAC = $9271; + GL_COMPRESSED_RG11_EAC = $9272; + GL_COMPRESSED_SIGNED_RG11_EAC = $9273; + GL_COMPRESSED_RGB8_ETC2 = $9274; + GL_COMPRESSED_SRGB8_ETC2 = $9275; + GL_COMPRESSED_RGB8_PUNCHTHROUGH_ALPHA1_ETC2 = $9276; + GL_COMPRESSED_SRGB8_PUNCHTHROUGH_ALPHA1_ETC2 = $9277; + GL_COMPRESSED_RGBA8_ETC2_EAC = $9278; + GL_COMPRESSED_SRGB8_ALPHA8_ETC2_EAC = $9279; + + // Various GL extension constants + GL_MAX_TEXTURE_UNITS = $84E2; + GL_TEXTURE_MAX_ANISOTROPY_EXT = $84FE; + GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT = $84FF; + + // Texture source data formats + GL_UNSIGNED_BYTE_3_3_2 = $8032; + GL_UNSIGNED_SHORT_4_4_4_4 = $8033; + GL_UNSIGNED_SHORT_5_5_5_1 = $8034; + GL_UNSIGNED_INT_8_8_8_8 = $8035; + GL_UNSIGNED_INT_10_10_10_2 = $8036; + GL_UNSIGNED_BYTE_2_3_3_REV = $8362; + GL_UNSIGNED_SHORT_5_6_5 = $8363; + GL_UNSIGNED_SHORT_5_6_5_REV = $8364; + GL_UNSIGNED_SHORT_4_4_4_4_REV = $8365; + GL_UNSIGNED_SHORT_1_5_5_5_REV = $8366; + GL_UNSIGNED_INT_8_8_8_8_REV = $8367; + GL_UNSIGNED_INT_2_10_10_10_REV = $8368; + GL_HALF_FLOAT_ARB = $140B; + + // Other GL constants + GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS = $8B4C; + + +{$IFDEF MSWINDOWS} + GLLibName = 'opengl32.dll'; +{$ENDIF} +{$IFDEF UNIX} + GLLibName = 'libGL.so'; +{$ENDIF} + +type + TglCompressedTexImage2D = procedure (Target: GLenum; Level: GLint; + InternalFormat: GLenum; Width: GLsizei; Height: GLsizei; Border: GLint; + ImageSize: GLsizei; const Data: PGLvoid); + {$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} +var + glCompressedTexImage2D: TglCompressedTexImage2D = nil; + ExtensionBuffer: string = ''; + +{$IFDEF MSWINDOWS} +function wglGetProcAddress(ProcName: PAnsiChar): Pointer; stdcall; external GLLibName; +{$ENDIF} +{$IFDEF UNIX} +function glXGetProcAddress(ProcName: PAnsiChar): Pointer; cdecl; external GLLibName; +{$ENDIF} + +function IsGLExtensionSupported(const Extension: string): Boolean; +var + ExtPos: LongInt; +begin + if ExtensionBuffer = '' then + ExtensionBuffer := glGetString(GL_EXTENSIONS); + + ExtPos := Pos(Extension, ExtensionBuffer); + Result := ExtPos > 0; + if Result then + begin + Result := ((ExtPos + Length(Extension) - 1) = Length(ExtensionBuffer)) or + not (ExtensionBuffer[ExtPos + Length(Extension)] in ['_', 'A'..'Z', 'a'..'z']); + end; +end; + +function GetGLProcAddress(const ProcName: string): Pointer; +begin +{$IFDEF MSWINDOWS} + Result := wglGetProcAddress(PAnsiChar(AnsiString(ProcName))); +{$ENDIF} +{$IFDEF UNIX} + Result := glXGetProcAddress(PAnsiChar(AnsiString(ProcName))); +{$ENDIF} +end; + +function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean; +begin + // Check DXTC support and load extension functions if necessary + Caps.DXTCompression := IsGLExtensionSupported('GL_ARB_texture_compression') and + IsGLExtensionSupported('GL_EXT_texture_compression_s3tc'); + if Caps.DXTCompression then + glCompressedTexImage2D := GetGLProcAddress('glCompressedTexImage2D'); + Caps.DXTCompression := Caps.DXTCompression and (@glCompressedTexImage2D <> nil); + Caps.ATI3DcCompression := Caps.DXTCompression and + IsGLExtensionSupported('GL_ATI_texture_compression_3dc'); + Caps.LATCCompression := Caps.DXTCompression and + IsGLExtensionSupported('GL_EXT_texture_compression_latc'); + // Check non power of 2 textures + Caps.NonPowerOfTwo := IsGLExtensionSupported('GL_ARB_texture_non_power_of_two'); + // Check for floating point textures support + Caps.FloatTextures := IsGLExtensionSupported('GL_ARB_texture_float'); + // Get max texture size + glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize); + // Get max anisotropy + if IsGLExtensionSupported('GL_EXT_texture_filter_anisotropic') then + glGetIntegerv(GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT, @Caps.MaxAnisotropy) + else + Caps.MaxAnisotropy := 0; + // Get number of texture units + if IsGLExtensionSupported('GL_ARB_multitexture') then + glGetIntegerv(GL_MAX_TEXTURE_UNITS, @Caps.MaxSimultaneousTextures) + else + Caps.MaxSimultaneousTextures := 1; + // Get number of vertex texture units + if IsGLExtensionSupported('GL_ARB_vertex_shader') then + glGetIntegerv(GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS, @Caps.VertexTextureUnits) + else + Caps.VertexTextureUnits := 1; + // Get max texture size + glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize); + // Clamp texture to edge? + Caps.ClampToEdge := IsGLExtensionSupported('GL_EXT_texture_edge_clamp'); + // Texture LOD extension? + Caps.TextureLOD := IsGLExtensionSupported('GL_SGIS_texture_lod'); + + Result := True; +end; + +function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum; + var GLType: GLenum; var GLInternal: GLint; const Caps: TGLTextureCaps): Boolean; +begin + GLFormat := 0; + GLType := 0; + GLInternal := 0; + case Format of + // Gray formats + ifGray8, ifGray16: + begin + GLFormat := GL_LUMINANCE; + GLType := Iff(Format = ifGray8, GL_UNSIGNED_BYTE, GL_UNSIGNED_SHORT); + GLInternal := Iff(Format = ifGray8, GL_LUMINANCE8, GL_LUMINANCE16); + end; + ifA8Gray8, ifA16Gray16: + begin + GLFormat := GL_LUMINANCE_ALPHA; + GLType := Iff(Format = ifA8Gray8, GL_UNSIGNED_BYTE, GL_UNSIGNED_SHORT); + GLInternal := Iff(Format = ifA8Gray8, GL_LUMINANCE8_ALPHA8, GL_LUMINANCE16_ALPHA16); + end; + // RGBA formats + ifR3G3B2: + begin + GLFormat := GL_RGB; + GLType := GL_UNSIGNED_BYTE_3_3_2; + GLInternal := GL_R3_G3_B2; + end; + ifR5G6B5: + begin + GLFormat := GL_RGB; + GLType := GL_UNSIGNED_SHORT_5_6_5; + GLInternal := GL_RGB5; //GL_RGB565 ot working on Radeons + end; + ifA1R5G5B5, ifX1R5G5B5: + begin + GLFormat := GL_BGRA_EXT; + GLType := GL_UNSIGNED_SHORT_1_5_5_5_REV; + GLInternal := Iff(Format = ifA1R5G5B5, GL_RGB5_A1, GL_RGB5); + end; + ifA4R4G4B4, ifX4R4G4B4: + begin + GLFormat := GL_BGRA_EXT; + GLType := GL_UNSIGNED_SHORT_4_4_4_4_REV; + GLInternal := Iff(Format = ifA4R4G4B4, GL_RGBA4, GL_RGB4); + end; + ifR8G8B8: + begin + GLFormat := GL_BGR_EXT; + GLType := GL_UNSIGNED_BYTE; + GLInternal := GL_RGB8; + end; + ifA8R8G8B8, ifX8R8G8B8: + begin + GLFormat := GL_BGRA_EXT; + GLType := GL_UNSIGNED_BYTE; + GLInternal := Iff(Format = ifA8R8G8B8, GL_RGBA8, GL_RGB8); + end; + ifR16G16B16, ifB16G16R16: + begin + GLFormat := Iff(Format = ifR16G16B16, GL_BGR_EXT, GL_RGB); + GLType := GL_UNSIGNED_SHORT; + GLInternal := GL_RGB16; + end; + ifA16R16G16B16, ifA16B16G16R16: + begin + GLFormat := Iff(Format = ifA16R16G16B16, GL_BGRA_EXT, GL_RGBA); + GLType := GL_UNSIGNED_SHORT; + GLInternal := GL_RGBA16; + end; + // Floating-Point formats + ifR32F: + begin + GLFormat := GL_RED; + GLType := GL_FLOAT; + GLInternal := GL_LUMINANCE32F_ARB; + end; + ifA32R32G32B32F, ifA32B32G32R32F: + begin + GLFormat := Iff(Format = ifA32R32G32B32F, GL_BGRA_EXT, GL_RGBA); + GLType := GL_FLOAT; + GLInternal := GL_RGBA32F_ARB; + end; + ifR16F: + begin + GLFormat := GL_RED; + GLType := GL_HALF_FLOAT_ARB; + GLInternal := GL_LUMINANCE16F_ARB; + end; + ifA16R16G16B16F, ifA16B16G16R16F: + begin + GLFormat := Iff(Format = ifA16R16G16B16F, GL_BGRA_EXT, GL_RGBA); + GLType := GL_HALF_FLOAT_ARB; + GLInternal := GL_RGBA16F_ARB; + end; + // Special formats + ifDXT1: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT1_EXT; + ifDXT3: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT3_EXT; + ifDXT5: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT5_EXT; + ifATI1N: GLInternal := GL_COMPRESSED_LUMINANCE_LATC1_EXT; + ifATI2N: + begin + GLInternal := GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT; + if not Caps.LATCCompression and Caps.ATI3DcCompression then + GLInternal := GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI; + end; + end; + Result := GLInternal <> 0; +end; + +function LoadGLTextureFromFile(const FileName: string; CreatedWidth, CreatedHeight: PLongInt): GLuint; +var + Images: TDynImageDataArray; +begin + if LoadMultiImageFromFile(FileName, Images) and (Length(Images) > 0) then + begin + Result := CreateGLTextureFromMultiImage(Images, Images[0].Width, + Images[0].Height, True, 0, ifUnknown, CreatedWidth, CreatedHeight); + end + else + Result := 0; + FreeImagesInArray(Images); +end; + +function LoadGLTextureFromStream(Stream: TStream; CreatedWidth, CreatedHeight: PLongInt): GLuint; +var + Images: TDynImageDataArray; +begin + if LoadMultiImageFromStream(Stream, Images) and (Length(Images) > 0) then + begin + Result := CreateGLTextureFromMultiImage(Images, Images[0].Width, + Images[0].Height, True, 0, ifUnknown, CreatedWidth, CreatedHeight); + end + else + Result := 0; + FreeImagesInArray(Images); +end; + +function LoadGLTextureFromMemory(Data: Pointer; Size: LongInt; CreatedWidth, CreatedHeight: PLongInt): GLuint; +var + Images: TDynImageDataArray; +begin + if LoadMultiImageFromMemory(Data, Size, Images) and (Length(Images) > 0) then + begin + Result := CreateGLTextureFromMultiImage(Images, Images[0].Width, + Images[0].Height, True, 0, ifUnknown, CreatedWidth, CreatedHeight); + end + else + Result := 0; + FreeImagesInArray(Images); +end; + +function CreateGLTextureFromImage(const Image: TImageData; + Width, Height: LongInt; MipMaps: Boolean; OverrideFormat: TImageFormat; + CreatedWidth, CreatedHeight: PLongInt): GLuint; +var + Arr: TDynImageDataArray; +begin + // Just calls function operating on image arrays + SetLength(Arr, 1); + Arr[0] := Image; + Result := CreateGLTextureFromMultiImage(Arr, Width, Height, MipMaps, 0, + OverrideFormat, CreatedWidth, CreatedHeight); +end; + +function CreateGLTextureFromMultiImage(const Images: TDynImageDataArray; + Width, Height: LongInt; MipMaps: Boolean; MainLevelIndex: LongInt; OverrideFormat: TImageFormat; + CreatedWidth, CreatedHeight: PLongInt): GLuint; +const + BlockCompressedFormats: TImageFormats = [ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N]; +var + I, MipLevels, PossibleLevels, ExistingLevels, CurrentWidth, CurrentHeight: LongInt; + Caps: TGLTextureCaps; + GLFormat: GLenum; + GLType: GLenum; + GLInternal: GLint; + Desired, ConvTo: TImageFormat; + Info: TImageFormatInfo; + LevelsArray: TDynImageDataArray; + NeedsResize, NeedsConvert: Boolean; + UnpackAlignment, UnpackSkipRows, UnpackSkipPixels, UnpackRowLength: LongInt; + + procedure PasteImage(var Image: TImageData; Width, Height: LongInt); + var + Clone: TImageData; + begin + CloneImage(Image, Clone); + NewImage(Width, Height, Clone.Format, Image); + FillRect(Image, 0, 0, Width, Height, Clone.Bits); + CopyRect(Clone, 0, 0, Clone.Width, Clone.Height, Image, 0, 0); + FreeImage(Clone); + end; + +begin + Result := 0; + ExistingLevels := Length(Images); + + if GetGLTextureCaps(Caps) and (ExistingLevels > 0) then + try + // Check if requested main level is at valid index + if (MainLevelIndex < 0) or (MainLevelIndex > High(Images)) then + MainLevelIndex := 0; + + // First check desired size and modify it if necessary + if Width <= 0 then Width := Images[MainLevelIndex].Width; + if Height <= 0 then Height := Images[MainLevelIndex].Height; + if not Caps.NonPowerOfTwo and not DisableNPOTSupportCheck then + begin + // If device supports only power of 2 texture sizes + Width := NextPow2(Width); + Height := NextPow2(Height); + end; + Width := ClampInt(Width, 1, Caps.MaxTextureSize); + Height := ClampInt(Height, 1, Caps.MaxTextureSize); + + // Get various mipmap level counts and modify + // desired MipLevels if its value is invalid + PossibleLevels := GetNumMipMapLevels(Width, Height); + if MipMaps then + MipLevels := PossibleLevels + else + MipLevels := 1; + + // Prepare array for mipmap levels. Make it larger than necessary - that + // way we can use the same index for input images and levels in the large loop below + SetLength(LevelsArray, MipLevels + MainLevelIndex); + + // Now determine which image format will be used + if OverrideFormat = ifUnknown then + Desired := Images[MainLevelIndex].Format + else + Desired := OverrideFormat; + + // Check if the hardware supports floating point and compressed textures + GetImageFormatInfo(Desired, Info); + if Info.IsFloatingPoint and not Caps.FloatTextures then + Desired := ifA8R8G8B8; + if (Desired in [ifDXT1, ifDXT3, ifDXT5]) and not Caps.DXTCompression then + Desired := ifA8R8G8B8; + if (Desired = ifATI1N) and not Caps.LATCCompression then + Desired := ifGray8; + if (Desired = ifATI2N) and not (Caps.ATI3DcCompression or Caps.LATCCompression) then + Desired := ifA8Gray8; + + // Try to find GL format equivalent to image format and if it is not + // found use one of default formats + if not ImageFormatToGL(Desired, GLFormat, GLType, GLInternal, Caps) then + begin + GetImageFormatInfo(Desired, Info); + if Info.HasGrayChannel then + ConvTo := ifGray8 + else + ConvTo := ifA8R8G8B8; + if not ImageFormatToGL(ConvTo, GLFormat, GLType, GLInternal, Caps) then + Exit; + end + else + ConvTo := Desired; + + CurrentWidth := Width; + CurrentHeight := Height; + // If user is interested in width and height of created texture lets + // give him that + if CreatedWidth <> nil then CreatedWidth^ := CurrentWidth; + if CreatedHeight <> nil then CreatedHeight^ := CurrentHeight; + + // Store old pixel unpacking settings + glGetIntegerv(GL_UNPACK_ALIGNMENT, @UnpackAlignment); + glGetIntegerv(GL_UNPACK_SKIP_ROWS, @UnpackSkipRows); + glGetIntegerv(GL_UNPACK_SKIP_PIXELS, @UnpackSkipPixels); + glGetIntegerv(GL_UNPACK_ROW_LENGTH, @UnpackRowLength); + // Set new pixel unpacking settings + glPixelStorei(GL_UNPACK_ALIGNMENT, 1); + glPixelStorei(GL_UNPACK_SKIP_ROWS, 0); + glPixelStorei(GL_UNPACK_SKIP_PIXELS, 0); + glPixelStorei(GL_UNPACK_ROW_LENGTH, 0); + + // Generate new texture, bind it and set + glGenTextures(1, @Result); + glBindTexture(GL_TEXTURE_2D, Result); + if glIsTexture(Result) <> GL_TRUE then + Exit; + + for I := MainLevelIndex to MipLevels - 1 + MainLevelIndex do + begin + // Check if we can use input image array as a source for this mipmap level + if I < ExistingLevels then + begin + // Check if input image for this mipmap level has the right + // size and format + NeedsConvert := not (Images[I].Format = ConvTo); + if ConvTo in BlockCompressedFormats then + begin + // Input images in DXTC will have min dimensions of 4, but we need + // current Width and Height to be lesser (for glCompressedTexImage2D) + NeedsResize := not ((Images[I].Width = Max(4, CurrentWidth)) and + (Images[I].Height = Max(4, CurrentHeight))); + end + else + NeedsResize := not ((Images[I].Width = CurrentWidth) and (Images[I].Height = CurrentHeight)); + + if NeedsResize or NeedsConvert then + begin + // Input image must be resized or converted to different format + // to become valid mipmap level + CloneImage(Images[I], LevelsArray[I]); + if NeedsConvert then + ConvertImage(LevelsArray[I], ConvTo); + if NeedsResize then + begin + if (not PasteNonPow2ImagesIntoPow2) or (LevelsArray[I].Width > CurrentWidth) or + (LevelsArray[I].Height > CurrentHeight)then + begin + // If pasteNP2toP2 is disabled or if source is bigger than target + // we rescale image, otherwise we paste it with the same size + ResizeImage(LevelsArray[I], CurrentWidth, CurrentHeight, rfBilinear) + end + else + PasteImage(LevelsArray[I], CurrentWidth, CurrentHeight); + end; + end + else + // Input image can be used without any changes + LevelsArray[I] := Images[I]; + end + else + begin + // This mipmap level is not present in the input image array + // so we create a new level + FillMipMapLevel(LevelsArray[I - 1], CurrentWidth, CurrentHeight, LevelsArray[I]); + end; + + if ConvTo in BlockCompressedFormats then + begin + // Note: GL DXTC texture snaller than 4x4 must have width and height + // as expected for non-DXTC texture (like 1x1 - we cannot + // use LevelsArray[I].Width and LevelsArray[I].Height - they are + // at least 4 for DXTC images). But Bits and Size passed to + // glCompressedTexImage2D must contain regular 4x4 DXTC block. + glCompressedTexImage2D(GL_TEXTURE_2D, I - MainLevelIndex, GLInternal, CurrentWidth, + CurrentHeight, 0, LevelsArray[I].Size, LevelsArray[I].Bits) + end + else + begin + glTexImage2D(GL_TEXTURE_2D, I - MainLevelIndex, GLInternal, CurrentWidth, + CurrentHeight, 0, GLFormat, GLType, LevelsArray[I].Bits); + end; + + // Calculate width and height of the next mipmap level + CurrentWidth := ClampInt(CurrentWidth div 2, 1, CurrentWidth); + CurrentHeight := ClampInt(CurrentHeight div 2, 1, CurrentHeight); + end; + + // Restore old pixel unpacking settings + glPixelStorei(GL_UNPACK_ALIGNMENT, UnpackAlignment); + glPixelStorei(GL_UNPACK_SKIP_ROWS, UnpackSkipRows); + glPixelStorei(GL_UNPACK_SKIP_PIXELS, UnpackSkipPixels); + glPixelStorei(GL_UNPACK_ROW_LENGTH, UnpackRowLength); + finally + // Free local image copies + for I := 0 to Length(LevelsArray) - 1 do + begin + if ((I < ExistingLevels) and (LevelsArray[I].Bits <> Images[I].Bits)) or + (I >= ExistingLevels) then + FreeImage(LevelsArray[I]); + end; + end; +end; + +function SaveGLTextureToFile(const FileName: string; const Texture: GLuint): Boolean; +var + Arr: TDynImageDataArray; + Fmt: TImageFileFormat; + IsDDS: Boolean; +begin + Result := CreateMultiImageFromGLTexture(Texture, Arr); + if Result then + begin + Fmt := FindImageFileFormatByName(FileName); + if Fmt <> nil then + begin + IsDDS := SameText(Fmt.Extensions[0], 'dds'); + if IsDDS then + begin + PushOptions; + SetOption(ImagingDDSSaveMipMapCount, Length(Arr)); + end; + Result := SaveMultiImageToFile(FileName, Arr); + if IsDDS then + PopOptions; + end; + FreeImagesInArray(Arr); + end; +end; + +function SaveGLTextureToStream(const Ext: string; Stream: TStream; const Texture: GLuint): Boolean; +var + Arr: TDynImageDataArray; + Fmt: TImageFileFormat; + IsDDS: Boolean; +begin + Result := CreateMultiImageFromGLTexture(Texture, Arr); + if Result then + begin + Fmt := FindImageFileFormatByExt(Ext); + if Fmt <> nil then + begin + IsDDS := SameText(Fmt.Extensions[0], 'dds'); + if IsDDS then + begin + PushOptions; + SetOption(ImagingDDSSaveMipMapCount, Length(Arr)); + end; + Result := SaveMultiImageToStream(Ext, Stream, Arr); + if IsDDS then + PopOptions; + end; + FreeImagesInArray(Arr); + end; +end; + +function SaveGLTextureToMemory(const Ext: string; Data: Pointer; var Size: LongInt; const Texture: GLuint): Boolean; +var + Arr: TDynImageDataArray; + Fmt: TImageFileFormat; + IsDDS: Boolean; +begin + Result := CreateMultiImageFromGLTexture(Texture, Arr); + if Result then + begin + Fmt := FindImageFileFormatByExt(Ext); + if Fmt <> nil then + begin + IsDDS := SameText(Fmt.Extensions[0], 'dds'); + if IsDDS then + begin + PushOptions; + SetOption(ImagingDDSSaveMipMapCount, Length(Arr)); + end; + Result := SaveMultiImageToMemory(Ext, Data, Size, Arr); + if IsDDS then + PopOptions; + end; + FreeImagesInArray(Arr); + end; +end; + +function CreateImageFromGLTexture(const Texture: GLuint; + var Image: TImageData; OverrideFormat: TImageFormat): Boolean; +var + Arr: TDynImageDataArray; +begin + // Just calls function operating on image arrays + FreeImage(Image); + SetLength(Arr, 1); + Result := CreateMultiImageFromGLTexture(Texture, Arr, 1, OverrideFormat); + Image := Arr[0]; +end; + +function CreateMultiImageFromGLTexture(const Texture: GLuint; + var Images: TDynImageDataArray; MipLevels: LongInt; OverrideFormat: TImageFormat): Boolean; +var + I, Width, Height, ExistingLevels: LongInt; +begin + FreeImagesInArray(Images); + SetLength(Images, 0); + Result := False; + if glIsTexture(Texture) = GL_TRUE then + begin + // Check if desired mipmap level count is valid + glBindTexture(GL_TEXTURE_2D, Texture); + if MipLevels <= 0 then + begin + glGetTexLevelParameteriv(GL_TEXTURE_2D, 0, GL_TEXTURE_WIDTH, @Width); + glGetTexLevelParameteriv(GL_TEXTURE_2D, 0, GL_TEXTURE_HEIGHT, @Height); + MipLevels := GetNumMipMapLevels(Width, Height); + end; + SetLength(Images, MipLevels); + ExistingLevels := 0; + + for I := 0 to MipLevels - 1 do + begin + // Get the current level size + glGetTexLevelParameteriv(GL_TEXTURE_2D, I, GL_TEXTURE_WIDTH, @Width); + glGetTexLevelParameteriv(GL_TEXTURE_2D, I, GL_TEXTURE_HEIGHT, @Height); + // Break when the mipmap chain is broken + if (Width = 0) or (Height = 0) then + Break; + // Create new image and copy texture data + NewImage(Width, Height, ifA8R8G8B8, Images[I]); + glGetTexImage(GL_TEXTURE_2D, I, GL_BGRA_EXT, GL_UNSIGNED_BYTE, Images[I].Bits); + Inc(ExistingLevels); + end; + // Resize mipmap array if necessary + if MipLevels <> ExistingLevels then + SetLength(Images, ExistingLevels); + // Convert images to desired format if set + if OverrideFormat <> ifUnknown then + for I := 0 to Length(Images) - 1 do + ConvertImage(Images[I], OverrideFormat); + + Result := True; + end; +end; + +initialization + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + + -- 0.77.1 --------------------------------------------------- + - Added some new compressed formats IDs + + -- 0.26.5 Changes/Bug Fixes --------------------------------- + - Fixed GetGLProcAddress in Unicode Delphi. Compressed + textures didn't work because of this. + + -- 0.26.1 Changes/Bug Fixes --------------------------------- + - Added support for GLScene's OpenGL header. + + -- 0.25.0 Changes/Bug Fixes --------------------------------- + - Added 3Dc compressed texture formats support. + - Added detection of 3Dc formats to texture caps. + + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - Added DisableNPOTSupportCheck option and related functionality. + - Added some new texture caps detection. + + -- 0.24.1 Changes/Bug Fixes --------------------------------- + - Added PasteNonPow2ImagesIntoPow2 option and related functionality. + - Better NeedsResize determination for small DXTC textures - + avoids needless resizing. + - Added MainLevelIndex to CreateMultiImageFromGLTexture. + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Added CreatedWidth and CreatedHeight parameters to most + LoadGLTextureFromXXX/CreateGLTextureFromXXX functions. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - fixed bug in CreateGLTextureFromMultiImage which caused assert failure + when creating mipmaps (using FillMipMapLevel) for DXTC formats + - changed single channel floating point texture formats from + GL_INTENSITY..._ARB to GL_LUMINANCE..._ARB + - added support for half float texture formats (GL_RGBA16F_ARB etc.) + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - filtered mipmap creation + - more texture caps added + - fixed memory leaks in SaveGLTextureTo... functions + + -- 0.15 Changes/Bug Fixes ----------------------------------- + - unit created and initial stuff added +} + +end. diff --git a/Imaging/ImagingOptions.inc b/Imaging/ImagingOptions.inc index a14f32d..63e5cf9 100644 --- a/Imaging/ImagingOptions.inc +++ b/Imaging/ImagingOptions.inc @@ -1,188 +1,228 @@ -{ $Id: ImagingOptions.inc 174 2009-09-08 09:37:59Z galfar $ } - -{ - User Options - Following defines and options can be changed by user. -} - -{ Source options } - -{$DEFINE USE_INLINE} // Use function inlining for some functions - // works in Free Pascal and Delphi 9+. -{.$DEFINE USE_ASM} // Ff defined, assembler versions of some - // functions will be used (only for x86). - - // Debug options: If none of these two are defined - // your project settings are used. -{ $DEFINE IMAGING_DEBUG} // If defined, debug info, range/IO/overflow - // checking, stack frames, assertions, and - // other debugging options will be turned on. -{$DEFINE IMAGING_RELEASE} // If defined, all debug info is off. - - - -(* File format support linking options. - Define formats which you don't want to be registred automatically. - Default: all formats are registered = no symbols defined. - Example: If you want to disable JPEG support just uncomment //{$DEFINE DONT_LINK_JPEG} line -*) - -{$DEFINE DONT_LINK_JPEG} // link support for Jpeg images -{.$DEFINE DONT_LINK_PNG} // link support for PNG images -{.$DEFINE DONT_LINK_TARGA} // link support for Targa images -{.$DEFINE DONT_LINK_BITMAP} // link support for Windows Bitmap images -{$DEFINE DONT_LINK_DDS} // link support for DDS images -{$DEFINE DONT_LINK_GIF} // link support for GIF images -{$DEFINE DONT_LINK_MNG} // link support for MNG images -{$DEFINE DONT_LINK_JNG} // link support for JNG images -{$DEFINE DONT_LINK_PNM} // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM) - -{$DEFINE DONT_LINK_EXTRAS} // link support for file formats defined in - // Extras package. Exactly which formats will be - // registered depends on settings in - // ImagingExtras.pas unit. - -{ Component set used in ImagignComponents.pas unit. You usually don't need - to be concerned with this - proper component library is selected automatically - according to your compiler. } - -{ $DEFINE COMPONENT_SET_VCL} // use Delphi VCL -{$DEFINE COMPONENT_SET_LCL} // use Lazarus LCL (set automatically when compiling with FPC) - -{ - Auto Options - Following options and defines are set automatically and some - are required for Imaging to compile successfully. Do not change - anything here if you don't know what you are doing. -} - -{ Compiler options } - -{$ALIGN ON} // Field alignment: 8 Bytes (in D6+) -{$BOOLEVAL OFF} // Boolean eval: off -{$EXTENDEDSYNTAX ON} // Extended syntax: on -{$LONGSTRINGS ON} // string = AnsiString: on -{$MINENUMSIZE 4} // Min enum size: 4 B -{$TYPEDADDRESS OFF} // Typed pointers: off -{$WRITEABLECONST OFF} // Writeable constants: off - -{$IFNDEF FPC} - {$DEFINE DCC} // if not using FPC then DCC compiler is used (Delphi/Kylix) - // others are not supported -{$ENDIF} - -{$IFDEF DCC} - {$IFDEF LINUX} - {$DEFINE KYLIX} // using Kylix - {$ENDIF} -{$ENDIF} - -{$IFDEF DCC} - {$IFNDEF KYLIX} - {$DEFINE DELPHI} // using Delphi - {$ENDIF} -{$ENDIF} - -{$IF Defined(IMAGING_DEBUG)} - {$ASSERTIONS ON} - {$DEBUGINFO ON} - {$RANGECHECKS ON} - {$IOCHECKS ON} - {$OVERFLOWCHECKS ON} - {$IFDEF DCC} - {$OPTIMIZATION OFF} - {$STACKFRAMES ON} - {$LOCALSYMBOLS ON} - {$DEFINE MEMCHECK} - {$ENDIF} - {$IFDEF FPC} - {$S+} - {$CHECKPOINTER ON} - {$ENDIF} -{$ELSEIF Defined(IMAGING_RELEASE)} - {$ASSERTIONS OFF} - {$DEBUGINFO OFF} - {$RANGECHECKS OFF} - {$IOCHECKS OFF} - {$OVERFLOWCHECKS OFF} - {$IFDEF DCC} - {$OPTIMIZATION ON} - {$STACKFRAMES OFF} - {$LOCALSYMBOLS OFF} - {$ENDIF} - {$IFDEF FPC} - {$S-} - {$ENDIF} -{$IFEND} - - -{ Compiler capabilities } - -// Define if compiler supports inlining of functions and procedures -// Note that FPC inline support crashed in older versions (1.9.8) -{$IF (Defined(FPC) and Defined(CPU86))} - {$DEFINE HAS_INLINE} -{$IFEND} - -// Define if compiler supports operator overloading -// (unfortunately Delphi and FPC operator overloaing is not compatible) -{$IF Defined(FPC)} - {$DEFINE HAS_OPERATOR_OVERLOADING} -{$IFEND} - -{ Imaging options check} - -{$IFNDEF HAS_INLINE} - {$UNDEF USE_INLINE} -{$ENDIF} - -{$IFDEF FPC} - {$IFNDEF CPU86} - {$UNDEF USE_ASM} - {$ENDIF} -{$ENDIF} - -{$IFDEF FPC} - {$DEFINE COMPONENT_SET_LCL} - {$UNDEF COMPONENT_SET_VCL} -{$ENDIF} - -{$IFDEF DELPHI} - {$UNDEF COMPONENT_SET_LCL} - {$DEFINE COMPONENT_SET_VCL} -{$ENDIF} - -{ Platform options } - -{$IFDEF WIN32} - {$DEFINE MSWINDOWS} -{$ENDIF} - -{$IFDEF DPMI} - {$DEFINE MSDOS} -{$ENDIF} - -{$IFDEF LINUX} - {$DEFINE UNIX} -{$ENDIF} - -{ More compiler options } - -{$IFDEF FPC} // Free Pascal options - some options set above (like min enum size) - // are reset to defaults by setting {$MODE} so they are - // redeclared here - {$MODE DELPHI} // compatible with delphi - {$GOTO ON} // alow goto - {$PACKRECORDS 8} // same as ALING 8 for Delphi - {$PACKENUM 4} // Min enum size: 4 B - {$CALLING REGISTER} // default calling convention is register - {$IFDEF CPU86} - {$ASMMODE INTEL} // intel assembler mode - {$ENDIF} -{$ENDIF} - -{$IFDEF HAS_INLINE} - {$INLINE ON} // turns inlining on for compilers that support it -{$ENDIF} - - +{ + User Options + Following defines and options can be changed by user. +} + +{ Source options } + +{$DEFINE USE_INLINE} // Use function inlining for some functions + // works in Free Pascal and Delphi 9+. +{$DEFINE USE_ASM} // If defined, assembler versions of some + // functions will be used (only for x86). + + // Debug options: If none of these two are defined + // your project settings are used. +{.$DEFINE IMAGING_DEBUG} // If defined, debug info, range/IO/overflow + // checking, stack frames, assertions, and + // other debugging options will be turned on. +{$DEFINE IMAGING_RELEASE} // If defined, all debug info is off. + +{$DEFINE OPENGL_NO_EXT_HEADERS} + + + +(* File format support linking options. + Define formats which you don't want to be registered automatically (by adding + Imaging.pas unit to your uses clause). + Default: most formats are registered = no symbols defined. + Example: If you want to disable JPEG support just uncomment //{$DEFINE DONT_LINK_JPEG} line +*) + +{$DEFINE DONT_LINK_JPEG} // link support for Jpeg images +{.$DEFINE DONT_LINK_PNG} // link support for PNG images +{.$DEFINE DONT_LINK_TARGA} // link support for Targa images +{.$DEFINE DONT_LINK_BITMAP} // link support for Windows Bitmap images +{$DEFINE DONT_LINK_DDS} // link support for DDS images +{$DEFINE DONT_LINK_GIF} // link support for GIF images +{$DEFINE DONT_LINK_MNG} // link support for MNG images +{$DEFINE DONT_LINK_JNG} // link support for JNG images +{$DEFINE DONT_LINK_PNM} // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM) +{$DEFINE DONT_LINK_RADHDR} // link support for Radiance HDR/RGBE file format + +{$DEFINE DONT_LINK_EXTRAS} // link support for file formats defined in + // Extensions package. Exactly which formats will be + // registered depends on settings in + // ImagingExtFileFormats.pas unit. + +{.$DEFINE DONT_LINK_FILE_FORMATS} // no auto link support of any file format + +{ + Auto Options + Following options and defines are set automatically and some + are required for Imaging to compile successfully. Do not change + anything here if you don't know what you are doing. +} + +{ Compiler options } + +{$ALIGN ON} // Field alignment: 8 Bytes (in D6+) +{$BOOLEVAL OFF} // Boolean eval: off +{$EXTENDEDSYNTAX ON} // Extended syntax: on +{$LONGSTRINGS ON} // string = AnsiString: on +{$MINENUMSIZE 1} // Min enum size: 1 B +{$TYPEDADDRESS OFF} // Typed pointers: off +{$WRITEABLECONST OFF} // Writeable constants: off + +{$IFNDEF FPC} + {$DEFINE DCC} // if not using FPC then DCC compiler is used (Delphi/BCB) + // others are not supported +{$ENDIF} + +{$IFDEF DCC} + {$DEFINE DELPHI} + {$IF (Defined(DCC) and (CompilerVersion >= 25.0))} + {$LEGACYIFEND ON} + {$IFEND} +{$ENDIF} + +{$IF (Defined(DCC) and (CompilerVersion >= 18.5))} + {$IFDEF RELEASE} + {$UNDEF DEBUG} // If we are using Delphi 2007+ where you can set + // DEBUG/RELEASE mode in project options and RELEASE + // is currently set we undef DEBUG mode + {$ENDIF} +{$IFEND} + +{$IF Defined(IMAGING_DEBUG)} + {$ASSERTIONS ON} + {$DEBUGINFO ON} + {$RANGECHECKS ON} + {$IOCHECKS ON} + {$OVERFLOWCHECKS ON} + {$IFDEF DCC} + {$OPTIMIZATION OFF} + {$STACKFRAMES ON} + {$LOCALSYMBOLS ON} + {$DEFINE MEMCHECK} + {$ENDIF} + {$IFDEF FPC} + {$S+} + {$CHECKPOINTER ON} + {$ENDIF} +{$ELSEIF Defined(IMAGING_RELEASE)} + {$ASSERTIONS OFF} + {$DEBUGINFO OFF} + {$RANGECHECKS OFF} + {$IOCHECKS OFF} + {$OVERFLOWCHECKS OFF} + {$IFDEF DCC} + {$OPTIMIZATION ON} + {$STACKFRAMES OFF} + {$LOCALSYMBOLS OFF} + {$ENDIF} + {$IFDEF FPC} + {$S-} + {$ENDIF} +{$IFEND} + +{$IF Defined(CPU86) and not Defined(CPUX86)} + {$DEFINE CPUX86} // Compatibility with Delphi +{$IFEND} + +{$IF Defined(CPUX86_64) and not Defined(CPUX64)} + {$DEFINE CPUX64} // Compatibility with Delphi +{$IFEND} + +{$IF Defined(DARWIN) and not Defined(MACOS)} + {$DEFINE MACOS} // Compatibility with Delphi +{$IFEND} +{$IF Defined(MACOS)} + {$DEFINE MACOSX} +{$IFEND} + +{$IF Defined(DCC) and (CompilerVersion < 23)} // < XE2 + {$DEFINE CPUX86} // Compatibility with older Delphi +{$IFEND} + +{$IF Defined(WIN32) or Defined(WIN64)} + {$DEFINE MSWINDOWS} // Compatibility with Delphi +{$IFEND} + +{$IF Defined(UNIX) and not Defined(POSIX)} + {$DEFINE POSIX} // Compatibility with Delphi +{$IFEND} + +{ Compiler capabilities } + +// Define if compiler supports inlining of functions and procedures +{$IF (Defined(DCC) and (CompilerVersion >= 17)) or Defined(FPC)} + {$DEFINE HAS_INLINE} +{$IFEND} + +// Define if compiler supports advanced records with methods +{$IF (Defined(DCC) and (CompilerVersion >= 18)) or + (Defined(FPC) and (FPC_FULLVERSION >= 20600))} + {$DEFINE HAS_ADVANCED_RECORDS} +{$IFEND} + +// Define if compiler supports operator overloading +// (unfortunately Delphi and FPC operator overloading is not compatible). +// FPC supports Delphi compatible operator overloads since 2.6.0 +{$IF (Defined(DCC) and (CompilerVersion >= 18)) or + (Defined(FPC) and (FPC_FULLVERSION >= 20600))} + {$DEFINE HAS_OPERATOR_OVERLOADING} +{$IFEND} + +// Anonymous methods +{$IF Defined(DCC) and (CompilerVersion >= 20) } + {$DEFINE HAS_ANON_METHODS} +{$IFEND} + +// Generic types (Delphi and FPC implementations incompatible). +// Update: FPC supports Delphi compatible generics since 2.6.0 +{$IF (Defined(DCC) and (CompilerVersion >= 20)) or + (Defined(FPC) and (FPC_FULLVERSION >= 20600))} + {$DEFINE HAS_GENERICS} +{$IFEND} + +{ Compiler pecularities } + +// Delphi 64bit POSIX targets +{$IF Defined(DCC) and (SizeOf(Integer) <> SizeOf(LongInt))} + {$DEFINE LONGINT_IS_NOT_INTEGER} +{$IFEND} + +// They used to force IFEND, now they warn about it +{$IF Defined(DCC) and (CompilerVersion >= 33)} + {$LEGACYIFEND ON} +{$IFEND} + +{ Imaging options check} + +{$IFNDEF HAS_INLINE} + {$UNDEF USE_INLINE} +{$ENDIF} + +{$IF not Defined(CPUX86)} + {$UNDEF USE_ASM} +{$IFEND} + +{$IFDEF FPC} + {$DEFINE COMPONENT_SET_LCL} + {$UNDEF COMPONENT_SET_VCL} +{$ENDIF} + +{$IFDEF DELPHI} + {$UNDEF COMPONENT_SET_LCL} + {$DEFINE COMPONENT_SET_VCL} +{$ENDIF} + +{ More compiler options } + +{$IFDEF FPC} // Free Pascal options - some options set above (like min enum size) + // are reset to defaults by setting {$MODE} so they are + // redeclared here + {$MODE DELPHI} // compatible with delphi + {$GOTO ON} // alow goto + {$PACKRECORDS 8} // same as ALING 8 for Delphi + {$PACKENUM 4} // Min enum size: 4 B + {$IFDEF CPU86} + {$ASMMODE INTEL} // intel assembler mode + {$ENDIF} +{$ENDIF} + +{$IFDEF HAS_INLINE} + {$INLINE ON} // turns inlining on for compilers that support it +{$ENDIF} + + diff --git a/Imaging/ImagingPortableMaps.pas b/Imaging/ImagingPortableMaps.pas index 570261c..001b4a5 100644 --- a/Imaging/ImagingPortableMaps.pas +++ b/Imaging/ImagingPortableMaps.pas @@ -1,1020 +1,961 @@ -{ - $Id: ImagingPortableMaps.pas 163 2009-07-28 21:44:10Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains loader/saver for Portable Maps file format family (or PNM). - That includes PBM, PGM, PPM, PAM, and PFM formats.} -unit ImagingPortableMaps; - -{$I ImagingOptions.inc} - -interface - -uses - SysUtils, ImagingTypes, Imaging, ImagingFormats, ImagingUtility; - -type - { Types of pixels of PNM images.} - TTupleType = (ttInvalid, ttBlackAndWhite, ttGrayScale, ttRGB, ttBlackAndWhiteAlpha, - ttGrayScaleAlpha, ttRGBAlpha, ttGrayScaleFP, ttRGBFP); - - { Record with info about PNM image used in both loading and saving functions.} - TPortableMapInfo = record - Width: LongInt; - Height: LongInt; - FormatId: AnsiChar; - MaxVal: LongInt; - BitCount: LongInt; - Depth: LongInt; - TupleType: TTupleType; - Binary: Boolean; - HasPAMHeader: Boolean; - IsBigEndian: Boolean; - end; - - { Base class for Portable Map file formats (or Portable AnyMaps or PNM). - There are several types of PNM file formats that share common - (simple) structure. This class can actually load all supported PNM formats. - Saving is also done by this class but descendants (each for different PNM - format) control it.} - TPortableMapFileFormat = class(TImageFileFormat) - protected - FIdNumbers: TChar2; - FSaveBinary: LongBool; - function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean): Boolean; override; - function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt; var MapInfo: TPortableMapInfo): Boolean; - public - constructor Create; override; - function TestFormat(Handle: TImagingHandle): Boolean; override; - published - { If set to True images will be saved in binary format. If it is False - they will be saved in text format (which could result in 5-10x bigger file). - Default is value True. Note that PAM and PFM files are always saved in binary.} - property SaveBinary: LongBool read FSaveBinary write FSaveBinary; - end; - - { Portable Bit Map is used to store monochrome 1bit images. Raster data - can be saved as text or binary data. Either way value of 0 represents white - and 1 is black. As Imaging does not have support for 1bit data formats - PBM images can be loaded but not saved. Loaded images are returned in - ifGray8 format (witch pixel values scaled from 1bit to 8bit).} - TPBMFileFormat = class(TPortableMapFileFormat) - public - constructor Create; override; - end; - - { Portable Gray Map is used to store grayscale 8bit or 16bit images. - Raster data can be saved as text or binary data.} - TPGMFileFormat = class(TPortableMapFileFormat) - protected - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); override; - public - constructor Create; override; - end; - - { Portable Pixel Map is used to store RGB images with 8bit or 16bit channels. - Raster data can be saved as text or binary data.} - TPPMFileFormat = class(TPortableMapFileFormat) - protected - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); override; - public - constructor Create; override; - end; - - { Portable Arbitrary Map is format that can store image data formats - of PBM, PGM, and PPM formats with optional alpha channel. Raster data - can be stored only in binary format. All data formats supported - by this format are ifGray8, ifGray16, ifA8Gray8, ifA16Gray16, - ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.} - TPAMFileFormat = class(TPortableMapFileFormat) - protected - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); override; - public - constructor Create; override; - end; - - { Portable Float Map is unofficial extension of PNM format family which - can store images with floating point pixels. Raster data is saved in - binary format as array of IEEE 32 bit floating point numbers. One channel - or RGB images are supported by PFM format (so no alpha).} - TPFMFileFormat = class(TPortableMapFileFormat) - protected - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); override; - public - constructor Create; override; - end; - -implementation - -const - PortableMapDefaultBinary = True; - - SPBMFormatName = 'Portable Bit Map'; - SPBMMasks = '*.pbm'; - SPGMFormatName = 'Portable Gray Map'; - SPGMMasks = '*.pgm'; - PGMSupportedFormats = [ifGray8, ifGray16]; - SPPMFormatName = 'Portable Pixel Map'; - SPPMMasks = '*.ppm'; - PPMSupportedFormats = [ifR8G8B8, ifR16G16B16]; - SPAMFormatName = 'Portable Arbitrary Map'; - SPAMMasks = '*.pam'; - PAMSupportedFormats = [ifGray8, ifGray16, ifA8Gray8, ifA16Gray16, - ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16]; - SPFMFormatName = 'Portable Float Map'; - SPFMMasks = '*.pfm'; - PFMSupportedFormats = [ifR32F, ifA32B32G32R32F]; - -const - { TAB, CR, LF, and Space are used as seperators in Portable map headers and data.} - WhiteSpaces = [#9, #10, #13, #32]; - SPAMWidth = 'WIDTH'; - SPAMHeight = 'HEIGHT'; - SPAMDepth = 'DEPTH'; - SPAMMaxVal = 'MAXVAL'; - SPAMTupleType = 'TUPLTYPE'; - SPAMEndHdr = 'ENDHDR'; - - { Size of buffer used to speed up text PNM loading/saving.} - LineBufferCapacity = 16 * 1024; - - TupleTypeNames: array[TTupleType] of string = ( - 'INVALID', 'BLACKANDWHITE', 'GRAYSCALE', 'RGB', - 'BLACKANDWHITE_ALPHA', 'GRAYSCALE_ALPHA', 'RGB_ALPHA', 'GRAYSCALEFP', - 'RGBFP'); - -{ TPortableMapFileFormat } - -constructor TPortableMapFileFormat.Create; -begin - inherited Create; - FCanLoad := True; - FCanSave := True; - FIsMultiImageFormat := False; - FSaveBinary := PortableMapDefaultBinary; -end; - -function TPortableMapFileFormat.LoadData(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - I, ScanLineSize, MonoSize: LongInt; - Dest: PByte; - MonoData: Pointer; - Info: TImageFormatInfo; - PixelFP: TColorFPRec; - LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar; - LineEnd, LinePos: LongInt; - MapInfo: TPortableMapInfo; - LineBreak: string; - - procedure CheckBuffer; - begin - if (LineEnd = 0) or (LinePos = LineEnd) then - begin - // Reload buffer if its is empty or its end was reached - LineEnd := GetIO.Read(Handle, @LineBuffer[0], LineBufferCapacity); - LinePos := 0; - end; - end; - - procedure FixInputPos; - begin - // Sets input's position to its real pos as it would be without buffering - if LineEnd > 0 then - begin - GetIO.Seek(Handle, -LineEnd + LinePos, smFromCurrent); - LineEnd := 0; - end; - end; - - function ReadString: string; - var - S: AnsiString; - C: AnsiChar; - begin - // First skip all whitespace chars - SetLength(S, 1); - repeat - CheckBuffer; - S[1] := LineBuffer[LinePos]; - Inc(LinePos); - if S[1] = '#' then - repeat - // Comment detected, skip everything until next line is reached - CheckBuffer; - S[1] := LineBuffer[LinePos]; - Inc(LinePos); - until S[1] = #10; - until not(S[1] in WhiteSpaces); - // Now we have reached some chars other than white space, read them until - // there is whitespace again - repeat - SetLength(S, Length(S) + 1); - CheckBuffer; - S[Length(S)] := LineBuffer[LinePos]; - Inc(LinePos); - // Repeat until current char is whitespace or end of file is reached - // (Line buffer has 0 bytes which happens only on EOF) - until (S[Length(S)] in WhiteSpaces) or (LineEnd = 0); - // Get rid of last char - whitespace or null - SetLength(S, Length(S) - 1); - // Move position to the beginning of next string (skip white space - needed - // to make the loader stop at the right input position) - repeat - CheckBuffer; - C := LineBuffer[LinePos]; - Inc(LinePos); - until not (C in WhiteSpaces) or (LineEnd = 0); - // Dec pos, current is the begining of the the string - Dec(LinePos); - - Result := string(S); - end; - - function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} - begin - Result := StrToInt(ReadString); - end; - - procedure FindLineBreak; - var - C: AnsiChar; - begin - LineBreak := #10; - repeat - CheckBuffer; - C := LineBuffer[LinePos]; - Inc(LinePos); - - if C = #13 then - LineBreak := #13#10; - - until C = #10; - end; - - function ParseHeader: Boolean; - var - Id: TChar2; - I: TTupleType; - TupleTypeName: string; - Scale: Single; - OldSeparator: Char; - begin - Result := False; - with GetIO do - begin - FillChar(MapInfo, SizeOf(MapInfo), 0); - Read(Handle, @Id, SizeOf(Id)); - FindLineBreak; - - if Id[1] in ['1'..'6'] then - begin - // Read header for PBM, PGM, and PPM files - MapInfo.Width := ReadIntValue; - MapInfo.Height := ReadIntValue; - - if Id[1] in ['1', '4'] then - begin - MapInfo.MaxVal := 1; - MapInfo.BitCount := 1 - end - else - begin - // Read channel max value, <=255 for 8bit images, >255 for 16bit images - // but some programs think its max colors so put <=256 here - MapInfo.MaxVal := ReadIntValue; - MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16); - end; - - MapInfo.Depth := 1; - case Id[1] of - '1', '4': MapInfo.TupleType := ttBlackAndWhite; - '2', '5': MapInfo.TupleType := ttGrayScale; - '3', '6': - begin - MapInfo.TupleType := ttRGB; - MapInfo.Depth := 3; - end; - end; - end - else if Id[1] = '7' then - begin - // Read values from PAM header - // WIDTH - if (ReadString <> SPAMWidth) then Exit; - MapInfo.Width := ReadIntValue; - // HEIGHT - if (ReadString <> SPAMheight) then Exit; - MapInfo.Height := ReadIntValue; - // DEPTH - if (ReadString <> SPAMDepth) then Exit; - MapInfo.Depth := ReadIntValue; - // MAXVAL - if (ReadString <> SPAMMaxVal) then Exit; - MapInfo.MaxVal := ReadIntValue; - MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16); - // TUPLETYPE - if (ReadString <> SPAMTupleType) then Exit; - TupleTypeName := ReadString; - for I := Low(TTupleType) to High(TTupleType) do - if SameText(TupleTypeName, TupleTypeNames[I]) then - begin - MapInfo.TupleType := I; - Break; - end; - // ENDHDR - if (ReadString <> SPAMEndHdr) then Exit; - end - else if Id[1] in ['F', 'f'] then - begin - // Read header of PFM file - MapInfo.Width := ReadIntValue; - MapInfo.Height := ReadIntValue; - OldSeparator := DecimalSeparator; - DecimalSeparator := '.'; - Scale := StrToFloatDef(ReadString, 0); - DecimalSeparator := OldSeparator; - MapInfo.IsBigEndian := Scale > 0.0; - if Id[1] = 'F' then - MapInfo.TupleType := ttRGBFP - else - MapInfo.TupleType := ttGrayScaleFP; - MapInfo.Depth := Iff(MapInfo.TupleType = ttRGBFP, 3, 1); - MapInfo.BitCount := Iff(MapInfo.TupleType = ttRGBFP, 96, 32); - end; - - FixInputPos; - MapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']); - - if MapInfo.Binary and not (Id[1] in ['F', 'f']) then - begin - // Mimic the behaviour of Photoshop and other editors/viewers: - // If linenreaks in file are DOS CR/LF 16bit binary values are - // little endian, Unix LF only linebreak indicates big endian. - MapInfo.IsBigEndian := LineBreak = #10; - end; - - // Check if values found in header are valid - Result := (MapInfo.Width > 0) and (MapInfo.Height > 0) and - (MapInfo.BitCount in [1, 8, 16, 32, 96]) and (MapInfo.TupleType <> ttInvalid); - // Now check if image has proper number of channels (PAM) - if Result then - case MapInfo.TupleType of - ttBlackAndWhite, ttGrayScale: Result := MapInfo.Depth = 1; - ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := MapInfo.Depth = 2; - ttRGB: Result := MapInfo.Depth = 3; - ttRGBAlpha: Result := MapInfo.Depth = 4; - end; - end; - end; - -begin - Result := False; - LineEnd := 0; - LinePos := 0; - SetLength(Images, 1); - with GetIO, Images[0] do - begin - Format := ifUnknown; - // Try to parse file header - if not ParseHeader then Exit; - // Select appropriate data format based on values read from file header - case MapInfo.TupleType of - ttBlackAndWhite: Format := ifGray8; - ttBlackAndWhiteAlpha: Format := ifA8Gray8; - ttGrayScale: Format := IffFormat(MapInfo.BitCount = 8, ifGray8, ifGray16); - ttGrayScaleAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16); - ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16); - ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16); - ttGrayScaleFP: Format := ifR32F; - ttRGBFP: Format := ifA32B32G32R32F; - end; - // Exit if no matching data format was found - if Format = ifUnknown then Exit; - - NewImage(MapInfo.Width, MapInfo.Height, Format, Images[0]); - Info := GetFormatInfo(Format); - - // Now read pixels from file to dest image - if not MapInfo.Binary then - begin - Dest := Bits; - for I := 0 to Width * Height - 1 do - begin - case Format of - ifGray8: - begin - Dest^ := ReadIntValue; - if MapInfo.BitCount = 1 then - // If source is 1bit mono image (where 0=white, 1=black) - // we must scale it to 8bits - Dest^ := 255 - Dest^ * 255; - end; - ifGray16: PWord(Dest)^ := ReadIntValue; - ifR8G8B8: - with PColor24Rec(Dest)^ do - begin - R := ReadIntValue; - G := ReadIntValue; - B := ReadIntValue; - end; - ifR16G16B16: - with PColor48Rec(Dest)^ do - begin - R := ReadIntValue; - G := ReadIntValue; - B := ReadIntValue; - end; - end; - Inc(Dest, Info.BytesPerPixel); - end; - end - else - begin - if MapInfo.BitCount > 1 then - begin - if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then - begin - // Just copy bytes from binary Portable Maps (non 1bit, non FP) - Read(Handle, Bits, Size); - end - else - begin - Dest := Bits; - // FP images are in BGR order and endian swap maybe needed. - // Some programs store scanlines in bottom-up order but - // I will stick with Photoshops behaviour here - for I := 0 to Width * Height - 1 do - begin - Read(Handle, @PixelFP, MapInfo.BitCount div 8); - if MapInfo.TupleType = ttRGBFP then - with PColorFPRec(Dest)^ do - begin - A := 1.0; - R := PixelFP.R; - G := PixelFP.G; - B := PixelFP.B; - if MapInfo.IsBigEndian then - SwapEndianLongWord(PLongWord(Dest), 3); - end - else - begin - PSingle(Dest)^ := PixelFP.B; - if MapInfo.IsBigEndian then - SwapEndianLongWord(PLongWord(Dest), 1); - end; - Inc(Dest, Info.BytesPerPixel); - end; - end; - - if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then - begin - // Black and white PAM files must be scaled to 8bits. Note that - // in PAM files 1=white, 0=black (reverse of PBM) - for I := 0 to Width * Height * Iff(MapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do - PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255; - end - else if MapInfo.TupleType in [ttRGB, ttRGBAlpha] then - begin - // Swap channels of RGB/ARGB images. Binary RGB image files use BGR order. - SwapChannels(Images[0], ChannelBlue, ChannelRed); - end; - - // Swap byte order if needed - if (MapInfo.BitCount = 16) and MapInfo.IsBigEndian then - SwapEndianWord(Bits, Width * Height * Info.BytesPerPixel div SizeOf(Word)); - end - else - begin - // Handle binary PBM files (ttBlackAndWhite 1bit) - ScanLineSize := (Width + 7) div 8; - // Get total binary data size, read it from file to temp - // buffer and convert the data to Gray8 - MonoSize := ScanLineSize * Height; - GetMem(MonoData, MonoSize); - try - Read(Handle, MonoData, MonoSize); - Convert1To8(MonoData, Bits, Width, Height, ScanLineSize); - // 1bit mono images must be scaled to 8bit (where 0=white, 1=black) - for I := 0 to Width * Height - 1 do - PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255; - finally - FreeMem(MonoData); - end; - end; - end; - - FixInputPos; - - if (MapInfo.MaxVal <> Pow2Int(MapInfo.BitCount) - 1) and - (MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then - begin - Dest := Bits; - // Scale color values according to MaxVal we got from header - // if necessary. - for I := 0 to Width * Height * Info.BytesPerPixel div (MapInfo.BitCount shr 3) - 1 do - begin - if MapInfo.BitCount = 8 then - Dest^ := Dest^ * 255 div MapInfo.MaxVal - else - PWord(Dest)^ := PWord(Dest)^ * 65535 div MapInfo.MaxVal; - Inc(Dest, MapInfo.BitCount shr 3); - end; - end; - - Result := True; - end; -end; - -function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: Integer; var MapInfo: TPortableMapInfo): Boolean; -const - // Use Unix linebreak, for many viewers/editors it means that - // 16bit samples are stored as big endian - so we need to swap byte order - // before saving - LineDelimiter = #10; - PixelDelimiter = #32; -var - ImageToSave: TImageData; - MustBeFreed: Boolean; - Info: TImageFormatInfo; - I, LineLength: LongInt; - Src: PByte; - Pixel32: TColor32Rec; - Pixel64: TColor64Rec; - W: Word; - - procedure WriteString(S: string; Delimiter: Char = LineDelimiter); - begin - SetLength(S, Length(S) + 1); - S[Length(S)] := Delimiter; - {$IF Defined(DCC) and Defined(UNICODE)} - GetIO.Write(Handle, @AnsiString(S)[1], Length(S)); - {$ELSE} - GetIO.Write(Handle, @S[1], Length(S)); - {$IFEND} - Inc(LineLength, Length(S)); - end; - - procedure WriteHeader; - var - OldSeparator: Char; - begin - WriteString('P' + MapInfo.FormatId); - if not MapInfo.HasPAMHeader then - begin - // Write header of PGM, PPM, and PFM files - WriteString(IntToStr(ImageToSave.Width)); - WriteString(IntToStr(ImageToSave.Height)); - case MapInfo.TupleType of - ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1)); - ttGrayScaleFP, ttRGBFP: - begin - OldSeparator := DecimalSeparator; - DecimalSeparator := '.'; - // Negative value indicates that raster data is saved in little endian - WriteString(FloatToStr(-1.0)); - DecimalSeparator := OldSeparator; - end; - end; - end - else - begin - // Write PAM file header - WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width])); - WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height])); - WriteString(Format('%s %d', [SPAMDepth, MapInfo.Depth])); - WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(MapInfo.BitCount) - 1])); - WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[MapInfo.TupleType]])); - WriteString(SPAMEndHdr); - end; - end; - -begin - Result := False; - if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then - with GetIO, ImageToSave do - try - Info := GetFormatInfo(Format); - // Fill values of MapInfo record that were not filled by - // descendants in their SaveData methods - MapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8; - MapInfo.Depth := Info.ChannelCount; - if MapInfo.TupleType = ttInvalid then - begin - if Info.HasGrayChannel then - begin - if Info.HasAlphaChannel then - MapInfo.TupleType := ttGrayScaleAlpha - else - MapInfo.TupleType := ttGrayScale; - end - else - begin - if Info.HasAlphaChannel then - MapInfo.TupleType := ttRGBAlpha - else - MapInfo.TupleType := ttRGB; - end; - end; - // Write file header - WriteHeader; - - if not MapInfo.Binary then - begin - Src := Bits; - LineLength := 0; - // For each pixel find its text representation and write it to file - for I := 0 to Width * Height - 1 do - begin - case Format of - ifGray8: WriteString(IntToStr(Src^), PixelDelimiter); - ifGray16: WriteString(IntToStr(PWord(Src)^), PixelDelimiter); - ifR8G8B8: - with PColor24Rec(Src)^ do - WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter); - ifR16G16B16: - with PColor48Rec(Src)^ do - WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter); - end; - // Lines in text PNM images should have length <70 - if LineLength > 65 then - begin - LineLength := 0; - WriteString('', LineDelimiter); - end; - Inc(Src, Info.BytesPerPixel); - end; - end - else - begin - // Write binary images - if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then - begin - // Save integer binary images - if MapInfo.BitCount = 8 then - begin - if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then - begin - // 8bit grayscale images can be written in one Write call - Write(Handle, Bits, Size); - end - else - begin - // 8bit RGB/ARGB images: read and blue must be swapped and - // 3 or 4 bytes must be written - Src := Bits; - for I := 0 to Width * Height - 1 do - with PColor32Rec(Src)^ do - begin - if MapInfo.TupleType = ttRGBAlpha then - Pixel32.A := A; - Pixel32.R := B; - Pixel32.G := G; - Pixel32.B := R; - Write(Handle, @Pixel32, Info.BytesPerPixel); - Inc(Src, Info.BytesPerPixel); - end; - end; - end - else - begin - // Images with 16bit channels: make sure that channel values are saved in big endian - Src := Bits; - if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then - begin - // 16bit grayscale image - for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do - begin - W := SwapEndianWord(PWord(Src)^); - Write(Handle, @W, SizeOf(Word)); - Inc(Src, SizeOf(Word)); - end; - end - else - begin - // RGB images with 16bit channels: swap RB and endian too - for I := 0 to Width * Height - 1 do - with PColor64Rec(Src)^ do - begin - if MapInfo.TupleType = ttRGBAlpha then - Pixel64.A := SwapEndianWord(A); - Pixel64.R := SwapEndianWord(B); - Pixel64.G := SwapEndianWord(G); - Pixel64.B := SwapEndianWord(R); - Write(Handle, @Pixel64, Info.BytesPerPixel); - Inc(Src, Info.BytesPerPixel); - end; - end; - end; - end - else - begin - // Floating point images (no need to swap endian here - little - // endian is specified in file header) - if MapInfo.TupleType = ttGrayScaleFP then - begin - // Grayscale images can be written in one Write call - Write(Handle, Bits, Size); - end - else - begin - // Expected data format of PFM RGB file is B32G32R32F which is not - // supported by Imaging. We must write pixels one by one and - // write only RGB part of A32B32G32B32 image. - Src := Bits; - for I := 0 to Width * Height - 1 do - begin - Write(Handle, Src, SizeOf(Single) * 3); - Inc(Src, Info.BytesPerPixel); - end; - end; - end; - end; - Result := True; - finally - if MustBeFreed then - FreeImage(ImageToSave); - end; -end; - -function TPortableMapFileFormat.TestFormat(Handle: TImagingHandle): Boolean; -var - Id: TChar4; - ReadCount: LongInt; -begin - Result := False; - if Handle <> nil then - with GetIO do - begin - ReadCount := Read(Handle, @Id, SizeOf(Id)); - Seek(Handle, -ReadCount, smFromCurrent); - Result := (Id[0] = 'P') and (Id[1] in [FIdNumbers[0], FIdNumbers[1]]) and - (Id[2] in WhiteSpaces); - end; -end; - -{ TPBMFileFormat } - -constructor TPBMFileFormat.Create; -begin - inherited Create; - FName := SPBMFormatName; - FCanSave := False; - AddMasks(SPBMMasks); - FIdNumbers := '14'; -end; - -{ TPGMFileFormat } - -constructor TPGMFileFormat.Create; -begin - inherited Create; - FName := SPGMFormatName; - FSupportedFormats := PGMSupportedFormats; - AddMasks(SPGMMasks); - RegisterOption(ImagingPGMSaveBinary, @FSaveBinary); - FIdNumbers := '25'; -end; - -function TPGMFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: Integer): Boolean; -var - MapInfo: TPortableMapInfo; -begin - FillChar(MapInfo, SizeOf(MapInfo), 0); - if FSaveBinary then - MapInfo.FormatId := FIdNumbers[1] - else - MapInfo.FormatId := FIdNumbers[0]; - MapInfo.Binary := FSaveBinary; - Result := SaveDataInternal(Handle, Images, Index, MapInfo); -end; - -procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -var - ConvFormat: TImageFormat; -begin - if Info.IsFloatingPoint then - // All FP images go to 16bit - ConvFormat := ifGray16 - else if Info.HasGrayChannel then - // Grayscale will be 8 or 16 bit - depends on input's bitcount - ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1, - ifGray16, ifGray8) - else if Info.BytesPerPixel > 4 then - // Large bitcounts -> 16bit - ConvFormat := ifGray16 - else - // Rest of the formats -> 8bit - ConvFormat := ifGray8; - - ConvertImage(Image, ConvFormat); -end; - -{ TPPMFileFormat } - -constructor TPPMFileFormat.Create; -begin - inherited Create; - FName := SPPMFormatName; - FSupportedFormats := PPMSupportedFormats; - AddMasks(SPPMMasks); - RegisterOption(ImagingPPMSaveBinary, @FSaveBinary); - FIdNumbers := '36'; -end; - -function TPPMFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: Integer): Boolean; -var - MapInfo: TPortableMapInfo; -begin - FillChar(MapInfo, SizeOf(MapInfo), 0); - if FSaveBinary then - MapInfo.FormatId := FIdNumbers[1] - else - MapInfo.FormatId := FIdNumbers[0]; - MapInfo.Binary := FSaveBinary; - Result := SaveDataInternal(Handle, Images, Index, MapInfo); -end; - -procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -var - ConvFormat: TImageFormat; -begin - if Info.IsFloatingPoint then - // All FP images go to 48bit RGB - ConvFormat := ifR16G16B16 - else if Info.HasGrayChannel then - // Grayscale will be 24 or 48 bit RGB - depends on input's bitcount - ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1, - ifR16G16B16, ifR8G8B8) - else if Info.BytesPerPixel > 4 then - // Large bitcounts -> 48bit RGB - ConvFormat := ifR16G16B16 - else - // Rest of the formats -> 24bit RGB - ConvFormat := ifR8G8B8; - - ConvertImage(Image, ConvFormat); -end; - -{ TPAMFileFormat } - -constructor TPAMFileFormat.Create; -begin - inherited Create; - FName := SPAMFormatName; - FSupportedFormats := PAMSupportedFormats; - AddMasks(SPAMMasks); - FIdNumbers := '77'; -end; - -function TPAMFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: Integer): Boolean; -var - MapInfo: TPortableMapInfo; -begin - FillChar(MapInfo, SizeOf(MapInfo), 0); - MapInfo.FormatId := FIdNumbers[0]; - MapInfo.Binary := True; - MapInfo.HasPAMHeader := True; - Result := SaveDataInternal(Handle, Images, Index, MapInfo); -end; - -procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -var - ConvFormat: TImageFormat; -begin - if Info.IsFloatingPoint then - ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16) - else if Info.HasGrayChannel then - ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray16) - else - begin - if Info.BytesPerPixel <= 4 then - ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8) - else - ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16); - end; - ConvertImage(Image, ConvFormat); -end; - -{ TPFMFileFormat } - -constructor TPFMFileFormat.Create; -begin - inherited Create; - FName := SPFMFormatName; - AddMasks(SPFMMasks); - FIdNumbers := 'Ff'; - FSupportedFormats := PFMSupportedFormats; -end; - -function TPFMFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: Integer): Boolean; -var - Info: TImageFormatInfo; - MapInfo: TPortableMapInfo; -begin - FillChar(MapInfo, SizeOf(MapInfo), 0); - Info := GetFormatInfo(Images[Index].Format); - - if (Info.ChannelCount > 1) or Info.IsIndexed then - MapInfo.TupleType := ttRGBFP - else - MapInfo.TupleType := ttGrayScaleFP; - - if MapInfo.TupleType = ttGrayScaleFP then - MapInfo.FormatId := FIdNumbers[1] - else - MapInfo.FormatId := FIdNumbers[0]; - - MapInfo.Binary := True; - Result := SaveDataInternal(Handle, Images, Index, MapInfo); -end; - -procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -begin - if (Info.ChannelCount > 1) or Info.IsIndexed then - ConvertImage(Image, ifA32B32G32R32F) - else - ConvertImage(Image, ifR32F); -end; - -initialization - RegisterImageFileFormat(TPBMFileFormat); - RegisterImageFileFormat(TPGMFileFormat); - RegisterImageFileFormat(TPPMFileFormat); - RegisterImageFileFormat(TPAMFileFormat); - RegisterImageFileFormat(TPFMFileFormat); - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.26.3 Changes/Bug Fixes ----------------------------------- - - Fixed D2009 Unicode related bug in PNM saving. - - -- 0.24.3 Changes/Bug Fixes ----------------------------------- - - Improved compatibility of 16bit/component image loading. - - Changes for better thread safety. - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Made modifications to ASCII PNM loading to be more "stream-safe". - - Fixed bug: indexed images saved as grayscale in PFM. - - Changed converting to supported formats little bit. - - Added scaling of channel values (non-FP and non-mono images) according - to MaxVal. - - Added buffering to loading of PNM files. More than 10x faster now - for text files. - - Added saving support to PGM, PPM, PAM, and PFM format. - - Added PFM file format. - - Initial version created. -} - -end. +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains loader/saver for Portable Maps file format family (or PNM). + That includes PBM, PGM, PPM, PAM, and PFM formats.} +unit ImagingPortableMaps; + +{$I ImagingOptions.inc} + +interface + +uses + SysUtils, ImagingTypes, Imaging, ImagingFormats, ImagingUtility; + +type + { Types of pixels of PNM images.} + TTupleType = (ttInvalid, ttBlackAndWhite, ttGrayScale, ttRGB, ttBlackAndWhiteAlpha, + ttGrayScaleAlpha, ttRGBAlpha, ttGrayScaleFP, ttRGBFP); + + { Record with info about PNM image used in both loading and saving functions.} + TPortableMapInfo = record + Width: LongInt; + Height: LongInt; + FormatId: AnsiChar; + MaxVal: LongInt; + BitCount: LongInt; + Depth: LongInt; + TupleType: TTupleType; + Binary: Boolean; + HasPAMHeader: Boolean; + IsBigEndian: Boolean; + end; + + { Base class for Portable Map file formats (or Portable AnyMaps or PNM). + There are several types of PNM file formats that share common + (simple) structure. This class can actually load all supported PNM formats. + Saving is also done by this class but descendants (each for different PNM + format) control it.} + TPortableMapFileFormat = class(TImageFileFormat) + protected + FIdNumbers: TChar2; + FSaveBinary: LongBool; + FUSFormat: TFormatSettings; + procedure Define; override; + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean): Boolean; override; + function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt; var MapInfo: TPortableMapInfo): Boolean; + public + function TestFormat(Handle: TImagingHandle): Boolean; override; + published + { If set to True images will be saved in binary format. If it is False + they will be saved in text format (which could result in 5-10x bigger file). + Default is value True. Note that PAM and PFM files are always saved in binary.} + property SaveBinary: LongBool read FSaveBinary write FSaveBinary; + end; + + { Portable Bit Map is used to store monochrome 1bit images. Raster data + can be saved as text or binary data. Either way value of 0 represents white + and 1 is black. As Imaging does not have support for 1bit data formats + PBM images can be loaded but not saved. Loaded images are returned in + ifGray8 format (witch pixel values scaled from 1bit to 8bit).} + TPBMFileFormat = class(TPortableMapFileFormat) + protected + procedure Define; override; + end; + + { Portable Gray Map is used to store grayscale 8bit or 16bit images. + Raster data can be saved as text or binary data.} + TPGMFileFormat = class(TPortableMapFileFormat) + protected + procedure Define; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + end; + + { Portable Pixel Map is used to store RGB images with 8bit or 16bit channels. + Raster data can be saved as text or binary data.} + TPPMFileFormat = class(TPortableMapFileFormat) + protected + procedure Define; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + end; + + { Portable Arbitrary Map is format that can store image data formats + of PBM, PGM, and PPM formats with optional alpha channel. Raster data + can be stored only in binary format. All data formats supported + by this format are ifGray8, ifGray16, ifA8Gray8, ifA16Gray16, + ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.} + TPAMFileFormat = class(TPortableMapFileFormat) + protected + procedure Define; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + end; + + { Portable Float Map is unofficial extension of PNM format family which + can store images with floating point pixels. Raster data is saved in + binary format as array of IEEE 32 bit floating point numbers. One channel + or RGB images are supported by PFM format (so no alpha).} + TPFMFileFormat = class(TPortableMapFileFormat) + protected + procedure Define; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + end; + +implementation + +const + PortableMapDefaultBinary = True; + + SPBMFormatName = 'Portable Bit Map'; + SPBMMasks = '*.pbm'; + SPGMFormatName = 'Portable Gray Map'; + SPGMMasks = '*.pgm'; + PGMSupportedFormats = [ifGray8, ifGray16]; + SPPMFormatName = 'Portable Pixel Map'; + SPPMMasks = '*.ppm'; + PPMSupportedFormats = [ifR8G8B8, ifR16G16B16]; + SPAMFormatName = 'Portable Arbitrary Map'; + SPAMMasks = '*.pam'; + PAMSupportedFormats = [ifGray8, ifGray16, ifA8Gray8, ifA16Gray16, + ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16]; + SPFMFormatName = 'Portable Float Map'; + SPFMMasks = '*.pfm'; + PFMSupportedFormats = [ifR32F, ifB32G32R32F]; + +const + { TAB, CR, LF, and Space are used as seperators in Portable map headers and data.} + WhiteSpaces = [#9, #10, #13, #32]; + SPAMWidth = 'WIDTH'; + SPAMHeight = 'HEIGHT'; + SPAMDepth = 'DEPTH'; + SPAMMaxVal = 'MAXVAL'; + SPAMTupleType = 'TUPLTYPE'; + SPAMEndHdr = 'ENDHDR'; + + { Size of buffer used to speed up text PNM loading/saving.} + LineBufferCapacity = 16 * 1024; + + TupleTypeNames: array[TTupleType] of string = ( + 'INVALID', 'BLACKANDWHITE', 'GRAYSCALE', 'RGB', + 'BLACKANDWHITE_ALPHA', 'GRAYSCALE_ALPHA', 'RGB_ALPHA', 'GRAYSCALEFP', + 'RGBFP'); + +{ TPortableMapFileFormat } + +procedure TPortableMapFileFormat.Define; +begin + inherited; + FFeatures := [ffLoad, ffSave]; + FSaveBinary := PortableMapDefaultBinary; + FUSFormat := GetFormatSettingsForFloats; +end; + +function TPortableMapFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + I, ScanLineSize, MonoSize: LongInt; + Dest: PByte; + MonoData: Pointer; + Info: TImageFormatInfo; + LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar; + LineEnd, LinePos: LongInt; + MapInfo: TPortableMapInfo; + LineBreak: string; + + procedure CheckBuffer; + begin + if (LineEnd = 0) or (LinePos = LineEnd) then + begin + // Reload buffer if its is empty or its end was reached + LineEnd := GetIO.Read(Handle, @LineBuffer[0], LineBufferCapacity); + LinePos := 0; + end; + end; + + procedure FixInputPos; + begin + // Sets input's position to its real pos as it would be without buffering + if LineEnd > 0 then + begin + GetIO.Seek(Handle, -LineEnd + LinePos, smFromCurrent); + LineEnd := 0; + end; + end; + + function ReadString: string; + var + S: AnsiString; + C: AnsiChar; + begin + // First skip all whitespace chars + SetLength(S, 1); + repeat + CheckBuffer; + S[1] := LineBuffer[LinePos]; + Inc(LinePos); + if S[1] = '#' then + repeat + // Comment detected, skip everything until next line is reached + CheckBuffer; + S[1] := LineBuffer[LinePos]; + Inc(LinePos); + until S[1] = #10; + until not(S[1] in WhiteSpaces); + // Now we have reached some chars other than white space, read them until + // there is whitespace again + repeat + SetLength(S, Length(S) + 1); + CheckBuffer; + S[Length(S)] := LineBuffer[LinePos]; + Inc(LinePos); + // Repeat until current char is whitespace or end of file is reached + // (Line buffer has 0 bytes which happens only on EOF) + until (S[Length(S)] in WhiteSpaces) or (LineEnd = 0); + // Get rid of last char - whitespace or null + SetLength(S, Length(S) - 1); + // Move position to the beginning of next string (skip white space - needed + // to make the loader stop at the right input position) + repeat + CheckBuffer; + C := LineBuffer[LinePos]; + Inc(LinePos); + until not (C in WhiteSpaces) or (LineEnd = 0); + // Dec pos, current is the beginning of the the string + Dec(LinePos); + + Result := string(S); + end; + + function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} + begin + Result := StrToInt(ReadString); + end; + + procedure FindLineBreak; + var + C: AnsiChar; + begin + LineBreak := #10; + repeat + CheckBuffer; + C := LineBuffer[LinePos]; + Inc(LinePos); + + if C = #13 then + LineBreak := #13#10; + + until C = #10; + end; + + function ParseHeader: Boolean; + var + Id: TChar2; + I: TTupleType; + TupleTypeName: string; + Scale: Single; + begin + Result := False; + with GetIO do + begin + FillChar(MapInfo, SizeOf(MapInfo), 0); + Read(Handle, @Id, SizeOf(Id)); + FindLineBreak; + + if Id[1] in ['1'..'6'] then + begin + // Read header for PBM, PGM, and PPM files + MapInfo.Width := ReadIntValue; + MapInfo.Height := ReadIntValue; + + if Id[1] in ['1', '4'] then + begin + MapInfo.MaxVal := 1; + MapInfo.BitCount := 1 + end + else + begin + // Read channel max value, <=255 for 8bit images, >255 for 16bit images + // but some programs think its max colors so put <=256 here + MapInfo.MaxVal := ReadIntValue; + MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16); + end; + + MapInfo.Depth := 1; + case Id[1] of + '1', '4': MapInfo.TupleType := ttBlackAndWhite; + '2', '5': MapInfo.TupleType := ttGrayScale; + '3', '6': + begin + MapInfo.TupleType := ttRGB; + MapInfo.Depth := 3; + end; + end; + end + else if Id[1] = '7' then + begin + // Read values from PAM header + // WIDTH + if (ReadString <> SPAMWidth) then Exit; + MapInfo.Width := ReadIntValue; + // HEIGHT + if (ReadString <> SPAMheight) then Exit; + MapInfo.Height := ReadIntValue; + // DEPTH + if (ReadString <> SPAMDepth) then Exit; + MapInfo.Depth := ReadIntValue; + // MAXVAL + if (ReadString <> SPAMMaxVal) then Exit; + MapInfo.MaxVal := ReadIntValue; + MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16); + // TUPLETYPE + if (ReadString <> SPAMTupleType) then Exit; + TupleTypeName := ReadString; + for I := Low(TTupleType) to High(TTupleType) do + if SameText(TupleTypeName, TupleTypeNames[I]) then + begin + MapInfo.TupleType := I; + Break; + end; + // ENDHDR + if (ReadString <> SPAMEndHdr) then Exit; + end + else if Id[1] in ['F', 'f'] then + begin + // Read header of PFM file + MapInfo.Width := ReadIntValue; + MapInfo.Height := ReadIntValue; + Scale := StrToFloatDef(ReadString, 0, FUSFormat); + MapInfo.IsBigEndian := Scale > 0.0; + if Id[1] = 'F' then + MapInfo.TupleType := ttRGBFP + else + MapInfo.TupleType := ttGrayScaleFP; + MapInfo.Depth := Iff(MapInfo.TupleType = ttRGBFP, 3, 1); + MapInfo.BitCount := Iff(MapInfo.TupleType = ttRGBFP, 96, 32); + end; + + FixInputPos; + MapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']); + + if MapInfo.Binary and not (Id[1] in ['F', 'f']) then + begin + // Mimic the behaviour of Photoshop and other editors/viewers: + // If linereaks in file are DOS CR/LF 16bit binary values are + // little endian, Unix LF only linebreak indicates big endian. + MapInfo.IsBigEndian := LineBreak = #10; + end; + + // Check if values found in header are valid + Result := (MapInfo.Width > 0) and (MapInfo.Height > 0) and + (MapInfo.BitCount in [1, 8, 16, 32, 96]) and (MapInfo.TupleType <> ttInvalid); + // Now check if image has proper number of channels (PAM) + if Result then + case MapInfo.TupleType of + ttBlackAndWhite, ttGrayScale: Result := MapInfo.Depth = 1; + ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := MapInfo.Depth = 2; + ttRGB: Result := MapInfo.Depth = 3; + ttRGBAlpha: Result := MapInfo.Depth = 4; + end; + end; + end; + +begin + Result := False; + LineEnd := 0; + LinePos := 0; + SetLength(Images, 1); + + with GetIO, Images[0] do + begin + Format := ifUnknown; + // Try to parse file header + if not ParseHeader then Exit; + // Select appropriate data format based on values read from file header + case MapInfo.TupleType of + ttBlackAndWhite: Format := ifGray8; + ttBlackAndWhiteAlpha: Format := ifA8Gray8; + ttGrayScale: Format := IffFormat(MapInfo.BitCount = 8, ifGray8, ifGray16); + ttGrayScaleAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16); + ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16); + ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16); + ttGrayScaleFP: Format := ifR32F; + ttRGBFP: Format := ifB32G32R32F; + end; + // Exit if no matching data format was found + if Format = ifUnknown then Exit; + + NewImage(MapInfo.Width, MapInfo.Height, Format, Images[0]); + Info := GetFormatInfo(Format); + + // Now read pixels from file to dest image + if not MapInfo.Binary then + begin + Dest := Bits; + for I := 0 to Width * Height - 1 do + begin + case Format of + ifGray8: + begin + Dest^ := ReadIntValue; + if MapInfo.BitCount = 1 then + // If source is 1bit mono image (where 0=white, 1=black) + // we must scale it to 8bits + Dest^ := 255 - Dest^ * 255; + end; + ifGray16: PWord(Dest)^ := ReadIntValue; + ifR8G8B8: + with PColor24Rec(Dest)^ do + begin + R := ReadIntValue; + G := ReadIntValue; + B := ReadIntValue; + end; + ifR16G16B16: + with PColor48Rec(Dest)^ do + begin + R := ReadIntValue; + G := ReadIntValue; + B := ReadIntValue; + end; + end; + Inc(Dest, Info.BytesPerPixel); + end; + end + else + begin + if MapInfo.BitCount > 1 then + begin + if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then + begin + // Just copy bytes from binary Portable Maps (non 1bit, non FP) + Read(Handle, Bits, Size); + end + else + begin + Dest := Bits; + // FP images are in BGR order and endian swap maybe needed. + // Some programs store scanlines in bottom-up order but + // I will stick with Photoshops behaviour here + Read(Handle, Bits, Size); + if MapInfo.IsBigEndian then + SwapEndianUInt32(PUInt32(Dest), Size div SizeOf(UInt32)); + end; + + if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then + begin + // Black and white PAM files must be scaled to 8bits. Note that + // in PAM files 1=white, 0=black (reverse of PBM) + for I := 0 to Width * Height * Iff(MapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do + PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255; + end + else if MapInfo.TupleType in [ttRGB, ttRGBAlpha] then + begin + // Swap channels of RGB/ARGB images. Binary RGB image files use BGR order. + SwapChannels(Images[0], ChannelBlue, ChannelRed); + end; + + // Swap byte order if needed + if (MapInfo.BitCount = 16) and MapInfo.IsBigEndian then + SwapEndianWord(Bits, Width * Height * Info.BytesPerPixel div SizeOf(Word)); + end + else + begin + // Handle binary PBM files (ttBlackAndWhite 1bit) + ScanLineSize := (Width + 7) div 8; + // Get total binary data size, read it from file to temp + // buffer and convert the data to Gray8 + MonoSize := ScanLineSize * Height; + GetMem(MonoData, MonoSize); + try + Read(Handle, MonoData, MonoSize); + Convert1To8(MonoData, Bits, Width, Height, ScanLineSize, False); + // 1bit mono images must be scaled to 8bit, but inverted (where 0=white, 1=black) + for I := 0 to Width * Height - 1 do + PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255; + finally + FreeMem(MonoData); + end; + end; + end; + + FixInputPos; + + if (MapInfo.MaxVal <> Pow2Int(MapInfo.BitCount) - 1) and + (MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then + begin + Dest := Bits; + // Scale color values according to MaxVal we got from header + // if necessary. + for I := 0 to Width * Height * Info.BytesPerPixel div (MapInfo.BitCount shr 3) - 1 do + begin + if MapInfo.BitCount = 8 then + Dest^ := Dest^ * 255 div MapInfo.MaxVal + else + PWord(Dest)^ := PWord(Dest)^ * 65535 div MapInfo.MaxVal; + Inc(Dest, MapInfo.BitCount shr 3); + end; + end; + + Result := True; + end; +end; + +function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt; var MapInfo: TPortableMapInfo): Boolean; +const + // Use Unix linebreak, for many viewers/editors it means that + // 16bit samples are stored as big endian - so we need to swap byte order + // before saving + LineDelimiter = #10; + PixelDelimiter = #32; +var + ImageToSave: TImageData; + MustBeFreed: Boolean; + Info: TImageFormatInfo; + I, LineLength: LongInt; + Src: PByte; + Pixel32: TColor32Rec; + Pixel64: TColor64Rec; + W: Word; + + procedure WriteString(S: string; Delimiter: Char = LineDelimiter); + begin + SetLength(S, Length(S) + 1); + S[Length(S)] := Delimiter; + {$IF Defined(DCC) and Defined(UNICODE)} + GetIO.Write(Handle, @AnsiString(S)[1], Length(S)); + {$ELSE} + GetIO.Write(Handle, @S[1], Length(S)); + {$IFEND} + Inc(LineLength, Length(S)); + end; + + procedure WriteHeader; + begin + WriteString('P' + MapInfo.FormatId); + if not MapInfo.HasPAMHeader then + begin + // Write header of PGM, PPM, and PFM files + WriteString(IntToStr(ImageToSave.Width)); + WriteString(IntToStr(ImageToSave.Height)); + case MapInfo.TupleType of + ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1)); + ttGrayScaleFP, ttRGBFP: + begin + // Negative value indicates that raster data is saved in little endian + WriteString(FloatToStr(-1.0, FUSFormat)); + end; + end; + end + else + begin + // Write PAM file header + WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width])); + WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height])); + WriteString(Format('%s %d', [SPAMDepth, MapInfo.Depth])); + WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(MapInfo.BitCount) - 1])); + WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[MapInfo.TupleType]])); + WriteString(SPAMEndHdr); + end; + end; + +begin + Result := False; + if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then + with GetIO, ImageToSave do + try + Info := GetFormatInfo(Format); + // Fill values of MapInfo record that were not filled by + // descendants in their SaveData methods + MapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8; + MapInfo.Depth := Info.ChannelCount; + if MapInfo.TupleType = ttInvalid then + begin + if Info.HasGrayChannel then + begin + if Info.HasAlphaChannel then + MapInfo.TupleType := ttGrayScaleAlpha + else + MapInfo.TupleType := ttGrayScale; + end + else + begin + if Info.HasAlphaChannel then + MapInfo.TupleType := ttRGBAlpha + else + MapInfo.TupleType := ttRGB; + end; + end; + // Write file header + WriteHeader; + + if not MapInfo.Binary then + begin + Src := Bits; + LineLength := 0; + // For each pixel find its text representation and write it to file + for I := 0 to Width * Height - 1 do + begin + case Format of + ifGray8: WriteString(IntToStr(Src^), PixelDelimiter); + ifGray16: WriteString(IntToStr(PWord(Src)^), PixelDelimiter); + ifR8G8B8: + with PColor24Rec(Src)^ do + WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter); + ifR16G16B16: + with PColor48Rec(Src)^ do + WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter); + end; + // Lines in text PNM images should have length <70 + if LineLength > 65 then + begin + LineLength := 0; + WriteString('', LineDelimiter); + end; + Inc(Src, Info.BytesPerPixel); + end; + end + else + begin + // Write binary images + if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then + begin + // Save integer binary images + if MapInfo.BitCount = 8 then + begin + if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then + begin + // 8bit grayscale images can be written in one Write call + Write(Handle, Bits, Size); + end + else + begin + // 8bit RGB/ARGB images: red and blue must be swapped and + // 3 or 4 bytes must be written + Src := Bits; + for I := 0 to Width * Height - 1 do + with PColor32Rec(Src)^ do + begin + if MapInfo.TupleType = ttRGBAlpha then + Pixel32.A := A; + Pixel32.R := B; + Pixel32.G := G; + Pixel32.B := R; + Write(Handle, @Pixel32, Info.BytesPerPixel); + Inc(Src, Info.BytesPerPixel); + end; + end; + end + else + begin + // Images with 16bit channels: make sure that channel values are saved in big endian + Src := Bits; + if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then + begin + // 16bit grayscale image + for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do + begin + W := SwapEndianWord(PWord(Src)^); + Write(Handle, @W, SizeOf(Word)); + Inc(Src, SizeOf(Word)); + end; + end + else + begin + // RGB images with 16bit channels: swap RB and endian too + for I := 0 to Width * Height - 1 do + with PColor64Rec(Src)^ do + begin + if MapInfo.TupleType = ttRGBAlpha then + Pixel64.A := SwapEndianWord(A); + Pixel64.R := SwapEndianWord(B); + Pixel64.G := SwapEndianWord(G); + Pixel64.B := SwapEndianWord(R); + Write(Handle, @Pixel64, Info.BytesPerPixel); + Inc(Src, Info.BytesPerPixel); + end; + end; + end; + end + else + begin + // Floating point images (no need to swap endian here - little + // endian is specified in file header) + Write(Handle, Bits, Size); + end; + end; + Result := True; + finally + if MustBeFreed then + FreeImage(ImageToSave); + end; +end; + +function TPortableMapFileFormat.TestFormat(Handle: TImagingHandle): Boolean; +var + Id: TChar4; + ReadCount: LongInt; +begin + Result := False; + if Handle <> nil then + with GetIO do + begin + ReadCount := Read(Handle, @Id, SizeOf(Id)); + Seek(Handle, -ReadCount, smFromCurrent); + Result := (Id[0] = 'P') and (Id[1] in [FIdNumbers[0], FIdNumbers[1]]) and + (Id[2] in WhiteSpaces); + end; +end; + +{ TPBMFileFormat } + +procedure TPBMFileFormat.Define; +begin + inherited; + FName := SPBMFormatName; + FFeatures := [ffLoad]; + AddMasks(SPBMMasks); + FIdNumbers := '14'; +end; + +{ TPGMFileFormat } + +procedure TPGMFileFormat.Define; +begin + inherited; + FName := SPGMFormatName; + FSupportedFormats := PGMSupportedFormats; + AddMasks(SPGMMasks); + RegisterOption(ImagingPGMSaveBinary, @FSaveBinary); + FIdNumbers := '25'; +end; + +function TPGMFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + MapInfo: TPortableMapInfo; +begin + FillChar(MapInfo, SizeOf(MapInfo), 0); + if FSaveBinary then + MapInfo.FormatId := FIdNumbers[1] + else + MapInfo.FormatId := FIdNumbers[0]; + MapInfo.Binary := FSaveBinary; + Result := SaveDataInternal(Handle, Images, Index, MapInfo); +end; + +procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +var + ConvFormat: TImageFormat; +begin + if Info.IsFloatingPoint then + // All FP images go to 16bit + ConvFormat := ifGray16 + else if Info.HasGrayChannel then + // Grayscale will be 8 or 16 bit - depends on input's bitcount + ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1, + ifGray16, ifGray8) + else if Info.BytesPerPixel > 4 then + // Large bitcounts -> 16bit + ConvFormat := ifGray16 + else + // Rest of the formats -> 8bit + ConvFormat := ifGray8; + + ConvertImage(Image, ConvFormat); +end; + +{ TPPMFileFormat } + +procedure TPPMFileFormat.Define; +begin + inherited; + FName := SPPMFormatName; + FSupportedFormats := PPMSupportedFormats; + AddMasks(SPPMMasks); + RegisterOption(ImagingPPMSaveBinary, @FSaveBinary); + FIdNumbers := '36'; +end; + +function TPPMFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + MapInfo: TPortableMapInfo; +begin + FillChar(MapInfo, SizeOf(MapInfo), 0); + if FSaveBinary then + MapInfo.FormatId := FIdNumbers[1] + else + MapInfo.FormatId := FIdNumbers[0]; + MapInfo.Binary := FSaveBinary; + Result := SaveDataInternal(Handle, Images, Index, MapInfo); +end; + +procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +var + ConvFormat: TImageFormat; +begin + if Info.IsFloatingPoint then + // All FP images go to 48bit RGB + ConvFormat := ifR16G16B16 + else if Info.HasGrayChannel then + // Grayscale will be 24 or 48 bit RGB - depends on input's bitcount + ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1, + ifR16G16B16, ifR8G8B8) + else if Info.BytesPerPixel > 4 then + // Large bitcounts -> 48bit RGB + ConvFormat := ifR16G16B16 + else + // Rest of the formats -> 24bit RGB + ConvFormat := ifR8G8B8; + + ConvertImage(Image, ConvFormat); +end; + +{ TPAMFileFormat } + +procedure TPAMFileFormat.Define; +begin + inherited; + FName := SPAMFormatName; + FSupportedFormats := PAMSupportedFormats; + AddMasks(SPAMMasks); + FIdNumbers := '77'; +end; + +function TPAMFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + MapInfo: TPortableMapInfo; +begin + FillChar(MapInfo, SizeOf(MapInfo), 0); + MapInfo.FormatId := FIdNumbers[0]; + MapInfo.Binary := True; + MapInfo.HasPAMHeader := True; + Result := SaveDataInternal(Handle, Images, Index, MapInfo); +end; + +procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +var + ConvFormat: TImageFormat; +begin + if Info.IsFloatingPoint then + ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16) + else if Info.HasGrayChannel then + ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray16) + else + begin + if Info.BytesPerPixel <= 4 then + ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8) + else + ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16); + end; + ConvertImage(Image, ConvFormat); +end; + +{ TPFMFileFormat } + +procedure TPFMFileFormat.Define; +begin + inherited; + FName := SPFMFormatName; + AddMasks(SPFMMasks); + FIdNumbers := 'Ff'; + FSupportedFormats := PFMSupportedFormats; +end; + +function TPFMFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + Info: TImageFormatInfo; + MapInfo: TPortableMapInfo; +begin + FillChar(MapInfo, SizeOf(MapInfo), 0); + Info := GetFormatInfo(Images[Index].Format); + + if (Info.ChannelCount > 1) or Info.IsIndexed then + MapInfo.TupleType := ttRGBFP + else + MapInfo.TupleType := ttGrayScaleFP; + + if MapInfo.TupleType = ttGrayScaleFP then + MapInfo.FormatId := FIdNumbers[1] + else + MapInfo.FormatId := FIdNumbers[0]; + + MapInfo.Binary := True; + Result := SaveDataInternal(Handle, Images, Index, MapInfo); +end; + +procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +begin + if (Info.ChannelCount > 1) or Info.IsIndexed then + ConvertImage(Image, ifB32G32R32F) + else + ConvertImage(Image, ifR32F); +end; + +initialization + RegisterImageFileFormat(TPBMFileFormat); + RegisterImageFileFormat(TPGMFileFormat); + RegisterImageFileFormat(TPPMFileFormat); + RegisterImageFileFormat(TPAMFileFormat); + RegisterImageFileFormat(TPFMFileFormat); + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - nothing now + + -- 0.77.1 Changes/Bug Fixes ----------------------------------- + - Native RGB floating point format of PFM is now supported by Imaging + so we use it now for saving instead of A32B32G32B32. + - String to float formatting changes (don't change global settings). + + -- 0.26.3 Changes/Bug Fixes ----------------------------------- + - Fixed D2009 Unicode related bug in PNM saving. + + -- 0.24.3 Changes/Bug Fixes ----------------------------------- + - Improved compatibility of 16bit/component image loading. + - Changes for better thread safety. + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Made modifications to ASCII PNM loading to be more "stream-safe". + - Fixed bug: indexed images saved as grayscale in PFM. + - Changed converting to supported formats little bit. + - Added scaling of channel values (non-FP and non-mono images) according + to MaxVal. + - Added buffering to loading of PNM files. More than 10x faster now + for text files. + - Added saving support to PGM, PPM, PAM, and PFM format. + - Added PFM file format. + - Initial version created. +} + +end. diff --git a/Imaging/ImagingRadiance.pas b/Imaging/ImagingRadiance.pas new file mode 100644 index 0000000..c92b2c7 --- /dev/null +++ b/Imaging/ImagingRadiance.pas @@ -0,0 +1,480 @@ +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains image format loader/saver for Radiance HDR/RGBE images.} +unit ImagingRadiance; + +{$I ImagingOptions.inc} + +interface + +uses + SysUtils, Classes, Imaging, ImagingTypes, ImagingUtility; + +type + { Radiance is a suite of tools for performing lighting simulation. It's + development started in 1985 and it pioneered the concept of + high dynamic range imaging. Radiance defined an image format for storing + HDR images, now described as RGBE image format. Since it was the first + HDR image format, this format is supported by many other software packages. + + Radiance image file consists of three sections: a header, resolution string, + followed by the pixel data. Each pixel is stored as 4 bytes, one byte + mantissa for each r, g, b and a shared one byte exponent. + The pixel data may be stored uncompressed or using run length encoding. + + Imaging translates RGBE pixels to original float values and stores them + in ifR32G32B32F data format. It can read both compressed and uncompressed + files, and saves files as compressed.} + THdrFileFormat = class(TImageFileFormat) + protected + procedure Define; override; + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean): Boolean; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + public + function TestFormat(Handle: TImagingHandle): Boolean; override; + end; + +implementation + +uses + Math, ImagingIO; + +const + SHdrFormatName = 'Radiance HDR/RGBE'; + SHdrMasks = '*.hdr'; + HdrSupportedFormats: TImageFormats = [ifR32G32B32F]; + +type + TSignature = array[0..9] of AnsiChar; + THdrFormat = (hfRgb, hfXyz); + + THdrHeader = record + Format: THdrFormat; + Width: Integer; + Height: Integer; + end; + + TRgbe = packed record + R, G, B, E: Byte; + end; + TDynRgbeArray = array of TRgbe; + +const + RadianceSignature: TSignature = '#?RADIANCE'; + RgbeSignature: TSignature = '#?RGBE'; + SFmtRgbeRle = '32-bit_rle_rgbe'; + SFmtXyzeRle = '32-bit_rle_xyze'; + +resourcestring + SErrorBadHeader = 'Bad HDR/RGBE header format.'; + SWrongScanLineWidth = 'Wrong scanline width.'; + SXyzNotSupported = 'XYZ color space not supported.'; + +{ THdrFileFormat } + +procedure THdrFileFormat.Define; +begin + inherited; + FName := SHdrFormatName; + FFeatures := [ffLoad, ffSave]; + FSupportedFormats := HdrSupportedFormats; + + AddMasks(SHdrMasks); +end; + +function THdrFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + Header: THdrHeader; + IO: TIOFunctions; + + function ReadHeader: Boolean; + const + CommentIds: TAnsiCharSet = ['#', '!']; + var + Line: AnsiString; + HasResolution: Boolean; + Count, Idx: Integer; + ValStr, NativeLine: string; + ValFloat: Double; + begin + Result := False; + HasResolution := False; + Count := 0; + + repeat + if not ReadLine(IO, Handle, Line) then + Exit; + + Inc(Count); + if Count > 16 then // Too long header for HDR + Exit; + + if Length(Line) = 0 then + Continue; + if Line[1] in CommentIds then + Continue; + + NativeLine := string(Line); + + if StrMaskMatch(NativeLine, 'Format=*') then + begin + // Data format parsing + ValStr := Copy(NativeLine, 8, MaxInt); + if ValStr = SFmtRgbeRle then + Header.Format := hfRgb + else if ValStr = SFmtXyzeRle then + Header.Format := hfXyz + else + Exit; + end; + + if StrMaskMatch(NativeLine, 'Gamma=*') then + begin + ValStr := Copy(NativeLine, 7, MaxInt); + if TryStrToFloat(ValStr, ValFloat, GetFormatSettingsForFloats) then + FMetadata.SetMetaItem(SMetaGamma, ValFloat); + end; + + if StrMaskMatch(NativeLine, 'Exposure=*') then + begin + ValStr := Copy(NativeLine, 10, MaxInt); + if TryStrToFloat(ValStr, ValFloat, GetFormatSettingsForFloats) then + FMetadata.SetMetaItem(SMetaExposure, ValFloat); + end; + + if StrMaskMatch(NativeLine, '?Y * ?X *') then + begin + Idx := Pos('X', NativeLine); + ValStr := SubString(NativeLine, 4, Idx - 2); + if not TryStrToInt(ValStr, Header.Height) then + Exit; + ValStr := Copy(NativeLine, Idx + 2, MaxInt); + if not TryStrToInt(ValStr, Header.Width) then + Exit; + + if (NativeLine[1] = '-') then + Header.Height := -Header.Height; + if (NativeLine[Idx - 1] = '-') then + Header.Width := -Header.Width; + + HasResolution := True; + end; + + until HasResolution; + Result := True; + end; + + procedure DecodeRgbe(const Src: TRgbe; Dest: PColor96FPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} + var + Mult: Single; + begin + if Src.E > 0 then + begin + Mult := Math.Ldexp(1, Src.E - 128); + Dest.R := Src.R / 255 * Mult; + Dest.G := Src.G / 255 * Mult; + Dest.B := Src.B / 255 * Mult; + end + else + begin + Dest.R := 0; + Dest.G := 0; + Dest.B := 0; + end; + end; + + procedure ReadCompressedLine(Width, Y: Integer; var DestBuffer: TDynRgbeArray); + var + Pos: Integer; + I, X, Count: Integer; + Code, Value: Byte; + LineBuff: TDynByteArray; + Rgbe: TRgbe; + Ptr: PByte; + begin + SetLength(LineBuff, Width); + IO.Read(Handle, @Rgbe, SizeOf(Rgbe)); + + if ((Rgbe.B shl 8) or Rgbe.E) <> Width then + RaiseImaging(SWrongScanLineWidth); + + for I := 0 to 3 do + begin + Pos := 0; + while Pos < Width do + begin + IO.Read(Handle, @Code, SizeOf(Byte)); + if Code > 128 then + begin + Count := Code - 128; + IO.Read(Handle, @Value, SizeOf(Byte)); + FillMemoryByte(@LineBuff[Pos], Count, Value); + end + else + begin + Count := Code; + IO.Read(Handle, @LineBuff[Pos], Count * SizeOf(Byte)); + end; + Inc(Pos, Count); + end; + + Ptr := @PByteArray(@DestBuffer[0])[I]; + for X := 0 to Width - 1 do + begin + Ptr^ := LineBuff[X]; + Inc(Ptr, 4); + end; + end; + end; + + procedure ReadPixels(var Image: TImageData); + var + Y, X, SrcLineLen: Integer; + Dest: PColor96FPRec; + Compressed: Boolean; + Rgbe: TRgbe; + Buffer: TDynRgbeArray; + begin + Dest := Image.Bits; + Compressed := not ((Image.Width < 8) or (Image.Width > $7FFFF)); + SrcLineLen := Image.Width * SizeOf(TRgbe); + + IO.Read(Handle, @Rgbe, SizeOf(Rgbe)); + IO.Seek(Handle, -SizeOf(Rgbe), smFromCurrent); + + if (Rgbe.R <> 2) or (Rgbe.G <> 2) or ((Rgbe.B and 128) > 0) then + Compressed := False; + + SetLength(Buffer, Image.Width); + + for Y := 0 to Image.Height - 1 do + begin + if Compressed then + ReadCompressedLine(Image.Width, Y, Buffer) + else + IO.Read(Handle, @Buffer[0], SrcLineLen); + + for X := 0 to Image.Width - 1 do + begin + DecodeRgbe(Buffer[X], Dest); + Inc(Dest); + end; + end; + end; + +begin + IO := GetIO; + SetLength(Images, 1); + + // Read header, allocate new image and, then read and convert the pixels + if not ReadHeader then + RaiseImaging(SErrorBadHeader); + if (Header.Format = hfXyz) then + RaiseImaging(SXyzNotSupported); + + NewImage(Abs(Header.Width), Abs(Header.Height), ifR32G32B32F, Images[0]); + ReadPixels(Images[0]); + + // Flip/mirror the image as needed (height < 0 is default top-down) + if Header.Width < 0 then + MirrorImage(Images[0]); + if Header.Height > 0 then + FlipImage(Images[0]); + + Result := True; +end; + +function THdrFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +const + LineEnd = #$0A; + SPrgComment = '#Made with Vampyre Imaging Library'; + SSizeFmt = '-Y %d +X %d'; +var + ImageToSave: TImageData; + MustBeFreed: Boolean; + IO: TIOFunctions; + + procedure SaveHeader; + begin + WriteLine(IO, Handle, RadianceSignature, LineEnd); + WriteLine(IO, Handle, SPrgComment, LineEnd); + WriteLine(IO, Handle, 'FORMAT=' + SFmtRgbeRle, LineEnd + LineEnd); + WriteLine(IO, Handle, AnsiString(Format(SSizeFmt, [ImageToSave.Height, ImageToSave.Width])), LineEnd); + end; + + procedure EncodeRgbe(const Src: TColor96FPRec; var DestR, DestG, DestB, DestE: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF} + var + V, M: {$IFDEF FPC}Float{$ELSE}Extended{$ENDIF}; + E: Integer; + begin + V := Src.R; + if (Src.G > V) then + V := Src.G; + if (Src.B > V) then + V := Src.B; + + if V < 1e-32 then + begin + DestR := 0; + DestG := 0; + DestB := 0; + DestE := 0; + end + else + begin + Frexp(V, M, E); + V := M * 256.0 / V; + DestR := ClampToByte(Round(Src.R * V)); + DestG := ClampToByte(Round(Src.G * V)); + DestB := ClampToByte(Round(Src.B * V)); + DestE := ClampToByte(E + 128); + end; + end; + + procedure WriteRleLine(const Line: array of Byte; Width: Integer); + const + MinRunLength = 4; + var + Cur, BeginRun, RunCount, OldRunCount, NonRunCount: Integer; + Buf: array[0..1] of Byte; + begin + Cur := 0; + while Cur < Width do + begin + BeginRun := Cur; + RunCount := 0; + OldRunCount := 0; + while (RunCount < MinRunLength) and (BeginRun < Width) do + begin + Inc(BeginRun, RunCount); + OldRunCount := RunCount; + RunCount := 1; + while (BeginRun + RunCount < Width) and (RunCount < 127) and (Line[BeginRun] = Line[BeginRun + RunCount]) do + Inc(RunCount); + end; + if (OldRunCount > 1) and (OldRunCount = BeginRun - Cur) then + begin + Buf[0] := 128 + OldRunCount; + Buf[1] := Line[Cur]; + IO.Write(Handle, @Buf, 2); + Cur := BeginRun; + end; + while Cur < BeginRun do + begin + NonRunCount := Min(128, BeginRun - Cur); + Buf[0] := NonRunCount; + IO.Write(Handle, @Buf, 1); + IO.Write(Handle, @Line[Cur], NonRunCount); + Inc(Cur, NonRunCount); + end; + if RunCount >= MinRunLength then + begin + Buf[0] := 128 + RunCount; + Buf[1] := Line[BeginRun]; + IO.Write(Handle, @Buf, 2); + Inc(Cur, RunCount); + end; + end; + end; + + procedure SavePixels; + var + Y, X, I, Width: Integer; + SrcPtr: PColor96FPRecArray; + Components: array of array of Byte; + StartLine: array[0..3] of Byte; + begin + Width := ImageToSave.Width; + // Save using RLE, each component is compressed separately + SetLength(Components, 4, Width); + + for Y := 0 to ImageToSave.Height - 1 do + begin + SrcPtr := @PColor96FPRecArray(ImageToSave.Bits)[ImageToSave.Width * Y]; + + // Identify line as using "new" RLE scheme (separate components) + StartLine[0] := 2; + StartLine[1] := 2; + StartLine[2] := Width shr 8; + StartLine[3] := Width and $FF; + IO.Write(Handle, @StartLine, SizeOf(StartLine)); + + for X := 0 to Width - 1 do + begin + EncodeRgbe(SrcPtr[X], Components[0, X], Components[1, X], + Components[2, X], Components[3, X]); + end; + + for I := 0 to 3 do + WriteRleLine(Components[I], Width); + end; + end; + +begin + Result := False; + IO := GetIO; + // Makes image to save compatible with Jpeg saving capabilities + if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then + with ImageToSave do + try + // Save header + SaveHeader; + // Save uncompressed pixels + SavePixels; + Result := True; + finally + if MustBeFreed then + FreeImage(ImageToSave); + end; +end; + +procedure THdrFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +begin + ConvertImage(Image, ifR32G32B32F); +end; + +function THdrFileFormat.TestFormat(Handle: TImagingHandle): Boolean; +var + FileSig: TSignature; + ReadCount: Integer; +begin + Result := False; + if Handle <> nil then + begin + ReadCount := GetIO.Read(Handle, @FileSig, SizeOf(FileSig)); + GetIO.Seek(Handle, -ReadCount, smFromCurrent); + Result := (ReadCount = SizeOf(FileSig)) and + ((FileSig = RadianceSignature) or CompareMem(@FileSig, @RgbeSignature, 6)); + end; +end; + +initialization + RegisterImageFileFormat(THdrFileFormat); + +{ + File Notes: + + -- 0.77.1 --------------------------------------------------- + - Added RLE compression to saving. + - Added image saving. + - Unit created with initial stuff (loading only). + +} + +end. diff --git a/Imaging/ImagingTarga.pas b/Imaging/ImagingTarga.pas index fedc8b8..e491bd2 100644 --- a/Imaging/ImagingTarga.pas +++ b/Imaging/ImagingTarga.pas @@ -1,623 +1,604 @@ -{ - $Id: ImagingTarga.pas 139 2008-09-18 02:01:42Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains image format loader/saver for Targa images.} -unit ImagingTarga; - -{$I ImagingOptions.inc} - -interface - -uses - ImagingTypes, Imaging, ImagingFormats, ImagingUtility; - -type - { Class for loading and saving Truevision Targa images. - It can load/save 8bit indexed or grayscale, 16 bit RGB or grayscale, - 24 bit RGB and 32 bit ARGB images with or without RLE compression.} - TTargaFileFormat = class(TImageFileFormat) - protected - FUseRLE: LongBool; - function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; - OnlyFirstLevel: Boolean): Boolean; override; - function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; - Index: LongInt): Boolean; override; - procedure ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); override; - public - constructor Create; override; - function TestFormat(Handle: TImagingHandle): Boolean; override; - published - { Controls that RLE compression is used during saving. Accessible trough - ImagingTargaRLE option.} - property UseRLE: LongBool read FUseRLE write FUseRLE; - end; - -implementation - -const - STargaFormatName = 'Truevision Targa Image'; - STargaMasks = '*.tga'; - TargaSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA1R5G5B5, - ifR8G8B8, ifA8R8G8B8]; - TargaDefaultRLE = False; - -const - STargaSignature = 'TRUEVISION-XFILE'; - -type - { Targa file header.} - TTargaHeader = packed record - IDLength: Byte; - ColorMapType: Byte; - ImageType: Byte; - ColorMapOff: Word; - ColorMapLength: Word; - ColorEntrySize: Byte; - XOrg: SmallInt; - YOrg: SmallInt; - Width: SmallInt; - Height: SmallInt; - PixelSize: Byte; - Desc: Byte; - end; - - { Footer at the end of TGA file.} - TTargaFooter = packed record - ExtOff: LongWord; // Extension Area Offset - DevDirOff: LongWord; // Developer Directory Offset - Signature: TChar16; // TRUEVISION-XFILE - Reserved: Byte; // ASCII period '.' - NullChar: Byte; // 0 - end; - - -{ TTargaFileFormat class implementation } - -constructor TTargaFileFormat.Create; -begin - inherited Create; - FName := STargaFormatName; - FCanLoad := True; - FCanSave := True; - FIsMultiImageFormat := False; - FSupportedFormats := TargaSupportedFormats; - - FUseRLE := TargaDefaultRLE; - - AddMasks(STargaMasks); - RegisterOption(ImagingTargaRLE, @FUseRLE); -end; - -function TTargaFileFormat.LoadData(Handle: TImagingHandle; - var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; -var - Hdr: TTargaHeader; - Foo: TTargaFooter; - FooterFound, ExtFound: Boolean; - I, PSize, PalSize: LongWord; - Pal: Pointer; - FmtInfo: TImageFormatInfo; - WordValue: Word; - - procedure LoadRLE; - var - I, CPixel, Cnt: LongInt; - Bpp, Rle: Byte; - Buffer, Dest, Src: PByte; - BufSize: LongInt; - begin - with GetIO, Images[0] do - begin - // Alocates buffer large enough to hold the worst case - // RLE compressed data and reads then from input - BufSize := Width * Height * FmtInfo.BytesPerPixel; - BufSize := BufSize + BufSize div 2 + 1; - GetMem(Buffer, BufSize); - Src := Buffer; - Dest := Bits; - BufSize := Read(Handle, Buffer, BufSize); - - Cnt := Width * Height; - Bpp := FmtInfo.BytesPerPixel; - CPixel := 0; - while CPixel < Cnt do - begin - Rle := Src^; - Inc(Src); - if Rle < 128 then - begin - // Process uncompressed pixel - Rle := Rle + 1; - CPixel := CPixel + Rle; - for I := 0 to Rle - 1 do - begin - // Copy pixel from src to dest - case Bpp of - 1: Dest^ := Src^; - 2: PWord(Dest)^ := PWord(Src)^; - 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^; - 4: PLongWord(Dest)^ := PLongWord(Src)^; - end; - Inc(Src, Bpp); - Inc(Dest, Bpp); - end; - end - else - begin - // Process compressed pixels - Rle := Rle - 127; - CPixel := CPixel + Rle; - // Copy one pixel from src to dest (many times there) - for I := 0 to Rle - 1 do - begin - case Bpp of - 1: Dest^ := Src^; - 2: PWord(Dest)^ := PWord(Src)^; - 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^; - 4: PLongWord(Dest)^ := PLongWord(Src)^; - end; - Inc(Dest, Bpp); - end; - Inc(Src, Bpp); - end; - end; - // set position in source to real end of compressed data - Seek(Handle, -(BufSize - LongInt(LongWord(Src) - LongWord(Buffer))), - smFromCurrent); - FreeMem(Buffer); - end; - end; - -begin - SetLength(Images, 1); - with GetIO, Images[0] do - begin - // Read targa header - Read(Handle, @Hdr, SizeOf(Hdr)); - // Skip image ID info - Seek(Handle, Hdr.IDLength, smFromCurrent); - // Determine image format - Format := ifUnknown; - case Hdr.ImageType of - 1, 9: Format := ifIndex8; - 2, 10: case Hdr.PixelSize of - 15: Format := ifX1R5G5B5; - 16: Format := ifA1R5G5B5; - 24: Format := ifR8G8B8; - 32: Format := ifA8R8G8B8; - end; - 3, 11: Format := ifGray8; - end; - // Format was not assigned by previous testing (it should be in - // well formed targas), so formats which reflects bit dept are selected - if Format = ifUnknown then - case Hdr.PixelSize of - 8: Format := ifGray8; - 15: Format := ifX1R5G5B5; - 16: Format := ifA1R5G5B5; - 24: Format := ifR8G8B8; - 32: Format := ifA8R8G8B8; - end; - NewImage(Hdr.Width, Hdr.Height, Format, Images[0]); - FmtInfo := GetFormatInfo(Format); - - if (Hdr.ColorMapType = 1) and (Hdr.ImageType in [1, 9]) then - begin - // Read palette - PSize := Hdr.ColorMapLength * (Hdr.ColorEntrySize shr 3); - GetMem(Pal, PSize); - try - Read(Handle, Pal, PSize); - // Process palette - PalSize := Iff(Hdr.ColorMapLength > FmtInfo.PaletteEntries, - FmtInfo.PaletteEntries, Hdr.ColorMapLength); - for I := 0 to PalSize - 1 do - case Hdr.ColorEntrySize of - 24: - with Palette[I] do - begin - A := $FF; - R := PPalette24(Pal)[I].R; - G := PPalette24(Pal)[I].G; - B := PPalette24(Pal)[I].B; - end; - // I've never seen tga with these palettes so they are untested - 16: - with Palette[I] do - begin - A := (PWordArray(Pal)[I] and $8000) shr 12; - R := (PWordArray(Pal)[I] and $FC00) shr 7; - G := (PWordArray(Pal)[I] and $03E0) shr 2; - B := (PWordArray(Pal)[I] and $001F) shl 3; - end; - 32: - with Palette[I] do - begin - A := PPalette32(Pal)[I].A; - R := PPalette32(Pal)[I].R; - G := PPalette32(Pal)[I].G; - B := PPalette32(Pal)[I].B; - end; - end; - finally - FreeMemNil(Pal); - end; - end; - - case Hdr.ImageType of - 0, 1, 2, 3: - // Load uncompressed mode images - Read(Handle, Bits, Size); - 9, 10, 11: - // Load RLE compressed mode images - LoadRLE; - end; - - // Check if there is alpha channel present in A1R5GB5 images, if it is not - // change format to X1R5G5B5 - if Format = ifA1R5G5B5 then - begin - if not Has16BitImageAlpha(Width * Height, Bits) then - Format := ifX1R5G5B5; - end; - - // We must find true end of file and set input' position to it - // paint programs appends extra info at the end of Targas - // some of them multiple times (PSP Pro 8) - repeat - ExtFound := False; - FooterFound := False; - - if Read(Handle, @WordValue, 2) = 2 then - begin - // 495 = size of Extension Area - if WordValue = 495 then - begin - Seek(Handle, 493, smFromCurrent); - ExtFound := True; - end - else - Seek(Handle, -2, smFromCurrent); - end; - - if Read(Handle, @Foo, SizeOf(Foo)) = SizeOf(Foo) then - begin - if Foo.Signature = STargaSignature then - FooterFound := True - else - Seek(Handle, -SizeOf(Foo), smFromCurrent); - end; - until (not ExtFound) and (not FooterFound); - - // Some editors save targas flipped - if Hdr.Desc < 31 then - FlipImage(Images[0]); - - Result := True; - end; -end; - -function TTargaFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: LongInt): Boolean; -var - I: LongInt; - Hdr: TTargaHeader; - FmtInfo: TImageFormatInfo; - Pal: PPalette24; - ImageToSave: TImageData; - MustBeFreed: Boolean; - - procedure SaveRLE; - var - Dest: PByte; - WidthBytes, Written, I, Total, DestSize: LongInt; - - function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt; - var - Pixel: LongWord; - NextPixel: LongWord; - N: LongInt; - begin - N := 0; - Pixel := 0; - NextPixel := 0; - if PixelCount = 1 then - begin - Result := PixelCount; - Exit; - end; - case Bpp of - 1: Pixel := Data^; - 2: Pixel := PWord(Data)^; - 3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^; - 4: Pixel := PLongWord(Data)^; - end; - while PixelCount > 1 do - begin - Inc(Data, Bpp); - case Bpp of - 1: NextPixel := Data^; - 2: NextPixel := PWord(Data)^; - 3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^; - 4: NextPixel := PLongWord(Data)^; - end; - if NextPixel = Pixel then - Break; - Pixel := NextPixel; - N := N + 1; - PixelCount := PixelCount - 1; - end; - if NextPixel = Pixel then - Result := N - else - Result := N + 1; - end; - - function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt; - var - Pixel: LongWord; - NextPixel: LongWord; - N: LongInt; - begin - N := 1; - Pixel := 0; - NextPixel := 0; - case Bpp of - 1: Pixel := Data^; - 2: Pixel := PWord(Data)^; - 3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^; - 4: Pixel := PLongWord(Data)^; - end; - PixelCount := PixelCount - 1; - while PixelCount > 0 do - begin - Inc(Data, Bpp); - case Bpp of - 1: NextPixel := Data^; - 2: NextPixel := PWord(Data)^; - 3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^; - 4: NextPixel := PLongWord(Data)^; - end; - if NextPixel <> Pixel then - Break; - N := N + 1; - PixelCount := PixelCount - 1; - end; - Result := N; - end; - - procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest: - PByte; var Written: LongInt); - const - MaxRun = 128; - var - DiffCount: LongInt; - SameCount: LongInt; - RleBufSize: LongInt; - begin - RleBufSize := 0; - while PixelCount > 0 do - begin - DiffCount := CountDiff(Data, Bpp, PixelCount); - SameCount := CountSame(Data, Bpp, PixelCount); - if (DiffCount > MaxRun) then - DiffCount := MaxRun; - if (SameCount > MaxRun) then - SameCount := MaxRun; - if (DiffCount > 0) then - begin - Dest^ := Byte(DiffCount - 1); - Inc(Dest); - PixelCount := PixelCount - DiffCount; - RleBufSize := RleBufSize + (DiffCount * Bpp) + 1; - Move(Data^, Dest^, DiffCount * Bpp); - Inc(Data, DiffCount * Bpp); - Inc(Dest, DiffCount * Bpp); - end; - if SameCount > 1 then - begin - Dest^ := Byte((SameCount - 1) or $80); - Inc(Dest); - PixelCount := PixelCount - SameCount; - RleBufSize := RleBufSize + Bpp + 1; - Inc(Data, (SameCount - 1) * Bpp); - case Bpp of - 1: Dest^ := Data^; - 2: PWord(Dest)^ := PWord(Data)^; - 3: PColor24Rec(Dest)^ := PColor24Rec(Data)^; - 4: PLongWord(Dest)^ := PLongWord(Data)^; - end; - Inc(Data, Bpp); - Inc(Dest, Bpp); - end; - end; - Written := RleBufSize; - end; - - begin - with ImageToSave do - begin - // Allocate enough space to hold the worst case compression - // result and then compress source's scanlines - WidthBytes := Width * FmtInfo.BytesPerPixel; - DestSize := WidthBytes * Height; - DestSize := DestSize + DestSize div 2 + 1; - GetMem(Dest, DestSize); - Total := 0; - try - for I := 0 to Height - 1 do - begin - RleCompressLine(@PByteArray(Bits)[I * WidthBytes], Width, - FmtInfo.BytesPerPixel, @PByteArray(Dest)[Total], Written); - Total := Total + Written; - end; - GetIO.Write(Handle, Dest, Total); - finally - FreeMem(Dest); - end; - end; - end; - -begin - Result := False; - if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then - with GetIO, ImageToSave do - try - FmtInfo := GetFormatInfo(Format); - // Fill targa header - FillChar(Hdr, SizeOf(Hdr), 0); - Hdr.IDLength := 0; - Hdr.ColorMapType := Iff(FmtInfo.PaletteEntries > 0, 1, 0); - Hdr.Width := Width; - Hdr.Height := Height; - Hdr.PixelSize := FmtInfo.BytesPerPixel * 8; - Hdr.ColorMapLength := FmtInfo.PaletteEntries; - Hdr.ColorEntrySize := Iff(FmtInfo.PaletteEntries > 0, 24, 0); - Hdr.ColorMapOff := 0; - // This indicates that targa is stored in top-left format - // as our images -> no flipping is needed. - Hdr.Desc := 32; - // Set alpha channel size in descriptor (mostly ignored by other software though) - if Format = ifA8R8G8B8 then - Hdr.Desc := Hdr.Desc or 8 - else if Format = ifA1R5G5B5 then - Hdr.Desc := Hdr.Desc or 1; - - // Choose image type - if FmtInfo.IsIndexed then - Hdr.ImageType := Iff(FUseRLE, 9, 1) - else - if FmtInfo.HasGrayChannel then - Hdr.ImageType := Iff(FUseRLE, 11, 3) - else - Hdr.ImageType := Iff(FUseRLE, 10, 2); - - Write(Handle, @Hdr, SizeOf(Hdr)); - - // Write palette - if FmtInfo.PaletteEntries > 0 then - begin - GetMem(Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec)); - try - for I := 0 to FmtInfo.PaletteEntries - 1 do - with Pal[I] do - begin - R := Palette[I].R; - G := Palette[I].G; - B := Palette[I].B; - end; - Write(Handle, Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec)); - finally - FreeMemNil(Pal); - end; - end; - - if FUseRLE then - // Save rle compressed mode images - SaveRLE - else - // Save uncompressed mode images - Write(Handle, Bits, Size); - - Result := True; - finally - if MustBeFreed then - FreeImage(ImageToSave); - end; -end; - -procedure TTargaFileFormat.ConvertToSupported(var Image: TImageData; - const Info: TImageFormatInfo); -var - ConvFormat: TImageFormat; -begin - if Info.HasGrayChannel then - // Convert all grayscale images to Gray8 (preserve alpha of AxGrayx formats) - ConvFormat := IffFormat(not Info.HasAlphaChannel, ifGray8, ifA8R8G8B8) - else if Info.IsIndexed then - // Convert all indexed images to Index8 - ConvFormat := ifIndex8 - else if Info.HasAlphaChannel then - // Convert images with alpha channel to A8R8G8B8 - ConvFormat := ifA8R8G8B8 - else if Info.UsePixelFormat then - // Convert 16bit images (without alpha channel) to A1R5G5B5 - ConvFormat := ifA1R5G5B5 - else - // Convert all other formats to R8G8B8 - ConvFormat := ifR8G8B8; - - ConvertImage(Image, ConvFormat); -end; - -function TTargaFileFormat.TestFormat(Handle: TImagingHandle): Boolean; -var - Hdr: TTargaHeader; - ReadCount: LongInt; -begin - Result := False; - if Handle <> nil then - begin - ReadCount := GetIO.Read(Handle, @Hdr, SizeOf(Hdr)); - GetIO.Seek(Handle, -ReadCount, smFromCurrent); - Result := (ReadCount >= SizeOf(Hdr)) and - (Hdr.ImageType in [0, 1, 2, 3, 9, 10, 11]) and - (Hdr.PixelSize in [1, 8, 15, 16, 24, 32]) and - (Hdr.ColorEntrySize in [0, 16, 24, 32]); - end; -end; - -initialization - RegisterImageFileFormat(TTargaFileFormat); - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - MakeCompatible method moved to base class, put ConvertToSupported here. - GetSupportedFormats removed, it is now set in constructor. - - Made public properties for options registered to SetOption/GetOption - functions. - - Changed extensions to filename masks. - - Changed SaveData, LoadData, and MakeCompatible methods according - to changes in base class in Imaging unit. - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - 16 bit images are usually without alpha but some has alpha - channel and there is no indication of it - so I have added - a check: if all pixels of image are with alpha = 0 image is treated - as X1R5G5B5 otherwise as A1R5G5B5 - - fixed problems with some nonstandard 15 bit images -} - -end. - +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains image format loader/saver for Targa images.} +unit ImagingTarga; + +{$I ImagingOptions.inc} + +interface + +uses + ImagingTypes, Imaging, ImagingFormats, ImagingUtility; + +type + { Class for loading and saving Truevision Targa images. + It can load/save 8bit indexed or grayscale, 16 bit RGB or grayscale, + 24 bit RGB and 32 bit ARGB images with or without RLE compression.} + TTargaFileFormat = class(TImageFileFormat) + protected + FUseRLE: LongBool; + procedure Define; override; + function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; + OnlyFirstLevel: Boolean): Boolean; override; + function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; + Index: LongInt): Boolean; override; + procedure ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); override; + public + function TestFormat(Handle: TImagingHandle): Boolean; override; + published + { Controls that RLE compression is used during saving. Accessible trough + ImagingTargaRLE option.} + property UseRLE: LongBool read FUseRLE write FUseRLE; + end; + +implementation + +const + STargaFormatName = 'Truevision Targa Image'; + STargaMasks = '*.tga'; + TargaSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA1R5G5B5, + ifR8G8B8, ifA8R8G8B8]; + TargaDefaultRLE = False; + +const + STargaSignature = 'TRUEVISION-XFILE'; + +type + { Targa file header.} + TTargaHeader = packed record + IDLength: Byte; + ColorMapType: Byte; + ImageType: Byte; + ColorMapOff: Word; + ColorMapLength: Word; + ColorEntrySize: Byte; + XOrg: SmallInt; + YOrg: SmallInt; + Width: SmallInt; + Height: SmallInt; + PixelSize: Byte; + Desc: Byte; + end; + + { Footer at the end of TGA file.} + TTargaFooter = packed record + ExtOff: UInt32; // Extension Area Offset + DevDirOff: UInt32; // Developer Directory Offset + Signature: TChar16; // TRUEVISION-XFILE + Reserved: Byte; // ASCII period '.' + NullChar: Byte; // 0 + end; + + +{ TTargaFileFormat class implementation } + +procedure TTargaFileFormat.Define; +begin + inherited; + FName := STargaFormatName; + FFeatures := [ffLoad, ffSave]; + FSupportedFormats := TargaSupportedFormats; + + FUseRLE := TargaDefaultRLE; + + AddMasks(STargaMasks); + RegisterOption(ImagingTargaRLE, @FUseRLE); +end; + +function TTargaFileFormat.LoadData(Handle: TImagingHandle; + var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; +var + Hdr: TTargaHeader; + Foo: TTargaFooter; + FooterFound, ExtFound: Boolean; + I, PSize, PalSize: Integer; + Pal: Pointer; + FmtInfo: TImageFormatInfo; + WordValue: Word; + + procedure LoadRLE; + var + I, CPixel, Cnt: LongInt; + Bpp, Rle: Byte; + Buffer, Dest, Src: PByte; + BufSize: LongInt; + begin + with GetIO, Images[0] do + begin + // Allocates buffer large enough to hold the worst case + // RLE compressed data and reads then from input + BufSize := Width * Height * FmtInfo.BytesPerPixel; + BufSize := BufSize + BufSize div 2 + 1; + GetMem(Buffer, BufSize); + Src := Buffer; + Dest := Bits; + BufSize := Read(Handle, Buffer, BufSize); + + Cnt := Width * Height; + Bpp := FmtInfo.BytesPerPixel; + CPixel := 0; + while CPixel < Cnt do + begin + Rle := Src^; + Inc(Src); + if Rle < 128 then + begin + // Process uncompressed pixel + Rle := Rle + 1; + CPixel := CPixel + Rle; + for I := 0 to Rle - 1 do + begin + // Copy pixel from src to dest + case Bpp of + 1: Dest^ := Src^; + 2: PWord(Dest)^ := PWord(Src)^; + 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^; + 4: PUInt32(Dest)^ := PUInt32(Src)^; + end; + Inc(Src, Bpp); + Inc(Dest, Bpp); + end; + end + else + begin + // Process compressed pixels + Rle := Rle - 127; + CPixel := CPixel + Rle; + // Copy one pixel from src to dest (many times there) + for I := 0 to Rle - 1 do + begin + case Bpp of + 1: Dest^ := Src^; + 2: PWord(Dest)^ := PWord(Src)^; + 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^; + 4: PUInt32(Dest)^ := PUInt32(Src)^; + end; + Inc(Dest, Bpp); + end; + Inc(Src, Bpp); + end; + end; + // set position in source to real end of compressed data + Seek(Handle, -(BufSize - (PtrUInt(Src) - PtrUInt(Buffer))), + smFromCurrent); + FreeMem(Buffer); + end; + end; + +begin + SetLength(Images, 1); + with GetIO, Images[0] do + begin + // Read targa header + Read(Handle, @Hdr, SizeOf(Hdr)); + // Skip image ID info + Seek(Handle, Hdr.IDLength, smFromCurrent); + // Determine image format + Format := ifUnknown; + case Hdr.ImageType of + 1, 9: Format := ifIndex8; + 2, 10: case Hdr.PixelSize of + 15: Format := ifX1R5G5B5; + 16: Format := ifA1R5G5B5; + 24: Format := ifR8G8B8; + 32: Format := ifA8R8G8B8; + end; + 3, 11: Format := ifGray8; + end; + // Format was not assigned by previous testing (it should be in + // well formed targas), so formats which reflects bit dept are selected + if Format = ifUnknown then + case Hdr.PixelSize of + 8: Format := ifGray8; + 15: Format := ifX1R5G5B5; + 16: Format := ifA1R5G5B5; + 24: Format := ifR8G8B8; + 32: Format := ifA8R8G8B8; + end; + NewImage(Hdr.Width, Hdr.Height, Format, Images[0]); + FmtInfo := GetFormatInfo(Format); + + if (Hdr.ColorMapType = 1) and (Hdr.ImageType in [1, 9]) then + begin + // Read palette + PSize := Hdr.ColorMapLength * (Hdr.ColorEntrySize shr 3); + GetMem(Pal, PSize); + try + Read(Handle, Pal, PSize); + // Process palette + PalSize := Iff(Hdr.ColorMapLength > FmtInfo.PaletteEntries, + FmtInfo.PaletteEntries, Hdr.ColorMapLength); + for I := 0 to PalSize - 1 do + case Hdr.ColorEntrySize of + 24: + with Palette[I] do + begin + A := $FF; + R := PPalette24(Pal)[I].R; + G := PPalette24(Pal)[I].G; + B := PPalette24(Pal)[I].B; + end; + // I've never seen tga with these palettes so they are untested + 16: + with Palette[I] do + begin + A := (PWordArray(Pal)[I] and $8000) shr 12; + R := (PWordArray(Pal)[I] and $FC00) shr 7; + G := (PWordArray(Pal)[I] and $03E0) shr 2; + B := (PWordArray(Pal)[I] and $001F) shl 3; + end; + 32: + with Palette[I] do + begin + A := PPalette32(Pal)[I].A; + R := PPalette32(Pal)[I].R; + G := PPalette32(Pal)[I].G; + B := PPalette32(Pal)[I].B; + end; + end; + finally + FreeMemNil(Pal); + end; + end; + + case Hdr.ImageType of + 0, 1, 2, 3: + // Load uncompressed mode images + Read(Handle, Bits, Size); + 9, 10, 11: + // Load RLE compressed mode images + LoadRLE; + end; + + // Check if there is alpha channel present in A1R5GB5 images, if it is not + // change format to X1R5G5B5 + if Format = ifA1R5G5B5 then + begin + if not Has16BitImageAlpha(Width * Height, Bits) then + Format := ifX1R5G5B5; + end; + + // We must find true end of file and set input' position to it + // paint programs appends extra info at the end of Targas + // some of them multiple times (PSP Pro 8) + repeat + ExtFound := False; + FooterFound := False; + + if Read(Handle, @WordValue, 2) = 2 then + begin + // 495 = size of Extension Area + if WordValue = 495 then + begin + Seek(Handle, 493, smFromCurrent); + ExtFound := True; + end + else + Seek(Handle, -2, smFromCurrent); + end; + + if Read(Handle, @Foo, SizeOf(Foo)) = SizeOf(Foo) then + begin + if Foo.Signature = STargaSignature then + FooterFound := True + else + Seek(Handle, -SizeOf(Foo), smFromCurrent); + end; + until (not ExtFound) and (not FooterFound); + + // Some editors save targas flipped + if Hdr.Desc < 31 then + FlipImage(Images[0]); + + Result := True; + end; +end; + +function TTargaFileFormat.SaveData(Handle: TImagingHandle; + const Images: TDynImageDataArray; Index: LongInt): Boolean; +var + I: LongInt; + Hdr: TTargaHeader; + FmtInfo: TImageFormatInfo; + Pal: PPalette24; + ImageToSave: TImageData; + MustBeFreed: Boolean; + + procedure SaveRLE; + var + Dest: PByte; + WidthBytes, Written, I, Total, DestSize: LongInt; + + function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt; + var + Pixel: UInt32; + NextPixel: UInt32; + N: LongInt; + begin + N := 0; + Pixel := 0; + NextPixel := 0; + if PixelCount = 1 then + begin + Result := PixelCount; + Exit; + end; + case Bpp of + 1: Pixel := Data^; + 2: Pixel := PWord(Data)^; + 3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^; + 4: Pixel := PUInt32(Data)^; + end; + while PixelCount > 1 do + begin + Inc(Data, Bpp); + case Bpp of + 1: NextPixel := Data^; + 2: NextPixel := PWord(Data)^; + 3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^; + 4: NextPixel := PUInt32(Data)^; + end; + if NextPixel = Pixel then + Break; + Pixel := NextPixel; + N := N + 1; + PixelCount := PixelCount - 1; + end; + if NextPixel = Pixel then + Result := N + else + Result := N + 1; + end; + + function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt; + var + Pixel: UInt32; + NextPixel: UInt32; + N: LongInt; + begin + N := 1; + Pixel := 0; + NextPixel := 0; + case Bpp of + 1: Pixel := Data^; + 2: Pixel := PWord(Data)^; + 3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^; + 4: Pixel := PUInt32(Data)^; + end; + PixelCount := PixelCount - 1; + while PixelCount > 0 do + begin + Inc(Data, Bpp); + case Bpp of + 1: NextPixel := Data^; + 2: NextPixel := PWord(Data)^; + 3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^; + 4: NextPixel := PUInt32(Data)^; + end; + if NextPixel <> Pixel then + Break; + N := N + 1; + PixelCount := PixelCount - 1; + end; + Result := N; + end; + + procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest: + PByte; out Written: LongInt); + const + MaxRun = 128; + var + DiffCount: LongInt; + SameCount: LongInt; + RleBufSize: LongInt; + begin + RleBufSize := 0; + while PixelCount > 0 do + begin + DiffCount := CountDiff(Data, Bpp, PixelCount); + SameCount := CountSame(Data, Bpp, PixelCount); + if (DiffCount > MaxRun) then + DiffCount := MaxRun; + if (SameCount > MaxRun) then + SameCount := MaxRun; + if (DiffCount > 0) then + begin + Dest^ := Byte(DiffCount - 1); + Inc(Dest); + PixelCount := PixelCount - DiffCount; + RleBufSize := RleBufSize + (DiffCount * Bpp) + 1; + Move(Data^, Dest^, DiffCount * Bpp); + Inc(Data, DiffCount * Bpp); + Inc(Dest, DiffCount * Bpp); + end; + if SameCount > 1 then + begin + Dest^ := Byte((SameCount - 1) or $80); + Inc(Dest); + PixelCount := PixelCount - SameCount; + RleBufSize := RleBufSize + Bpp + 1; + Inc(Data, (SameCount - 1) * Bpp); + case Bpp of + 1: Dest^ := Data^; + 2: PWord(Dest)^ := PWord(Data)^; + 3: PColor24Rec(Dest)^ := PColor24Rec(Data)^; + 4: PUInt32(Dest)^ := PUInt32(Data)^; + end; + Inc(Data, Bpp); + Inc(Dest, Bpp); + end; + end; + Written := RleBufSize; + end; + + begin + with ImageToSave do + begin + // Allocate enough space to hold the worst case compression + // result and then compress source's scanlines + WidthBytes := Width * FmtInfo.BytesPerPixel; + DestSize := WidthBytes * Height; + DestSize := DestSize + DestSize div 2 + 1; + GetMem(Dest, DestSize); + Total := 0; + try + for I := 0 to Height - 1 do + begin + RleCompressLine(@PByteArray(Bits)[I * WidthBytes], Width, + FmtInfo.BytesPerPixel, @PByteArray(Dest)[Total], Written); + Total := Total + Written; + end; + GetIO.Write(Handle, Dest, Total); + finally + FreeMem(Dest); + end; + end; + end; + +begin + Result := False; + if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then + with GetIO, ImageToSave do + try + FmtInfo := GetFormatInfo(Format); + // Fill targa header + FillChar(Hdr, SizeOf(Hdr), 0); + Hdr.IDLength := 0; + Hdr.ColorMapType := Iff(FmtInfo.PaletteEntries > 0, 1, 0); + Hdr.Width := Width; + Hdr.Height := Height; + Hdr.PixelSize := FmtInfo.BytesPerPixel * 8; + Hdr.ColorMapLength := FmtInfo.PaletteEntries; + Hdr.ColorEntrySize := Iff(FmtInfo.PaletteEntries > 0, 24, 0); + Hdr.ColorMapOff := 0; + // This indicates that targa is stored in top-left format + // as our images -> no flipping is needed. + Hdr.Desc := 32; + // Set alpha channel size in descriptor (mostly ignored by other software though) + if Format = ifA8R8G8B8 then + Hdr.Desc := Hdr.Desc or 8 + else if Format = ifA1R5G5B5 then + Hdr.Desc := Hdr.Desc or 1; + + // Choose image type + if FmtInfo.IsIndexed then + Hdr.ImageType := Iff(FUseRLE, 9, 1) + else + if FmtInfo.HasGrayChannel then + Hdr.ImageType := Iff(FUseRLE, 11, 3) + else + Hdr.ImageType := Iff(FUseRLE, 10, 2); + + Write(Handle, @Hdr, SizeOf(Hdr)); + + // Write palette + if FmtInfo.PaletteEntries > 0 then + begin + GetMem(Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec)); + try + for I := 0 to FmtInfo.PaletteEntries - 1 do + with Pal[I] do + begin + R := Palette[I].R; + G := Palette[I].G; + B := Palette[I].B; + end; + Write(Handle, Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec)); + finally + FreeMemNil(Pal); + end; + end; + + if FUseRLE then + // Save rle compressed mode images + SaveRLE + else + // Save uncompressed mode images + Write(Handle, Bits, Size); + + Result := True; + finally + if MustBeFreed then + FreeImage(ImageToSave); + end; +end; + +procedure TTargaFileFormat.ConvertToSupported(var Image: TImageData; + const Info: TImageFormatInfo); +var + ConvFormat: TImageFormat; +begin + if Info.HasGrayChannel then + // Convert all grayscale images to Gray8 (preserve alpha of AxGrayx formats) + ConvFormat := IffFormat(not Info.HasAlphaChannel, ifGray8, ifA8R8G8B8) + else if Info.IsIndexed then + // Convert all indexed images to Index8 + ConvFormat := ifIndex8 + else if Info.HasAlphaChannel then + // Convert images with alpha channel to A8R8G8B8 + ConvFormat := ifA8R8G8B8 + else if Info.UsePixelFormat then + // Convert 16bit images (without alpha channel) to A1R5G5B5 + ConvFormat := ifA1R5G5B5 + else + // Convert all other formats to R8G8B8 + ConvFormat := ifR8G8B8; + + ConvertImage(Image, ConvFormat); +end; + +function TTargaFileFormat.TestFormat(Handle: TImagingHandle): Boolean; +var + Hdr: TTargaHeader; + ReadCount: LongInt; +begin + Result := False; + if Handle <> nil then + begin + ReadCount := GetIO.Read(Handle, @Hdr, SizeOf(Hdr)); + GetIO.Seek(Handle, -ReadCount, smFromCurrent); + Result := (ReadCount >= SizeOf(Hdr)) and + (Hdr.ImageType in [0, 1, 2, 3, 9, 10, 11]) and + (Hdr.PixelSize in [1, 8, 15, 16, 24, 32]) and + (Hdr.ColorEntrySize in [0, 16, 24, 32]); + end; +end; + +initialization + RegisterImageFileFormat(TTargaFileFormat); + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - nothing now + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - MakeCompatible method moved to base class, put ConvertToSupported here. + GetSupportedFormats removed, it is now set in constructor. + - Made public properties for options registered to SetOption/GetOption + functions. + - Changed extensions to filename masks. + - Changed SaveData, LoadData, and MakeCompatible methods according + to changes in base class in Imaging unit. + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - 16 bit images are usually without alpha but some has alpha + channel and there is no indication of it - so I have added + a check: if all pixels of image are with alpha = 0 image is treated + as X1R5G5B5 otherwise as A1R5G5B5 + - fixed problems with some nonstandard 15 bit images +} + +end. + diff --git a/Imaging/ImagingTypes.pas b/Imaging/ImagingTypes.pas index abdcdc8..7514d84 100644 --- a/Imaging/ImagingTypes.pas +++ b/Imaging/ImagingTypes.pas @@ -1,499 +1,564 @@ -{ - $Id: ImagingTypes.pas 171 2009-09-02 01:34:19Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains basic types and constants used by Imaging library.} -unit ImagingTypes; - -{$I ImagingOptions.inc} - -interface - -const - { Current Major version of Imaging.} - ImagingVersionMajor = 0; - { Current Minor version of Imaging.} - ImagingVersionMinor = 26; - { Current patch of Imaging.} - ImagingVersionPatch = 4; - - { Imaging Option Ids whose values can be set/get by SetOption/ - GetOption functions.} - - { Defines Jpeg compression quality, ranges from 1 (ugly/small) to 100 (nice/large). - Default value is 90.} - ImagingJpegQuality = 10; - { Specifies whether Jpeg images are saved in progressive format, - can be 0 or 1. Default value is 0.} - ImagingJpegProgressive = 11; - - { Specifies whether Windows Bitmaps are saved using RLE compression - (only for 1/4/8 bit images), can be 0 or 1. Default value is 1.} - ImagingBitmapRLE = 12; - - { Specifies whether Targa images are saved using RLE compression, - can be 0 or 1. Default value is 0.} - ImagingTargaRLE = 13; - - { Value of this option is non-zero if last loaded DDS file was cube map.} - ImagingDDSLoadedCubeMap = 14; - { Value of this option is non-zero if last loaded DDS file was volume texture.} - ImagingDDSLoadedVolume = 15; - { Value of this option is number of mipmap levels of last loaded DDS image.} - ImagingDDSLoadedMipMapCount = 16; - { Value of this option is depth (slices of volume texture or faces of - cube map) of last loaded DDS image.} - ImagingDDSLoadedDepth = 17; - { If it is non-zero next saved DDS file should be stored as cube map.} - ImagingDDSSaveCubeMap = 18; - { If it is non-zero next saved DDS file should be stored as volume texture.} - ImagingDDSSaveVolume = 19; - { Sets the number of mipmaps which should be stored in the next saved DDS file. - Only applies to cube maps and volumes, ordinary 2D textures save all - levels present in input.} - ImagingDDSSaveMipMapCount = 20; - { Sets the depth (slices of volume texture or faces of cube map) - of the next saved DDS file.} - ImagingDDSSaveDepth = 21; - - { Sets precompression filter used when saving PNG images. Allowed values - are: 0 (none), 1 (sub), 2 (up), 3 (average), 4 (paeth), - 5 (use 0 for indexed/gray images and 4 for RGB/ARGB images), - 6 (adaptive filtering - use best filter for each scanline - very slow). - Note that filters 3 and 4 are much slower than filters 1 and 2. - Default value is 5.} - ImagingPNGPreFilter = 25; - { Sets ZLib compression level used when saving PNG images. - Allowed values are in range 0 (no compresstion) to 9 (best compression). - Default value is 5.} - ImagingPNGCompressLevel = 26; - { Boolean option that specifies whether PNG images with more frames (APNG format) - are animated by Imaging (according to frame disposal/blend methods) or just - raw frames are loaded and sent to user (if you want to animate APNG yourself). - Default value is 1.} - ImagingPNGLoadAnimated = 27; - - { Specifies whether MNG animation frames are saved with lossy or lossless - compression. Lossless frames are saved as PNG images and lossy frames are - saved as JNG images. Allowed values are 0 (False) and 1 (True). - Default value is 0.} - ImagingMNGLossyCompression = 28; - { Defines whether alpha channel of lossy compressed MNG frames - (when ImagingMNGLossyCompression is 1) is lossy compressed too. - Allowed values are 0 (False) and 1 (True). Default value is 0.} - ImagingMNGLossyAlpha = 29; - { Sets precompression filter used when saving MNG frames as PNG images. - For details look at ImagingPNGPreFilter.} - ImagingMNGPreFilter = 30; - { Sets ZLib compression level used when saving MNG frames as PNG images. - For details look at ImagingPNGCompressLevel.} - ImagingMNGCompressLevel = 31; - { Specifies compression quality used when saving MNG frames as JNG images. - For details look at ImagingJpegQuality.} - ImagingMNGQuality = 32; - { Specifies whether images are saved in progressive format when saving MNG - frames as JNG images. For details look at ImagingJpegProgressive.} - ImagingMNGProgressive = 33; - - { Specifies whether alpha channels of JNG images are lossy compressed. - Allowed values are 0 (False) and 1 (True). Default value is 0.} - ImagingJNGLossyAlpha = 40; - { Sets precompression filter used when saving lossless alpha channels. - For details look at ImagingPNGPreFilter.} - ImagingJNGAlphaPreFilter = 41; - { Sets ZLib compression level used when saving lossless alpha channels. - For details look at ImagingPNGCompressLevel.} - ImagingJNGAlphaCompressLevel = 42; - { Defines compression quality used when saving JNG images (and lossy alpha channels). - For details look at ImagingJpegQuality.} - ImagingJNGQuality = 43; - { Specifies whether JNG images are saved in progressive format. - For details look at ImagingJpegProgressive.} - ImagingJNGProgressive = 44; - { Specifies whether PGM files are stored in text or in binary format. - Allowed values are 0 (store as text - very! large files) and 1 (save binary). - Default value is 1.} - ImagingPGMSaveBinary = 50; - { Specifies whether PPM files are stored in text or in binary format. - Allowed values are 0 (store as text - very! large files) and 1 (save binary). - Default value is 1.} - ImagingPPMSaveBinary = 51; - { Boolean option that specifies whether GIF images with more frames - are animated by Imaging (according to frame disposal methods) or just - raw frames are loaded and sent to user (if you want to animate GIF yourself). - Default value is 1. - Raw frames are 256 color indexed images (ifIndex8), whereas - animated frames are always in 32bit ifA8R8G8B8 format (simplifies animating).} - ImagingGIFLoadAnimated = 56; - - { This option is used when reducing number of colors used in - image (mainly when converting from ARGB image to indexed - format). Mask is 'anded' (bitwise AND) with every pixel's - channel value when creating color histogram. If $FF is used - all 8bits of color channels are used which can result in very - slow proccessing of large images with many colors so you can - use lower masks to speed it up (FC, F8 and F0 are good - choices). Allowed values are in range <0, $FF> and default is - $FE. } - ImagingColorReductionMask = 128; - { This option can be used to override image data format during image - loading. If set to format different from ifUnknown all loaded images - are automaticaly converted to this format. Useful when you have - many files in various formats but you want them all in one format for - further proccessing. Allowed values are in - range and - default value is ifUnknown.} - ImagingLoadOverrideFormat = 129; - { This option can be used to override image data format during image - saving. If set to format different from ifUnknown all images - to be saved are automaticaly internaly converted to this format. - Note that image file formats support only a subset of Imaging data formats - so final saved file may in different format than this override. - Allowed values are in range - and default value is ifUnknown.} - ImagingSaveOverrideFormat = 130; - { Specifies resampling filter used when generating mipmaps. It is used - in GenerateMipMaps low level function and Direct3D and OpenGL extensions. - Allowed values are in range - - and default value is 1 (linear filter).} - ImagingMipMapFilter = 131; - - { Returned by GetOption if given Option Id is invalid.} - InvalidOption = -$7FFFFFFF; - - { Indices that can be used to access channel values in array parts - of structures like TColor32Rec. Note that this order can be - used only for ARGB images. For ABGR image you must swap Red and Blue.} - ChannelBlue = 0; - ChannelGreen = 1; - ChannelRed = 2; - ChannelAlpha = 3; - -type - { Enum defining image data format. In formats with more channels, - first channel after "if" is stored in the most significant bits and channel - before end is stored in the least significant.} - TImageFormat = ( - ifUnknown = 0, - ifDefault = 1, - { Indexed formats using palette.} - ifIndex8 = 10, - { Grayscale/Luminance formats.} - ifGray8 = 40, - ifA8Gray8 = 41, - ifGray16 = 42, - ifGray32 = 43, - ifGray64 = 44, - ifA16Gray16 = 45, - { ARGB formats.} - ifX5R1G1B1 = 80, - ifR3G3B2 = 81, - ifR5G6B5 = 82, - ifA1R5G5B5 = 83, - ifA4R4G4B4 = 84, - ifX1R5G5B5 = 85, - ifX4R4G4B4 = 86, - ifR8G8B8 = 87, - ifA8R8G8B8 = 88, - ifX8R8G8B8 = 89, - ifR16G16B16 = 90, - ifA16R16G16B16 = 91, - ifB16G16R16 = 92, - ifA16B16G16R16 = 93, - { Floating point formats.} - ifR32F = 170, - ifA32R32G32B32F = 171, - ifA32B32G32R32F = 172, - ifR16F = 173, - ifA16R16G16B16F = 174, - ifA16B16G16R16F = 175, - { Special formats.} - ifDXT1 = 220, - ifDXT3 = 221, - ifDXT5 = 222, - ifBTC = 223, - ifATI1N = 224, - ifATI2N = 225); - - { Color value for 32 bit images.} - TColor32 = LongWord; - PColor32 = ^TColor32; - - { Color value for 64 bit images.} - TColor64 = type Int64; - PColor64 = ^TColor64; - - { Color record for 24 bit images, which allows access to individual color - channels.} - TColor24Rec = packed record - case LongInt of - 0: (B, G, R: Byte); - 1: (Channels: array[0..2] of Byte); - end; - PColor24Rec = ^TColor24Rec; - TColor24RecArray = array[0..MaxInt div SizeOf(TColor24Rec) - 1] of TColor24Rec; - PColor24RecArray = ^TColor24RecArray; - - { Color record for 32 bit images, which allows access to individual color - channels.} - TColor32Rec = packed record - case LongInt of - 0: (Color: TColor32); - 1: (B, G, R, A: Byte); - 2: (Channels: array[0..3] of Byte); - 3: (Color24Rec: TColor24Rec); - end; - PColor32Rec = ^TColor32Rec; - TColor32RecArray = array[0..MaxInt div SizeOf(TColor32Rec) - 1] of TColor32Rec; - PColor32RecArray = ^TColor32RecArray; - - { Color record for 48 bit images, which allows access to individual color - channels.} - TColor48Rec = packed record - case LongInt of - 0: (B, G, R: Word); - 1: (Channels: array[0..2] of Word); - end; - PColor48Rec = ^TColor48Rec; - TColor48RecArray = array[0..MaxInt div SizeOf(TColor48Rec) - 1] of TColor48Rec; - PColor48RecArray = ^TColor48RecArray; - - { Color record for 64 bit images, which allows access to individual color - channels.} - TColor64Rec = packed record - case LongInt of - 0: (Color: TColor64); - 1: (B, G, R, A: Word); - 2: (Channels: array[0..3] of Word); - 3: (Color48Rec: TColor48Rec); - end; - PColor64Rec = ^TColor64Rec; - TColor64RecArray = array[0..MaxInt div SizeOf(TColor64Rec) - 1] of TColor64Rec; - PColor64RecArray = ^TColor64RecArray; - - { Color record for 128 bit floating point images, which allows access to - individual color channels.} - TColorFPRec = packed record - case LongInt of - 0: (B, G, R, A: Single); - 1: (Channels: array[0..3] of Single); - end; - PColorFPRec = ^TColorFPRec; - TColorFPRecArray = array[0..MaxInt div SizeOf(TColorFPRec) - 1] of TColorFPRec; - PColorFPRecArray = ^TColorFPRecArray; - - { 16 bit floating-point value. It has 1 sign bit, 5 exponent bits, - and 10 mantissa bits.} - THalfFloat = type Word; - PHalfFloat = ^THalfFloat; - - { Color record for 64 bit floating point images, which allows access to - individual color channels.} - TColorHFRec = packed record - case LongInt of - 0: (B, G, R, A: THalfFloat); - 1: (Channels: array[0..3] of THalfFloat); - end; - PColorHFRec = ^TColorHFRec; - TColorHFRecArray = array[0..MaxInt div SizeOf(TColorHFRec) - 1] of TColorHFRec; - PColorHFRecArray = ^TColorHFRecArray; - - { Palette for indexed mode images with 32 bit colors.} - TPalette32 = TColor32RecArray; - TPalette32Size256 = array[0..255] of TColor32Rec; - PPalette32 = ^TPalette32; - - { Palette for indexd mode images with 24 bit colors.} - TPalette24 = TColor24RecArray; - TPalette24Size256 = array[0..255] of TColor24Rec; - PPalette24 = ^TPalette24; - - { Record that stores single image data and information describing it.} - TImageData = packed record - Width: LongInt; // Width of image in pixels - Height: LongInt; // Height of image in pixels - Format: TImageFormat; // Data format of image - Size: LongInt; // Size of image bits in Bytes - Bits: Pointer; // Pointer to memory containing image bits - Palette: PPalette32; // Image palette for indexed images - end; - PImageData = ^TImageData; - - { Pixel format information used in conversions to/from 16 and 8 bit ARGB - image formats.} - TPixelFormatInfo = packed record - ABitCount, RBitCount, GBitCount, BBitCount: Byte; - ABitMask, RBitMask, GBitMask, BBitMask: LongWord; - AShift, RShift, GShift, BShift: Byte; - ARecDiv, RRecDiv, GRecDiv, BRecDiv: Byte; - end; - PPixelFormatInfo = ^TPixelFormatInfo; - - PImageFormatInfo = ^TImageFormatInfo; - - { Look at TImageFormatInfo.GetPixelsSize for details.} - TFormatGetPixelsSizeFunc = function(Format: TImageFormat; Width, - Height: LongInt): LongInt; - { Look at TImageFormatInfo.CheckDimensions for details.} - TFormatCheckDimensionsProc = procedure(Format: TImageFormat; var Width, - Height: LongInt); - { Function for getting pixel colors. Native pixel is read from Image and - then translated to 32 bit ARGB.} - TGetPixel32Func = function(Bits: Pointer; Info: PImageFormatInfo; - Palette: PPalette32): TColor32Rec; - { Function for getting pixel colors. Native pixel is read from Image and - then translated to FP ARGB.} - TGetPixelFPFunc = function(Bits: Pointer; Info: PImageFormatInfo; - Palette: PPalette32): TColorFPRec; - { Procedure for setting pixel colors. Input 32 bit ARGB color is translated to - native format and then written to Image.} - TSetPixel32Proc = procedure(Bits: Pointer; Info: PImageFormatInfo; - Palette: PPalette32;const Color: TColor32Rec); - { Procedure for setting pixel colors. Input FP ARGB color is translated to - native format and then written to Image.} - TSetPixelFPProc = procedure(Bits: Pointer; Info: PImageFormatInfo; - Palette: PPalette32; const Color: TColorFPRec); - - { Additional information for each TImageFormat value.} - TImageFormatInfo = packed record - Format: TImageFormat; // Format described by this record - Name: array[0..15] of Char; // Symbolic name of format - BytesPerPixel: LongInt; // Number of bytes per pixel (note: it is - // 0 for formats where BitsPerPixel < 8 (e.g. DXT). - // Use GetPixelsSize function to get size of - // image data. - ChannelCount: LongInt; // Number of image channels (R, G, B, A, Gray) - PaletteEntries: LongInt; // Number of palette entries - HasGrayChannel: Boolean; // True if image has grayscale channel - HasAlphaChannel: Boolean; // True if image has alpha channel - IsFloatingPoint: Boolean; // True if image has floating point pixels - UsePixelFormat: Boolean; // True if image uses pixel format - IsRBSwapped: Boolean; // True if Red and Blue channels are swapped - // e.g. A16B16G16R16 has IsRBSwapped True - RBSwapFormat: TImageFormat; // Indicates supported format with swapped - // Red and Blue channels, ifUnknown if such - // format does not exist - IsIndexed: Boolean; // True if image uses palette - IsSpecial: Boolean; // True if image is in special format - PixelFormat: PPixelFormatInfo; // Pixel format structure - GetPixelsSize: TFormatGetPixelsSizeFunc; // Returns size in bytes of - // Width * Height pixels of image - CheckDimensions: TFormatCheckDimensionsProc; // some formats have limited - // values of Width and Height. This - // procedure checks and changes dimensions - // to be valid for given format. - GetPixel32: TGetPixel32Func; // 32bit ARGB pixel get function - GetPixelFP: TGetPixelFPFunc; // FP ARGB pixel get function - SetPixel32: TSetPixel32Proc; // 32bit ARGB pixel set procedure - SetPixelFP: TSetPixelFPProc; // FP ARGB pixel set procedure - SpecialNearestFormat: TImageFormat; // Regular image format used when - // compressing/decompressing special images - // as source/target - end; - - { Handle to list of image data records.} - TImageDataList = Pointer; - PImageDataList = ^TImageDataList; - - { Handle to input/output.} - TImagingHandle = Pointer; - - { Filters used in functions that resize images or their portions.} - TResizeFilter = ( - rfNearest = 0, - rfBilinear = 1, - rfBicubic = 2); - - { Seek origin mode for IO function Seek.} - TSeekMode = ( - smFromBeginning = 0, - smFromCurrent = 1, - smFromEnd = 2); - - { IO functions used for reading and writing images from/to input/output.} - TOpenReadProc = function(Source: PChar): TImagingHandle; cdecl; - TOpenWriteProc = function(Source: PChar): TImagingHandle; cdecl; - TCloseProc = procedure(Handle: TImagingHandle); cdecl; - TEofProc = function(Handle: TImagingHandle): Boolean; cdecl; - TSeekProc = function(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode): LongInt; cdecl; - TTellProc = function(Handle: TImagingHandle): LongInt; cdecl; - TReadProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl; - TWriteProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl; - -implementation - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - add lookup tables to pixel formats for fast conversions - - -- 0.24.3 Changes/Bug Fixes --------------------------------- - - Added ifATI1N and ifATI2N image data formats. - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Added ifBTC image format and SpecialNearestFormat field - to TImageFormatInfo. - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Added option constants for PGM and PPM file formats. - - Added TPalette32Size256 and TPalette24Size256 types. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - added ImagingVersionPatch constant so bug fix only releases - can be distinguished from ordinary major/minor releases - - renamed TPixelFormat to TPixelFormatInfo to avoid name collisions - with Graphics.TPixelFormat - - added new image data formats: ifR16F, ifA16R16G16B16F, - ifA16B16G16R16F - - added pixel get/set function pointers to TImageFormatInfo - - added 16bit half float type and color record - - renamed TColorFRec to TColorFPRec (and related types too) - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - added option ImagingMipMapFilter which now controls resampling filter - used when generating mipmaps - - added TResizeFilter type - - added ChannelCount to TImageFormatInfo - - added new option constants for MNG and JNG images - - -- 0.15 Changes/Bug Fixes ----------------------------------- - - added RBSwapFormat to TImageFormatInfo for faster conversions - between swapped formats (it just calls SwapChannels now if - RBSwapFormat is not ifUnknown) - - moved TImageFormatInfo and required types from Imaging unit - here, removed TImageFormatShortInfo - - added new options: ImagingLoadOverrideFormat, ImagingSaveOverrideFormat - - -- 0.13 Changes/Bug Fixes ----------------------------------- - - new ImagingColorReductionMask option added - - new image format added: ifA16Gray16 - -} - -end. +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains basic types and constants used by Imaging library.} +unit ImagingTypes; + +{$I ImagingOptions.inc} + +interface + +const + { Current Major version of Imaging.} + ImagingVersionMajor = 0; + { Current Minor version of Imaging.} + ImagingVersionMinor = 82; + + { Imaging Option Ids whose values can be set/get by SetOption/ + GetOption functions.} + + { Defines Jpeg compression quality, ranges from 1 (ugly/small) to 100 (nice/large). + Default value is 90.} + ImagingJpegQuality = 10; + { Specifies whether Jpeg images are saved in progressive format, + can be 0 or 1. Default value is 0.} + ImagingJpegProgressive = 11; + + { Specifies whether Windows Bitmaps are saved using RLE compression + (only for 1/4/8 bit images), can be 0 or 1. Default value is 1.} + ImagingBitmapRLE = 12; + + { Specifies whether Targa images are saved using RLE compression, + can be 0 or 1. Default value is 0.} + ImagingTargaRLE = 13; + + { Value of this option is non-zero if last loaded DDS file was cube map.} + ImagingDDSLoadedCubeMap = 14; + { Value of this option is non-zero if last loaded DDS file was volume texture.} + ImagingDDSLoadedVolume = 15; + { Value of this option is number of mipmap levels of last loaded DDS image.} + ImagingDDSLoadedMipMapCount = 16; + { Value of this option is depth (slices of volume texture or faces of + cube map) of last loaded DDS image.} + ImagingDDSLoadedDepth = 17; + { If it is non-zero next saved DDS file should be stored as cube map.} + ImagingDDSSaveCubeMap = 18; + { If it is non-zero next saved DDS file should be stored as volume texture.} + ImagingDDSSaveVolume = 19; + { Sets the number of mipmaps which should be stored in the next saved DDS file. + Only applies to cube maps and volumes, ordinary 2D textures save all + levels present in input.} + ImagingDDSSaveMipMapCount = 20; + { Sets the depth (slices of volume texture or faces of cube map) + of the next saved DDS file.} + ImagingDDSSaveDepth = 21; + + { Sets precompression filter used when saving PNG images. Allowed values + are: 0 (none), 1 (sub), 2 (up), 3 (average), 4 (paeth), + 5 (use 0 for indexed/gray images and 4 for RGB/ARGB images), + 6 (adaptive filtering - use best filter for each scanline - very slow). + Note that filters 3 and 4 are much slower than filters 1 and 2. + Default value is 5.} + ImagingPNGPreFilter = 25; + { Sets ZLib compression level used when saving PNG images. + Allowed values are in range 0 (no compression) to 9 (best compression). + Default value is 5.} + ImagingPNGCompressLevel = 26; + { Boolean option that specifies whether PNG images with more frames (APNG format) + are animated by Imaging (according to frame disposal/blend methods) or just + raw frames are loaded and sent to user (if you want to animate APNG yourself). + Default value is 1.} + ImagingPNGLoadAnimated = 27; + { Sets ZLib compression strategy used when saving PNG files (see deflateInit2() + in ZLib for details). Allowed values are: 0 (default), 1 (filtered), + 2 (huffman only). Default value is 0.} + ImagingPNGZLibStrategy = 28; + + { Specifies whether MNG animation frames are saved with lossy or lossless + compression. Lossless frames are saved as PNG images and lossy frames are + saved as JNG images. Allowed values are 0 (False) and 1 (True). + Default value is 0.} + ImagingMNGLossyCompression = 32; + { Defines whether alpha channel of lossy compressed MNG frames + (when ImagingMNGLossyCompression is 1) is lossy compressed too. + Allowed values are 0 (False) and 1 (True). Default value is 0.} + ImagingMNGLossyAlpha = 33; + { Sets precompression filter used when saving MNG frames as PNG images. + For details look at ImagingPNGPreFilter.} + ImagingMNGPreFilter = 34; + { Sets ZLib compression level used when saving MNG frames as PNG images. + For details look at ImagingPNGCompressLevel.} + ImagingMNGCompressLevel = 35; + { Specifies compression quality used when saving MNG frames as JNG images. + For details look at ImagingJpegQuality.} + ImagingMNGQuality = 36; + { Specifies whether images are saved in progressive format when saving MNG + frames as JNG images. For details look at ImagingJpegProgressive.} + ImagingMNGProgressive = 37; + + { Specifies whether alpha channels of JNG images are lossy compressed. + Allowed values are 0 (False) and 1 (True). Default value is 0.} + ImagingJNGLossyAlpha = 40; + { Sets precompression filter used when saving lossless alpha channels. + For details look at ImagingPNGPreFilter.} + ImagingJNGAlphaPreFilter = 41; + { Sets ZLib compression level used when saving lossless alpha channels. + For details look at ImagingPNGCompressLevel.} + ImagingJNGAlphaCompressLevel = 42; + { Defines compression quality used when saving JNG images (and lossy alpha channels). + For details look at ImagingJpegQuality.} + ImagingJNGQuality = 43; + { Specifies whether JNG images are saved in progressive format. + For details look at ImagingJpegProgressive.} + ImagingJNGProgressive = 44; + + { Specifies whether PGM files are stored in text or in binary format. + Allowed values are 0 (store as text - very! large files) and 1 (save binary). + Default value is 1.} + ImagingPGMSaveBinary = 50; + + { Specifies whether PPM files are stored in text or in binary format. + Allowed values are 0 (store as text - very! large files) and 1 (save binary). + Default value is 1.} + ImagingPPMSaveBinary = 51; + + { Boolean option that specifies whether GIF images with more frames + are animated by Imaging (according to frame disposal methods) or just + raw frames are loaded and sent to user (if you want to animate GIF yourself). + Default value is 1. + Raw frames are 256 color indexed images (ifIndex8), whereas + animated frames are always in 32bit ifA8R8G8B8 format (simplifies animating).} + ImagingGIFLoadAnimated = 56; + + { This option is used when reducing number of colors used in + image (mainly when converting from ARGB image to indexed + format). Mask is 'anded' (bitwise AND) with every pixel's + channel value when creating color histogram. If $FF is used + all 8bits of color channels are used which can result in very + slow processing of large images with many colors so you can + use lower masks to speed it up (FC, F8 and F0 are good + choices). Allowed values are in range <0, $FF> and default is + $FE. } + ImagingColorReductionMask = 128; + { This option can be used to override image data format during image + loading. If set to format different from ifUnknown all loaded images + are automatically converted to this format. Useful when you have + many files in various formats but you want them all in one format for + further processing. Allowed values are in + range and + default value is ifUnknown.} + ImagingLoadOverrideFormat = 129; + { This option can be used to override image data format during image + saving. If set to format different from ifUnknown all images + to be saved are automatically internally converted to this format. + Note that image file formats support only a subset of Imaging data formats + so final saved file may in different format than this override. + Allowed values are in range + and default value is ifUnknown.} + ImagingSaveOverrideFormat = 130; + { Specifies resampling filter used when generating mipmaps. It is used + in GenerateMipMaps low level function and Direct3D and OpenGL extensions. + Allowed values are in range + + and default value is 1 (linear filter).} + ImagingMipMapFilter = 131; + { Specifies threshold value used when automatically converting images to + ifBinary format. For adaptive thresholding see ImagingBinary.pas unit. + Default value is 128 and allowed range is 0..255.} + ImagingBinaryThreshold = 132; + + { Returned by GetOption if given Option Id is invalid.} + InvalidOption = -$7FFFFFFF; + + { Indices that can be used to access channel values in array parts + of structures like TColor32Rec. Note that this order can be + used only for ARGB images. For ABGR image you must swap Red and Blue.} + ChannelBlue = 0; + ChannelGreen = 1; + ChannelRed = 2; + ChannelAlpha = 3; + +type +{$IFDEF DCC} + {$IF CompilerVersion <= 18.5} + PtrUInt = Cardinal; + PtrInt = Integer; + { Some new Delphi platforms have 64bit LongInt/LongWord so rather use + Int32/UInt32 where you really want 32bits. } + Int32 = Integer; + UInt32 = Cardinal; + Int16 = SmallInt; + {$ELSE} + PtrUInt = NativeUInt; + PtrInt = NativeInt; + {$IFEND} + { Not sure which Delphi version defined these (e.g. XE3 has UInt32 but not PUInt32). } + {$IF not Defined(PInt32) or not Defined(PUInt32)} + PInt32 = ^Int32; + PUInt32 = ^UInt32; + {$IFEND} +{$ENDIF} + + { Enum defining image data format. In formats with more channels, + first channel after "if" is stored in the most significant bits and channel + before end is stored in the least significant.} + TImageFormat = ( + ifUnknown = 0, + ifDefault = 1, + { Indexed formats using palette } + ifIndex8 = 10, + { Grayscale/Luminance formats } + ifGray8 = 40, + ifA8Gray8 = 41, + ifGray16 = 42, + ifGray32 = 43, + ifGray64 = 44, + ifA16Gray16 = 45, + { ARGB formats } + ifX5R1G1B1 = 80, + ifR3G3B2 = 81, + ifR5G6B5 = 82, + ifA1R5G5B5 = 83, + ifA4R4G4B4 = 84, + ifX1R5G5B5 = 85, + ifX4R4G4B4 = 86, + ifR8G8B8 = 87, + ifA8R8G8B8 = 88, + ifX8R8G8B8 = 89, + ifR16G16B16 = 90, + ifA16R16G16B16 = 91, + ifB16G16R16 = 92, + ifA16B16G16R16 = 93, + { Floating point formats } + ifR32F = 160, + ifA32R32G32B32F = 161, + ifA32B32G32R32F = 162, + ifR16F = 163, + ifA16R16G16B16F = 164, + ifA16B16G16R16F = 165, + ifR32G32B32F = 166, + ifB32G32R32F = 167, + { Special formats } + ifDXT1 = 200, + ifDXT3 = 201, + ifDXT5 = 202, + ifBTC = 203, + ifATI1N = 204, + ifATI2N = 205, + ifBinary = 206, + { Passthrough formats } + {ifETC1 = 220, + ifETC2RGB = 221, + ifETC2RGBA = 222, + ifETC2PA = 223, + ifDXBC6 = 224, + ifDXBC7 = 225} + ifLast = 255 + ); + + { Color value for 32 bit images.} + TColor32 = UInt32; + PColor32 = ^TColor32; + + { Color value for 64 bit images.} + TColor64 = type Int64; + PColor64 = ^TColor64; + + { Color record for 24 bit images, which allows access to individual color + channels.} + TColor24Rec = packed record + case LongInt of + 0: (B, G, R: Byte); + 1: (Channels: array[0..2] of Byte); + end; + PColor24Rec = ^TColor24Rec; + TColor24RecArray = array[0..MaxInt div SizeOf(TColor24Rec) - 1] of TColor24Rec; + PColor24RecArray = ^TColor24RecArray; + + { Color record for 32 bit images, which allows access to individual color + channels.} + TColor32Rec = packed record + case LongInt of + 0: (Color: TColor32); + 1: (B, G, R, A: Byte); + 2: (Channels: array[0..3] of Byte); + 3: (Color24Rec: TColor24Rec); + end; + PColor32Rec = ^TColor32Rec; + TColor32RecArray = array[0..MaxInt div SizeOf(TColor32Rec) - 1] of TColor32Rec; + PColor32RecArray = ^TColor32RecArray; + + { Color record for 48 bit images, which allows access to individual color + channels.} + TColor48Rec = packed record + case LongInt of + 0: (B, G, R: Word); + 1: (Channels: array[0..2] of Word); + end; + PColor48Rec = ^TColor48Rec; + TColor48RecArray = array[0..MaxInt div SizeOf(TColor48Rec) - 1] of TColor48Rec; + PColor48RecArray = ^TColor48RecArray; + + { Color record for 64 bit images, which allows access to individual color + channels.} + TColor64Rec = packed record + case LongInt of + 0: (Color: TColor64); + 1: (B, G, R, A: Word); + 2: (Channels: array[0..3] of Word); + 3: (Color48Rec: TColor48Rec); + end; + PColor64Rec = ^TColor64Rec; + TColor64RecArray = array[0..MaxInt div SizeOf(TColor64Rec) - 1] of TColor64Rec; + PColor64RecArray = ^TColor64RecArray; + + { Color record for 96 bit floating point images, which allows access to + individual color channels.} + TColor96FPRec = packed record + case Integer of + 0: (B, G, R: Single); + 1: (Channels: array[0..2] of Single); + end; + PColor96FPRec = ^TColor96FPRec; + TColor96FPRecArray = array[0..MaxInt div SizeOf(TColor96FPRec) - 1] of TColor96FPRec; + PColor96FPRecArray = ^TColor96FPRecArray; + + { Color record for 128 bit floating point images, which allows access to + individual color channels.} + TColorFPRec = packed record + case LongInt of + 0: (B, G, R, A: Single); + 1: (Channels: array[0..3] of Single); + 2: (Color96Rec: TColor96FPRec); + end; + PColorFPRec = ^TColorFPRec; + TColorFPRecArray = array[0..MaxInt div SizeOf(TColorFPRec) - 1] of TColorFPRec; + PColorFPRecArray = ^TColorFPRecArray; + + { 16 bit floating-point value. It has 1 sign bit, 5 exponent bits, + and 10 mantissa bits.} + THalfFloat = type Word; + PHalfFloat = ^THalfFloat; + + { Color record for 64 bit floating point images, which allows access to + individual color channels.} + TColorHFRec = packed record + case LongInt of + 0: (B, G, R, A: THalfFloat); + 1: (Channels: array[0..3] of THalfFloat); + end; + PColorHFRec = ^TColorHFRec; + TColorHFRecArray = array[0..MaxInt div SizeOf(TColorHFRec) - 1] of TColorHFRec; + PColorHFRecArray = ^TColorHFRecArray; + + { Palette for indexed mode images with 32 bit colors.} + TPalette32 = TColor32RecArray; + TPalette32Size256 = array[0..255] of TColor32Rec; + PPalette32 = ^TPalette32; + + { Palette for indexd mode images with 24 bit colors.} + TPalette24 = TColor24RecArray; + TPalette24Size256 = array[0..255] of TColor24Rec; + PPalette24 = ^TPalette24; + + { Record that stores single image data and information describing it.} + TImageData = packed record + Width: LongInt; // Width of image in pixels + Height: LongInt; // Height of image in pixels + Format: TImageFormat; // Data format of image + Size: LongInt; // Size of image bits in Bytes + Bits: Pointer; // Pointer to memory containing image bits + Palette: PPalette32; // Image palette for indexed images + Tag: Pointer; // User data + end; + PImageData = ^TImageData; + + { Pixel format information used in conversions to/from 16 and 8 bit ARGB + image formats.} + TPixelFormatInfo = packed record + ABitCount, RBitCount, GBitCount, BBitCount: Byte; + ABitMask, RBitMask, GBitMask, BBitMask: UInt32; + AShift, RShift, GShift, BShift: Byte; + ARecDiv, RRecDiv, GRecDiv, BRecDiv: Byte; + end; + PPixelFormatInfo = ^TPixelFormatInfo; + + PImageFormatInfo = ^TImageFormatInfo; + + { Look at TImageFormatInfo.GetPixelsSize for details.} + TFormatGetPixelsSizeFunc = function(Format: TImageFormat; Width, + Height: LongInt): LongInt; + { Look at TImageFormatInfo.CheckDimensions for details.} + TFormatCheckDimensionsProc = procedure(Format: TImageFormat; var Width, + Height: LongInt); + { Function for getting pixel colors. Native pixel is read from Image and + then translated to 32 bit ARGB.} + TGetPixel32Func = function(Bits: Pointer; Info: PImageFormatInfo; + Palette: PPalette32): TColor32Rec; + { Function for getting pixel colors. Native pixel is read from Image and + then translated to FP ARGB.} + TGetPixelFPFunc = function(Bits: Pointer; Info: PImageFormatInfo; + Palette: PPalette32): TColorFPRec; + { Procedure for setting pixel colors. Input 32 bit ARGB color is translated to + native format and then written to Image.} + TSetPixel32Proc = procedure(Bits: Pointer; Info: PImageFormatInfo; + Palette: PPalette32;const Color: TColor32Rec); + { Procedure for setting pixel colors. Input FP ARGB color is translated to + native format and then written to Image.} + TSetPixelFPProc = procedure(Bits: Pointer; Info: PImageFormatInfo; + Palette: PPalette32; const Color: TColorFPRec); + + { Additional information for each TImageFormat value.} + TImageFormatInfo = packed record + Format: TImageFormat; // Format described by this record + Name: array[0..15] of Char; // Symbolic name of format + BytesPerPixel: LongInt; // Number of bytes per pixel (note: it is + // 0 for formats where BitsPerPixel < 8 (e.g. DXT). + // Use GetPixelsSize function to get size of + // image data. + ChannelCount: LongInt; // Number of image channels (R, G, B, A, Gray) + PaletteEntries: LongInt; // Number of palette entries + HasGrayChannel: Boolean; // True if image has grayscale channel + HasAlphaChannel: Boolean; // True if image has alpha channel + IsFloatingPoint: Boolean; // True if image has floating point pixels + UsePixelFormat: Boolean; // True if image uses pixel format + IsRBSwapped: Boolean; // True if Red and Blue channels are swapped + // e.g. A16B16G16R16 has IsRBSwapped True + RBSwapFormat: TImageFormat; // Indicates supported format with swapped + // Red and Blue channels, ifUnknown if such + // format does not exist + IsIndexed: Boolean; // True if image uses palette + IsSpecial: Boolean; // True if image is in special format + IsPassthrough: Boolean; // True if image is in passthrough program (Imaging + // itself doesn't know how to decode and encode it - + // complex texture compressions etc.) + PixelFormat: PPixelFormatInfo; // Pixel format structure + GetPixelsSize: TFormatGetPixelsSizeFunc; // Returns size in bytes of + // Width * Height pixels of image + CheckDimensions: TFormatCheckDimensionsProc; // some formats have limited + // values of Width and Height. This + // procedure checks and changes dimensions + // to be valid for given format. + GetPixel32: TGetPixel32Func; // 32bit ARGB pixel get function + GetPixelFP: TGetPixelFPFunc; // FP ARGB pixel get function + SetPixel32: TSetPixel32Proc; // 32bit ARGB pixel set procedure + SetPixelFP: TSetPixelFPProc; // FP ARGB pixel set procedure + SpecialNearestFormat: TImageFormat; // Regular image format used when + // compressing/decompressing special images + // as source/target + end; + + { Handle to list of image data records.} + TImageDataList = Pointer; + PImageDataList = ^TImageDataList; + + { Handle to input/output.} + TImagingHandle = Pointer; + + { Filters used in functions that resize images or their portions.} + TResizeFilter = ( + rfNearest = 0, + rfBilinear = 1, + rfBicubic = 2, + rfLanczos = 3); + + { Seek origin mode for IO function Seek.} + TSeekMode = ( + smFromBeginning = 0, + smFromCurrent = 1, + smFromEnd = 2); + + TOpenMode = ( + omReadOnly = 0, // Opens file for reading only + omCreate = 1, // Creates new file (overwriting any existing) and opens it for writing + omReadWrite = 2 // Opens for reading and writing. Non existing file is created. + ); + + { IO functions used for reading and writing images from/to input/output.} + TOpenProc = function(Source: PChar; Mode: TOpenMode): TImagingHandle; cdecl; + TCloseProc = procedure(Handle: TImagingHandle); cdecl; + TEofProc = function(Handle: TImagingHandle): Boolean; cdecl; + TSeekProc = function(Handle: TImagingHandle; Offset: Int64; Mode: TSeekMode): Int64; cdecl; + TTellProc = function(Handle: TImagingHandle): Int64; cdecl; + TReadProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl; + TWriteProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl; + + +implementation + +{ + File Notes: + + -- TODOS ---------------------------------------------------- + - add lookup tables to pixel formats for fast conversions + + -- 0.80 ----------------------------------------------------- + - Dropped "patch version". + + -- 0.77.3 --------------------------------------------------- + - IO functions now have 64bit sizes and offsets. + + -- 0.77.1 --------------------------------------------------- + - Added Tag to TImageData for storing user data. + - Added ImagingPNGZLibStrategy option. + - Changed IO functions. Merged open functions to one + and added third open mode R/W (for TIFF append etc.). + - Added new image data formats and related structures: + ifR32G32B32F, ifB32G32G32F. + + -- 0.26.5 Changes/Bug Fixes --------------------------------- + - Added ifBinary image format and ImagingBinaryThreshold option. + - Lanczos filter added to TResizeFilter enum. + + -- 0.24.3 Changes/Bug Fixes --------------------------------- + - Added ifATI1N and ifATI2N image data formats. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Added ifBTC image format and SpecialNearestFormat field + to TImageFormatInfo. + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Added option constants for PGM and PPM file formats. + - Added TPalette32Size256 and TPalette24Size256 types. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - added ImagingVersionPatch constant so bug fix only releases + can be distinguished from ordinary major/minor releases + - renamed TPixelFormat to TPixelFormatInfo to avoid name collisions + with Graphics.TPixelFormat + - added new image data formats: ifR16F, ifA16R16G16B16F, + ifA16B16G16R16F + - added pixel get/set function pointers to TImageFormatInfo + - added 16bit half float type and color record + - renamed TColorFRec to TColorFPRec (and related types too) + + -- 0.17 Changes/Bug Fixes ----------------------------------- + - added option ImagingMipMapFilter which now controls resampling filter + used when generating mipmaps + - added TResizeFilter type + - added ChannelCount to TImageFormatInfo + - added new option constants for MNG and JNG images + + -- 0.15 Changes/Bug Fixes ----------------------------------- + - added RBSwapFormat to TImageFormatInfo for faster conversions + between swapped formats (it just calls SwapChannels now if + RBSwapFormat is not ifUnknown) + - moved TImageFormatInfo and required types from Imaging unit + here, removed TImageFormatShortInfo + - added new options: ImagingLoadOverrideFormat, ImagingSaveOverrideFormat + + -- 0.13 Changes/Bug Fixes ----------------------------------- + - new ImagingColorReductionMask option added + - new image format added: ifA16Gray16 + +} + +end. diff --git a/Imaging/ImagingUtility.pas b/Imaging/ImagingUtility.pas index e775e50..4f994ad 100644 --- a/Imaging/ImagingUtility.pas +++ b/Imaging/ImagingUtility.pas @@ -1,111 +1,118 @@ -{ - $Id: ImagingUtility.pas 175 2009-10-06 11:55:15Z galfar $ - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - The contents of this file are used with permission, subject to the Mozilla - Public License Version 1.1 (the "License"); you may not use this file except - in compliance with the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL/MPL-1.1.html - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for - the specific language governing rights and limitations under the License. - - Alternatively, the contents of this file may be used under the terms of the - GNU Lesser General Public License (the "LGPL License"), in which case the - provisions of the LGPL License are applicable instead of those above. - If you wish to allow use of your version of this file only under the terms - of the LGPL License and not to allow others to use your version of this file - under the MPL, indicate your decision by deleting the provisions above and - replace them with the notice and other provisions required by the LGPL - License. If you do not delete the provisions above, a recipient may use - your version of this file under either the MPL or the LGPL License. - - For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html -} - -{ This unit contains utility functions and types for Imaging library.} -unit ImagingUtility; - -{$I ImagingOptions.inc} - -interface - -uses - SysUtils, Classes, Types; - -const - STrue = 'True'; - SFalse = 'False'; - -type - TByteArray = array[0..MaxInt - 1] of Byte; - PByteArray = ^TByteArray; - TWordArray = array[0..MaxInt div 2 - 1] of Word; - PWordArray = ^TWordArray; - TLongIntArray = array[0..MaxInt div 4 - 1] of LongInt; - PLongIntArray = ^TLongIntArray; - TLongWordArray = array[0..MaxInt div 4 - 1] of LongWord; - PLongWordArray = ^TLongWordArray; - TInt64Array = array[0..MaxInt div 8 - 1] of Int64; - PInt64Array = ^TInt64Array; - TSingleArray = array[0..MaxInt div 4 - 1] of Single; - PSingleArray = ^TSingleArray; - TBooleanArray = array[0..MaxInt - 1] of Boolean; - PBooleanArray = ^TBooleanArray; - - TDynByteArray = array of Byte; - TDynIntegerArray = array of Integer; - TDynBooleanArray = array of Boolean; - - TWordRec = packed record - case Integer of - 0: (WordValue: Word); - 1: (Low, High: Byte); - end; - PWordRec = ^TWordRec; - TWordRecArray = array[0..MaxInt div 2 - 1] of TWordRec; - PWordRecArray = ^TWordRecArray; - - TLongWordRec = packed record - case Integer of - 0: (LongWordValue: LongWord); - 1: (Low, High: Word); - { Array variants - Index 0 means lowest significant byte (word, ...).} - 2: (Words: array[0..1] of Word); - 3: (Bytes: array[0..3] of Byte); - end; - PLongWordRec = ^TLongWordRec; - TLongWordRecArray = array[0..MaxInt div 4 - 1] of TLongWordRec; - PLongWordRecArray = ^TLongWordRecArray; - - TInt64Rec = packed record - case Integer of - 0: (Int64Value: Int64); - 1: (Low, High: LongWord); - { Array variants - Index 0 means lowest significant byte (word, ...).} - 2: (Words: array[0..3] of Word); - 3: (Bytes: array[0..7] of Byte); - end; - PInt64Rec = ^TInt64Rec; - TInt64RecArray = array[0..MaxInt div 8 - 1] of TInt64Rec; - PInt64RecArray = ^TInt64RecArray; - - TFloatHelper = record - Data1: Int64; - Data2: Int64; - end; - PFloatHelper = ^TFloatHelper; - - TChar2 = array[0..1] of AnsiChar; - TChar3 = array[0..2] of AnsiChar; - TChar4 = array[0..3] of AnsiChar; - TChar8 = array[0..7] of AnsiChar; - TChar16 = array[0..15] of AnsiChar; - - { Options for BuildFileList function: +{ + Vampyre Imaging Library + by Marek Mauder + https://github.com/galfar/imaginglib + https://imaginglib.sourceforge.io + - - - - - + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at https://mozilla.org/MPL/2.0. +} + +{ This unit contains utility functions and types for Imaging library.} +unit ImagingUtility; + +{$I ImagingOptions.inc} + +interface + +uses + SysUtils, Classes, Types; + +const + STrue = 'True'; + SFalse = 'False'; + +type +{$IF Defined(DELPHI)} + {$IF not Defined(UInt32)} + UInt32 = Cardinal; + {$IFEND} + {$IF not Defined(PUInt32)} + PUInt32 = ^UInt32; + {$IFEND} +{$IFEND} + + TByteArray = array[0..MaxInt - 1] of Byte; + PByteArray = ^TByteArray; + TWordArray = array[0..MaxInt div 2 - 1] of Word; + PWordArray = ^TWordArray; + TUInt32Array = array[0..MaxInt div 4 - 1] of UInt32; + PUInt32Array = ^TUInt32Array; + TInt64Array = array[0..MaxInt div 8 - 1] of Int64; + PInt64Array = ^TInt64Array; + TSingleArray = array[0..MaxInt div 4 - 1] of Single; + PSingleArray = ^TSingleArray; + TBooleanArray = array[0..MaxInt - 1] of Boolean; + PBooleanArray = ^TBooleanArray; + + TDynByteArray = array of Byte; + TDynIntegerArray = array of Integer; + TDynBooleanArray = array of Boolean; + TDynStringArray = array of string; + + TWordRec = packed record + case Integer of + 0: (WordValue: Word); + 1: (Low, High: Byte); + end; + PWordRec = ^TWordRec; + TWordRecArray = array[0..MaxInt div 2 - 1] of TWordRec; + PWordRecArray = ^TWordRecArray; + + TUInt32Rec = packed record + case Integer of + 0: (UInt32Value: UInt32); + 1: (Low, High: Word); + { Array variants - Index 0 means lowest significant byte (word, ...).} + 2: (Words: array[0..1] of Word); + 3: (Bytes: array[0..3] of Byte); + end; + PUInt32Rec = ^TUInt32Rec; + TUInt32RecArray = array[0..MaxInt div 4 - 1] of TUInt32Rec; + PUInt32RecArray = ^TUInt32RecArray; + + TInt64Rec = packed record + case Integer of + 0: (Int64Value: Int64); + 1: (Low, High: UInt32); + { Array variants - Index 0 means lowest significant byte (word, ...).} + 2: (Words: array[0..3] of Word); + 3: (Bytes: array[0..7] of Byte); + end; + PInt64Rec = ^TInt64Rec; + TInt64RecArray = array[0..MaxInt div 8 - 1] of TInt64Rec; + PInt64RecArray = ^TInt64RecArray; + + TFloatHelper = record + Data: Int64; + case Integer of + 0: (Data64: Int64); + 1: (Data32: UInt32); + end; + PFloatHelper = ^TFloatHelper; + + TFloatPoint = record + X, Y: Single; + end; + + TFloatRect = record + Left, Top, Right, Bottom: Single; + end; + + TChar2 = array[0..1] of AnsiChar; + TChar3 = array[0..2] of AnsiChar; + TChar4 = array[0..3] of AnsiChar; + TChar8 = array[0..7] of AnsiChar; + TChar16 = array[0..15] of AnsiChar; + TAnsiCharSet = set of AnsiChar; + + ENotImplemented = class(Exception) + public + constructor Create; + end; + + { Options for BuildFileList function: flFullNames - file names in result will have full path names (ExtractFileDir(Path) + FileName) flRelNames - file names in result will have names relative to @@ -113,34 +120,40 @@ type flRecursive - adds files in subdirectories found in Path.} TFileListOption = (flFullNames, flRelNames, flRecursive); TFileListOptions = set of TFileListOption; - - -{ Frees class instance and sets its reference to nil.} -procedure FreeAndNil(var Obj); -{ Frees pointer and sets it to nil.} -procedure FreeMemNil(var P); {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Replacement of standard System.FreeMem procedure which checks if P is nil - (this is only needed for Free Pascal, Delphi makes checks in its FreeMem).} -procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns current exception object. Do not call outside exception handler.} -function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns time value with microsecond resolution.} -function GetTimeMicroseconds: Int64; -{ Returns time value with milisecond resolution.} -function GetTimeMilliseconds: Int64; - -{ Returns file extension (without "." dot)} -function GetFileExt(const FileName: string): string; -{ Returns file name of application's executable.} -function GetAppExe: string; -{ Returns directory where application's exceutable is located without - path delimiter at the end.} -function GetAppDir: string; -{ Returns True if FileName matches given Mask with optional case sensitivity. + + +{ Frees class instance and sets its reference to nil.} +procedure FreeAndNil(var Obj); +{ Frees pointer and sets it to nil.} +procedure FreeMemNil(var P); {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Replacement of standard System.FreeMem procedure which checks if P is nil + (this is only needed for Free Pascal, Delphi makes checks in its FreeMem).} +procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns current exception object. Do not call outside exception handler.} +function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns time value with microsecond resolution.} +function GetTimeMicroseconds: Int64; +{ Returns time value with millisecond resolution.} +function GetTimeMilliseconds: Int64; + +{ Returns file extension (without "." dot)} +function GetFileExt(const FileName: string): string; +{ Returns file name of application's executable.} +function GetAppExe: string; +{ Returns directory where application's executable is located without + path delimiter at the end.} +function GetAppDir: string; +{ Works like SysUtils.ExtractFileName but supports '/' and '\' dir delimiters + at the same time (whereas ExtractFileName supports on default delimiter on current platform).} +function GetFileName(const FileName: string): string; +{ Works like SysUtils.ExtractFileDir but supports '/' and '\' dir delimiters + at the same time (whereas ExtractFileDir supports on default delimiter on current platform).} +function GetFileDir(const FileName: string): string; +{ Returns True if Subject matches given Mask with optional case sensitivity. Mask can contain ? and * special characters: ? matches one character, * matches zero or more characters.} -function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean = False): Boolean; -{ This function fills Files string list with names of files found +function StrMaskMatch(const Subject, Mask: string; CaseSensitive: Boolean = False): Boolean; +{ This function fills Files string list with names of files found with FindFirst/FindNext functions (See details on Path/Atrr here). - BuildFileList('c:\*.*', faAnyFile, List, [flRecursive]) returns list of all files (only name.ext - no path) on C drive @@ -149,7 +162,9 @@ function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean function BuildFileList(Path: string; Attr: LongInt; Files: TStrings; Options: TFileListOptions = []): Boolean; { Similar to RTL's Pos function but with optional Offset where search will start. - This function is in the RTL StrUtils unit but } + In recent FPC and Delphi XE3+ regular SysUtils.Pos has the Offset parameter as well. + This function is in the RTL StrUtils unit, it's here to depend on additional + unit for just this one function. } function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt; { Same as PosEx but without case sensitivity.} function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} @@ -161,289 +176,328 @@ function StrTokenEnd(var S: string; Sep: Char): string; { Fills instance of TStrings with tokens from string S where tokens are separated by one of Seps characters.} procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings); -{ Returns string representation of integer number (with digit grouping).} +{ Returns string representation of integer number (with digit grouping). + Uses current locale.} function IntToStrFmt(const I: Int64): string; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns string representation of float number (with digit grouping).} +{ Returns string representation of float number (with digit grouping). + Uses current locale.} function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns format settings for parsing floats (dot as decimal separator). + Useful when formatting/parsing floats etc.} +function GetFormatSettingsForFloats: TFormatSettings; +{ Returns True if S contains at least one of the substrings in SubStrs array. Case sensitive.} +function ContainsAnySubStr(const S: string; const SubStrs: array of string): Boolean; +{ Extracts substring starting at IdxStart ending at IdxEnd. + S[IdxEnd] is not included in the result.} +function SubString(const S: string; IdxStart, IdxEnd: Integer): string; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Similar to Trim() but removes only characters in a given set. + Part of FPC RTL here for Delphi compatibility. } +function TrimSet(const S: string; const CharSet: TSysCharSet): string; +{ Similar to TrimLeft() but removes only characters in a given set. + Part of FPC RTL here for Delphi compatibility. } +function TrimLeftSet(const S: string; const CharSet:TSysCharSet): string; -{ Clamps integer value to range } -function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Clamps float value to range } -function ClampFloat(Number: Single; Min, Max: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Clamps integer value to Byte boundaries.} -function ClampToByte(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Clamps integer value to Word boundaries.} -function ClampToWord(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns True if Num is power of 2.} -function IsPow2(Num: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns next power of 2 greater than or equal to Num - (if Num itself is power of 2 then it retuns Num).} -function NextPow2(Num: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Raises 2 to the given integer power (in range [0, 30]).} -function Pow2Int(Exponent: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Raises Base to any power.} -function Power(const Base, Exponent: Single): Single; -{ Returns log base 2 of integer X (max 2^30) or -1 if X is not power of 2.} -function Log2Int(X: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns log base 2 of X.} -function Log2(X: Single): Single; -{ Returns largest integer <= Val (for 5.9 returns 5).} -function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns smallest integer >= Val (for 5.1 returns 6).} -function Ceil(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns lesser of two integer numbers.} -function Min(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns lesser of two float numbers.} -function MinFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns greater of two integer numbers.} -function Max(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns greater of two float numbers.} -function MaxFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns result from multiplying Number by Numerator and then dividing by Denominator. - Denominator must be greater than 0.} -function MulDiv(Number, Numerator, Denominator: Word): Word; {$IFDEF USE_INLINE}inline;{$ENDIF} - -{ Switches Boolean value.} -procedure Switch(var Value: Boolean); {$IFDEF USE_INLINE}inline;{$ENDIF} -{ If Condition is True then TruePart is retured, otherwise - FalsePart is returned.} -function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ If Condition is True then TruePart is retured, otherwise - FalsePart is returned.} -function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ If Condition is True then TruePart is retured, otherwise - FalsePart is returned.} -function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ If Condition is True then TruePart is retured, otherwise - FalsePart is returned.} -function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ If Condition is True then TruePart is retured, otherwise - FalsePart is returned.} -function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ If Condition is True then TruePart is retured, otherwise - FalsePart is returned.} -function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ If Condition is True then TruePart is retured, otherwise - FalsePart is returned.} -function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ If Condition is True then TruePart is retured, otherwise - FalsePart is returned.} -function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Swaps two Byte values} -procedure SwapValues(var A, B: Byte); overload; -{ Swaps two Word values} -procedure SwapValues(var A, B: Word); overload; -{ Swaps two LongInt values} -procedure SwapValues(var A, B: LongInt); overload; -{ Swaps two Single values} -procedure SwapValues(var A, B: Single); overload; -{ Swaps two LongInt values if necessary to ensure that Min <= Max.} -procedure SwapMin(var Min, Max: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} -{ This function returns True if running on little endian machine.} -function IsLittleEndian: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Swaps byte order of Word value.} -function SwapEndianWord(Value: Word): Word; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Swaps byte order of multiple Word values.} -procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload; -{ Swaps byte order of LongWord value.} -function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Swaps byte order of multiple LongWord values.} -procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload; - -{ Calculates CRC32 for the given data.} -procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt); -{ Fills given memory with given Byte value. Size is size of buffer in bytes.} -procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte); -{ Fills given memory with given Word value. Size is size of buffer in bytes.} -procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word); -{ Fills given memory with given LongWord value. Size is size of buffer in bytes.} -procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord); - -{ Returns how many mipmap levels can be created for image of given size.} -function GetNumMipMapLevels(Width, Height: LongInt): LongInt; -{ Returns total number of levels of volume texture with given depth and - mipmap count (this is not depth * mipmaps!).} -function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt; -{ Returns rectangle (X, Y, X + Width, Y + Height).} -function BoundsToRect(X, Y, Width, Height: LongInt): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns rectangle (R.Left, R.Top, R.Left + R.Right, R.Top + R.Bottom).} -function BoundsToRect(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Returns rectangle (R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top).} -function RectToBounds(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} -{ Clips given bounds to Clip rectangle.} -procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect); -{ Clips given source bounds and dest position. It is used by various CopyRect - functions that copy rect from one image to another. It handles clipping the same way - as Win32 BitBlt function. } -procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; - SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect); -{ Clips given source bounds and dest bounds. It is used by various StretchRect - functions that stretch rectangle of pixels from one image to another. - It handles clipping the same way as Win32 StretchBlt function. } -procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY, - DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect); -{ Scales one rectangle to fit into another. Proportions are preserved so - it could be used for 'Stretch To Fit Window' image drawing for instance.} -function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect; -{ Returns True if R1 fits into R2.} -function RectInRect(const R1, R2: TRect): Boolean; -{ Returns True if R1 and R2 intersects.} -function RectIntersects(const R1, R2: TRect): Boolean; - -{ Formats given message for usage in Exception.Create(..). Use only - in except block - returned message contains message of last raised exception.} -function FormatExceptMsg(const Msg: string; const Args: array of const): string; -{ Outputs debug message - shows message dialog in Windows and writes to console - in Linux/Unix.} -procedure DebugMsg(const Msg: string; const Args: array of const); - -implementation - -uses -{$IFDEF MSWINDOWS} - Windows; -{$ENDIF} -{$IFDEF UNIX} - {$IFDEF KYLIX} - Libc; - {$ELSE} - Dos, BaseUnix, Unix; - {$ENDIF} -{$ENDIF} - -procedure FreeAndNil(var Obj); -var - Temp: TObject; -begin - Temp := TObject(Obj); - Pointer(Obj) := nil; - Temp.Free; -end; - -procedure FreeMemNil(var P); -begin - FreeMem(Pointer(P)); - Pointer(P) := nil; -end; - -procedure FreeMem(P: Pointer); -begin - if P <> nil then - System.FreeMem(P); -end; - -function GetExceptObject: Exception; -begin - Result := Exception(ExceptObject); -end; - -{$IFDEF MSWINDOWS} -var - PerfFrequency: Int64; - InvPerfFrequency: Single; - -function GetTimeMicroseconds: Int64; -var - Time: Int64; -begin - QueryPerformanceCounter(Time); - Result := Round(1000000 * InvPerfFrequency * Time); -end; -{$ENDIF} - -{$IFDEF UNIX} -function GetTimeMicroseconds: Int64; -var - TimeVal: TTimeVal; -begin - {$IFDEF KYLIX} - GetTimeOfDay(TimeVal, nil); - {$ELSE} - fpGetTimeOfDay(@TimeVal, nil); - {$ENDIF} - Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec; -end; -{$ENDIF} - -{$IFDEF MSDOS} -function GetTimeMicroseconds: Int64; -asm - XOR EAX, EAX - CLI - OUT $43, AL - MOV EDX, FS:[$46C] - IN AL, $40 - DB $EB, 0, $EB, 0, $EB, 0 - MOV AH, AL - IN AL, $40 - DB $EB, 0, $EB, 0, $EB, 0 - XCHG AL, AH - NEG AX - MOVZX EDI, AX - STI - MOV EBX, $10000 - MOV EAX, EDX - XOR EDX, EDX - MUL EBX - ADD EAX, EDI - ADC EDX, 0 - PUSH EDX - PUSH EAX - MOV ECX, $82BF1000 - MOVZX EAX, WORD PTR FS:[$470] - MUL ECX - MOV ECX, EAX - POP EAX - POP EDX - ADD EAX, ECX - ADC EDX, 0 -end; -{$ENDIF} - -function GetTimeMilliseconds: Int64; -begin +{ Clamps integer value to range } +function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Clamps float value to range } +function ClampFloat(Number: Single; Min, Max: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Clamps integer value to Byte boundaries.} +function ClampToByte(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Clamps integer value to Word boundaries.} +function ClampToWord(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns True if Num is power of 2.} +function IsPow2(Num: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns next power of 2 greater than or equal to Num + (if Num itself is power of 2 then it returns Num).} +function NextPow2(Num: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Raises 2 to the given integer power (in range [0, 30]).} +function Pow2Int(Exponent: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Raises Base to any power.} +function Power(const Base, Exponent: Single): Single; +{ Returns log base 2 of integer X (max 2^30) or -1 if X is not power of 2.} +function Log2Int(X: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns log base 2 of X.} +function Log2(X: Single): Single; +{ Returns log base 10 of X.} +function Log10(X: Single): Single; +{ Returns largest integer <= Val (for 5.9 returns 5).} +function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns smallest integer >= Val (for 5.1 returns 6).} +function Ceil(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns lesser of two integer numbers.} +function Min(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns lesser of two float numbers.} +function MinFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns greater of two integer numbers.} +function Max(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns greater of two float numbers.} +function MaxFloat(A, B: Single): Single; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns greater of two float numbers.} +function MaxFloat(const A, B: Double): Double; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns result from multiplying Number by Numerator and then dividing by Denominator. + Denominator must be greater than 0.} +function MulDiv(Number, Numerator, Denominator: Word): Word; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns true if give floats are the equal within given delta.} +function SameFloat(A, B: Single; Delta: Single = 0.001): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns true if give floats are the equal within given delta.} +function SameFloat(const A, B: Double; const Delta: Double = 0.000001): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} + +{ Switches Boolean value.} +procedure Switch(var Value: Boolean); {$IFDEF USE_INLINE}inline;{$ENDIF} +{ If Condition is True then TruePart is returned, otherwise + FalsePart is returned.} +function Iff(Condition: Boolean; TruePart, FalsePart: Integer): Integer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ If Condition is True then TruePart is returned, otherwise + FalsePart is returned.} +function IffUnsigned(Condition: Boolean; TruePart, FalsePart: Cardinal): Cardinal; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ If Condition is True then TruePart is returned, otherwise + FalsePart is returned.} +function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ If Condition is True then TruePart is returned, otherwise + FalsePart is returned.} +function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ If Condition is True then TruePart is returned, otherwise + FalsePart is returned.} +function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ If Condition is True then TruePart is returned, otherwise + FalsePart is returned.} +function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ If Condition is True then TruePart is returned, otherwise + FalsePart is returned.} +function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ If Condition is True then TruePart is returned, otherwise + FalsePart is returned.} +function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Swaps two Boolean values} +procedure SwapValues(var A, B: Boolean); overload; +{ Swaps two Byte values} +procedure SwapValues(var A, B: Byte); overload; +{ Swaps two Word values} +procedure SwapValues(var A, B: Word); overload; +{ Swaps two Integer values} +procedure SwapValues(var A, B: Integer); overload; +{$IFDEF LONGINT_IS_NOT_INTEGER} +{ Swaps two LongInt values} +procedure SwapValues(var A, B: LongInt); overload; +{$ENDIF} +{ Swaps two Single values} +procedure SwapValues(var A, B: Single); overload; +{ Swaps two values if necessary to ensure that Min <= Max.} +procedure SwapMin(var Min, Max: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} +{ This function returns True if running on little endian machine.} +function IsLittleEndian: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Swaps byte order of Word value.} +function SwapEndianWord(Value: Word): Word; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Swaps byte order of multiple Word values.} +procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload; +{ Swaps byte order of UInt32 value.} +function SwapEndianUInt32(Value: UInt32): UInt32; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Swaps byte order of multiple UInt32 values.} +procedure SwapEndianUInt32(P: PUInt32; Count: LongInt); overload; + +{ Calculates CRC32 for the given data.} +procedure CalcCrc32(var Crc: UInt32; Data: Pointer; Size: LongInt); +{ Fills given memory with given Byte value. Size is size of buffer in bytes.} +procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte); +{ Fills given memory with given Word value. Size is size of buffer in bytes.} +procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word); +{ Fills given memory with given UInt32 value. Size is size of buffer in bytes.} +procedure FillMemoryUInt32(Data: Pointer; Size: LongInt; Value: UInt32); +{ Fills given memory zeroes.} +{$EXTERNALSYM ZeroMemory} // Conflicts with WinAPI ZeroMemory in C++ Builder +procedure ZeroMemory(Data: Pointer; Size: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF} + +{ Returns how many mipmap levels can be created for image of given size.} +function GetNumMipMapLevels(Width, Height: LongInt): LongInt; +{ Returns total number of levels of volume texture with given depth and + mipmap count (this is not depth * mipmaps!).} +function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt; +{ Returns rectangle (X, Y, X + Width, Y + Height).} +function BoundsToRect(X, Y, Width, Height: LongInt): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns rectangle (R.Left, R.Top, R.Left + R.Right, R.Top + R.Bottom).} +function BoundsToRect(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns rectangle (R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top).} +function RectToBounds(const R: TRect): TRect; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Clips given bounds to Clip rectangle.} +procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect); +{ Clips given source bounds and dest position. It is used by various CopyRect + functions that copy rect from one image to another. It handles clipping the same way + as Win32 BitBlt function. } +procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; + SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect); +{ Clips given source bounds and dest bounds. It is used by various StretchRect + functions that stretch rectangle of pixels from one image to another. + It handles clipping the same way as Win32 StretchBlt function. } +procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY, + DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect); +{ Scales one rectangle to fit into another. Proportions are preserved so + it could be used for 'Stretch To Fit Window' image drawing for instance.} +function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect; +{ Scales given size to fit into max size while keeping the original aspect ratio. + Useful for calculating thumbnail dimensions etc.} +function ScaleSizeToFit(const CurrentSize, MaxSize: TSize): TSize; +{ Returns width of given rect. Part of RTL in newer Delphi.} +function RectWidth(const Rect: TRect): Integer; +{ Returns height of given rect. Part of RTL in newer Delphi.} +function RectHeight(const Rect: TRect): Integer; +{ Returns True if R1 fits into R2.} +function RectInRect(const R1, R2: TRect): Boolean; +{ Returns True if R1 and R2 intersects.} +function RectIntersects(const R1, R2: TRect): Boolean; +{ Ensures that rect's right>left and bottom>top. } +procedure NormalizeRect(var R: TRect); + +{ Converts pixel size in micrometers to corresponding DPI.} +function PixelSizeToDpi(SizeInMicroMeters: Single): Single; +{ Converts DPI to corresponding pixel size in micrometers.} +function DpiToPixelSize(Dpi: Single): Single; + +function FloatPoint(AX, AY: Single): TFloatPoint; {$IFDEF USE_INLINE}inline;{$ENDIF} +function FloatRect(ALeft, ATop, ARight, ABottom: Single): TFloatRect; +function FloatRectWidth(const R: TFloatRect): Single; +function FloatRectHeight(const R: TFloatRect): Single; +function FloatRectFromRect(const R: TRect): TFloatRect; + +{ Formats given message for usage in Exception.Create(..). Use only + in except block - returned message contains message of last raised exception.} +function FormatExceptMsg(const Msg: string; const Args: array of const): string; +{ Outputs debug message - shows message dialog in Windows and writes to console + in Linux/Unix.} +procedure DebugMsg(const Msg: string; const Args: array of const); + +implementation + +uses +{$IF Defined(MSWINDOWS)} + Windows; +{$ELSEIF Defined(FPC)} + Dos, BaseUnix, Unix; +{$ELSEIF Defined(DELPHI)} + Posix.SysTime; +{$IFEND} + +var + FloatFormatSettings: TFormatSettings; + +constructor ENotImplemented.Create; +begin + inherited Create('Not implemented'); +end; + +procedure FreeAndNil(var Obj); +var + Temp: TObject; +begin + Temp := TObject(Obj); + Pointer(Obj) := nil; + Temp.Free; +end; + +procedure FreeMemNil(var P); +begin + FreeMem(Pointer(P)); + Pointer(P) := nil; +end; + +procedure FreeMem(P: Pointer); +begin + if P <> nil then + System.FreeMem(P); +end; + +function GetExceptObject: Exception; +begin + Result := Exception(ExceptObject); +end; + +{$IF Defined(MSWINDOWS)} +var + PerfFrequency: Int64; + InvPerfFrequency: Extended; + +function GetTimeMicroseconds: Int64; +var + Time: Int64; +begin + QueryPerformanceCounter(Time); + Result := Round(1000000 * InvPerfFrequency * Time); +end; +{$ELSEIF Defined(DELPHI)} +function GetTimeMicroseconds: Int64; +var + Time: TimeVal; +begin + Posix.SysTime.GetTimeOfDay(Time, nil); + Result := Int64(Time.tv_sec) * 1000000 + Time.tv_usec; +end; +{$ELSEIF Defined(FPC)} +function GetTimeMicroseconds: Int64; +var + TimeVal: TTimeVal; +begin + fpGetTimeOfDay(@TimeVal, nil); + Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec; +end; +{$IFEND} + +function GetTimeMilliseconds: Int64; +begin Result := GetTimeMicroseconds div 1000; -end; - -function GetFileExt(const FileName: string): string; -begin - Result := ExtractFileExt(FileName); - if Length(Result) > 1 then - Delete(Result, 1, 1); -end; - -function GetAppExe: string; -{$IFDEF MSWINDOWS} -var - FileName: array[0..MAX_PATH] of Char; -begin - SetString(Result, FileName, - Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName))); -{$ENDIF} -{$IFDEF UNIX} - {$IFDEF KYLIX} -var - FileName: array[0..FILENAME_MAX] of Char; -begin - SetString(Result, FileName, - System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName))); - {$ELSE} -begin - Result := FExpand(ParamStr(0)); - {$ENDIF} -{$ENDIF} -{$IFDEF MSDOS} -begin - Result := ParamStr(0); -{$ENDIF} -end; - -function GetAppDir: string; -begin - Result := ExtractFileDir(GetAppExe); -end; - -function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean): Boolean; +end; + +function GetFileExt(const FileName: string): string; +begin + Result := ExtractFileExt(FileName); + if Length(Result) > 1 then + Delete(Result, 1, 1); +end; + +function GetAppExe: string; +{$IF Defined(MSWINDOWS)} +var + FileName: array[0..MAX_PATH] of Char; +begin + SetString(Result, FileName, + Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName))); +{$ELSEIF Defined(DELPHI)} // Delphi non Win targets +var + FileName: array[0..1024] of Char; +begin + SetString(Result, FileName, + System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName))); +{$ELSE} +begin + Result := ExpandFileName(ParamStr(0)); +{$IFEND} +end; + +function GetAppDir: string; +begin + Result := ExtractFileDir(GetAppExe); +end; + +function GetFileName(const FileName: string): string; +var + I: Integer; +begin + I := LastDelimiter('\/' + DriveDelim, FileName); + Result := Copy(FileName, I + 1, MaxInt); +end; + +function GetFileDir(const FileName: string): string; +const + Delims = '\/' + DriveDelim; +var + I: Integer; +begin + I := LastDelimiter(Delims, Filename); + if (I > 1) and + ((FileName[I] = Delims[1]) or (FileName[I] = Delims[2])) and + (not IsDelimiter(Delims, FileName, I - 1)) then Dec(I); + Result := Copy(FileName, 1, I); +end; + +function StrMaskMatch(const Subject, Mask: string; CaseSensitive: Boolean): Boolean; var MaskLen, KeyLen : LongInt; @@ -486,7 +540,7 @@ var Exit; end; else - if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then + if not CharMatch(Mask[MaskPos], Subject[KeyPos]) then begin Result := False; Exit; @@ -497,9 +551,9 @@ var Inc(KeyPos); end; end; - end; + end; - while (MaskPos <= MaskLen) and (Mask[MaskPos] in ['?', '*']) do + while (MaskPos <= MaskLen) and (AnsiChar(Mask[MaskPos]) in ['?', '*']) do Inc(MaskPos); if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then begin @@ -512,16 +566,16 @@ var begin MaskLen := Length(Mask); - KeyLen := Length(FileName); + KeyLen := Length(Subject); if MaskLen = 0 then begin Result := True; Exit; end; Result := MatchAt(1, 1); -end; - -function BuildFileList(Path: string; Attr: LongInt; +end; + +function BuildFileList(Path: string; Attr: LongInt; Files: TStrings; Options: TFileListOptions): Boolean; var FileMask: string; @@ -707,817 +761,1025 @@ begin Result := Format('%.' + IntToStr(Precision) + 'n', [F]); end; -function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; -begin - Result := Number; - if Result < Min then - Result := Min - else if Result > Max then - Result := Max; -end; - -function ClampFloat(Number: Single; Min, Max: Single): Single; -begin - Result := Number; - if Result < Min then - Result := Min - else if Result > Max then - Result := Max; -end; - -function ClampToByte(Value: LongInt): LongInt; -begin - Result := Value; - if Result > 255 then - Result := 255 - else if Result < 0 then - Result := 0; -end; - -function ClampToWord(Value: LongInt): LongInt; -begin - Result := Value; - if Result > 65535 then - Result := 65535 - else if Result < 0 then - Result := 0; -end; - -function IsPow2(Num: LongInt): Boolean; -begin - Result := (Num and -Num) = Num; -end; - -function NextPow2(Num: LongInt): LongInt; -begin - Result := Num and -Num; - while Result < Num do - Result := Result shl 1; -end; - -function Pow2Int(Exponent: LongInt): LongInt; -begin - Result := 1 shl Exponent; -end; - -function Power(const Base, Exponent: Single): Single; -begin - if Exponent = 0.0 then - Result := 1.0 - else if (Base = 0.0) and (Exponent > 0.0) then - Result := 0.0 - else - Result := Exp(Exponent * Ln(Base)); -end; - -function Log2Int(X: LongInt): LongInt; -begin - case X of - 1: Result := 0; - 2: Result := 1; - 4: Result := 2; - 8: Result := 3; - 16: Result := 4; - 32: Result := 5; - 64: Result := 6; - 128: Result := 7; - 256: Result := 8; - 512: Result := 9; - 1024: Result := 10; - 2048: Result := 11; - 4096: Result := 12; - 8192: Result := 13; - 16384: Result := 14; - 32768: Result := 15; - 65536: Result := 16; - 131072: Result := 17; - 262144: Result := 18; - 524288: Result := 19; - 1048576: Result := 20; - 2097152: Result := 21; - 4194304: Result := 22; - 8388608: Result := 23; - 16777216: Result := 24; - 33554432: Result := 25; - 67108864: Result := 26; - 134217728: Result := 27; - 268435456: Result := 28; - 536870912: Result := 29; - 1073741824: Result := 30; - else - Result := -1; - end; -end; - -function Log2(X: Single): Single; -const - Ln2: Single = 0.6931471; -begin - Result := Ln(X) / Ln2; -end; - -function Floor(Value: Single): LongInt; -begin - Result := Trunc(Value); - if Frac(Value) < 0.0 then - Dec(Result); -end; - -function Ceil(Value: Single): LongInt; -begin - Result := Trunc(Value); - if Frac(Value) > 0.0 then - Inc(Result); -end; - -procedure Switch(var Value: Boolean); -begin - Value := not Value; -end; - -function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt; -begin - if Condition then - Result := TruePart - else - Result := FalsePart; -end; - -function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord; -begin - if Condition then - Result := TruePart - else - Result := FalsePart; -end; - -function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; -begin - if Condition then - Result := TruePart - else - Result := FalsePart; -end; - -function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; -begin - if Condition then - Result := TruePart - else - Result := FalsePart; -end; - -function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; -begin - if Condition then - Result := TruePart - else - Result := FalsePart; -end; - -function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; -begin +function GetFormatSettingsForFloats: TFormatSettings; +begin + Result := FloatFormatSettings; +end; + +function ContainsAnySubStr(const S: string; const SubStrs: array of string): Boolean; +var + I: Integer; +begin + Result := False; + for I := 0 to High(SubStrs) do + begin + Result := Pos(SubStrs[I], S) > 0; + if Result then + Exit; + end; +end; + +function SubString(const S: string; IdxStart, IdxEnd: Integer): string; +begin + Result := Copy(S, IdxStart, IdxEnd - IdxStart); +end; + +function TrimSet(const S: string; const CharSet: TSysCharSet): string; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] in CharSet) do + Inc(I); + if I > L then + Result := '' + else + begin + while S[L] in CharSet do + Dec(L); + Result := Copy(S, I, L - I + 1); + end; +end; + +function TrimLeftSet(const S: string; const CharSet: TSysCharSet): string; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] in CharSet) do + Inc(I); + Result := Copy(S, I, MaxInt); +end; + +function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; +begin + Result := Number; + if Result < Min then + Result := Min + else if Result > Max then + Result := Max; +end; + +function ClampFloat(Number: Single; Min, Max: Single): Single; +begin + Result := Number; + if Result < Min then + Result := Min + else if Result > Max then + Result := Max; +end; + +function ClampToByte(Value: LongInt): LongInt; +begin + Result := Value; + if Result > 255 then + Result := 255 + else if Result < 0 then + Result := 0; +end; + +function ClampToWord(Value: LongInt): LongInt; +begin + Result := Value; + if Result > 65535 then + Result := 65535 + else if Result < 0 then + Result := 0; +end; + +function IsPow2(Num: LongInt): Boolean; +begin + Result := (Num and -Num) = Num; +end; + +function NextPow2(Num: LongInt): LongInt; +begin + Result := Num and -Num; + while Result < Num do + Result := Result shl 1; +end; + +function Pow2Int(Exponent: LongInt): LongInt; +begin + Result := 1 shl Exponent; +end; + +function Power(const Base, Exponent: Single): Single; +begin + if Exponent = 0.0 then + Result := 1.0 + else if (Base = 0.0) and (Exponent > 0.0) then + Result := 0.0 + else + Result := Exp(Exponent * Ln(Base)); +end; + +function Log2Int(X: LongInt): LongInt; +begin + case X of + 1: Result := 0; + 2: Result := 1; + 4: Result := 2; + 8: Result := 3; + 16: Result := 4; + 32: Result := 5; + 64: Result := 6; + 128: Result := 7; + 256: Result := 8; + 512: Result := 9; + 1024: Result := 10; + 2048: Result := 11; + 4096: Result := 12; + 8192: Result := 13; + 16384: Result := 14; + 32768: Result := 15; + 65536: Result := 16; + 131072: Result := 17; + 262144: Result := 18; + 524288: Result := 19; + 1048576: Result := 20; + 2097152: Result := 21; + 4194304: Result := 22; + 8388608: Result := 23; + 16777216: Result := 24; + 33554432: Result := 25; + 67108864: Result := 26; + 134217728: Result := 27; + 268435456: Result := 28; + 536870912: Result := 29; + 1073741824: Result := 30; + else + Result := -1; + end; +end; + +function Log2(X: Single): Single; +{$IFDEF USE_ASM} +asm + FLD1 + FLD X + FYL2X + FWAIT +end; +{$ELSE} +const + Ln2: Single = 0.6931471; +begin + Result := Ln(X) / Ln2; +end; +{$ENDIF} + +function Log10(X: Single): Single; +{$IFDEF USE_ASM} +asm + FLDLG2 + FLD X + FYL2X + FWAIT +end; +{$ELSE} +const + Ln10: Single = 2.30258509299405; +begin + Result := Ln(X) / Ln10; +end; +{$ENDIF} + +function Floor(Value: Single): LongInt; +begin + Result := Trunc(Value); + if Value < Result then + Dec(Result); +end; + +function Ceil(Value: Single): LongInt; +begin + Result := Trunc(Value); + if Value > Result then + Inc(Result); +end; + +procedure Switch(var Value: Boolean); +begin + Value := not Value; +end; + +function Iff(Condition: Boolean; TruePart, FalsePart: Integer): Integer; +begin if Condition then - Result := TruePart - else + Result := TruePart + else Result := FalsePart; -end; - -function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; -begin +end; + +function IffUnsigned(Condition: Boolean; TruePart, FalsePart: Cardinal): Cardinal; +begin if Condition then - Result := TruePart - else + Result := TruePart + else Result := FalsePart; -end; - -function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; -begin - if Condition then - Result := TruePart - else - Result := FalsePart; -end; - -procedure SwapValues(var A, B: Byte); -var - Tmp: Byte; -begin - Tmp := A; - A := B; - B := Tmp; -end; - -procedure SwapValues(var A, B: Word); -var - Tmp: Word; -begin - Tmp := A; - A := B; - B := Tmp; -end; - -procedure SwapValues(var A, B: LongInt); -var - Tmp: LongInt; -begin - Tmp := A; - A := B; - B := Tmp; -end; - -procedure SwapValues(var A, B: Single); -var - Tmp: Single; -begin - Tmp := A; - A := B; - B := Tmp; -end; - -procedure SwapMin(var Min, Max: LongInt); -var - Tmp: LongInt; -begin - if Min > Max then - begin - Tmp := Min; - Min := Max; - Max := Tmp; - end; -end; - -function Min(A, B: LongInt): LongInt; -begin - if A < B then - Result := A - else - Result := B; -end; - -function MinFloat(A, B: Single): Single; -begin - if A < B then - Result := A - else - Result := B; -end; - -function Max(A, B: LongInt): LongInt; -begin - if A > B then - Result := A - else - Result := B; -end; - -function MaxFloat(A, B: Single): Single; -begin - if A > B then - Result := A - else - Result := B; -end; - -function MulDiv(Number, Numerator, Denominator: Word): Word; -{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))} -asm +end; + +function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; +begin + if Condition then + Result := TruePart + else + Result := FalsePart; +end; + +function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; +begin + if Condition then + Result := TruePart + else + Result := FalsePart; +end; + +function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; +begin + if Condition then + Result := TruePart + else + Result := FalsePart; +end; + +function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; +begin + if Condition then + Result := TruePart + else + Result := FalsePart; +end; + +function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; +begin + if Condition then + Result := TruePart + else + Result := FalsePart; +end; + +function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; +begin + if Condition then + Result := TruePart + else + Result := FalsePart; +end; + +procedure SwapValues(var A, B: Boolean); +var + Tmp: Boolean; +begin + Tmp := A; + A := B; + B := Tmp; +end; + +procedure SwapValues(var A, B: Byte); +var + Tmp: Byte; +begin + Tmp := A; + A := B; + B := Tmp; +end; + +procedure SwapValues(var A, B: Word); +var + Tmp: Word; +begin + Tmp := A; + A := B; + B := Tmp; +end; + +procedure SwapValues(var A, B: Integer); +var + Tmp: Integer; +begin + Tmp := A; + A := B; + B := Tmp; +end; + +{$IFDEF LONGINT_IS_NOT_INTEGER} +procedure SwapValues(var A, B: LongInt); +var + Tmp: LongInt; +begin + Tmp := A; + A := B; + B := Tmp; +end; +{$ENDIF} + +procedure SwapValues(var A, B: Single); +var + Tmp: Single; +begin + Tmp := A; + A := B; + B := Tmp; +end; + +procedure SwapMin(var Min, Max: LongInt); +var + Tmp: LongInt; +begin + if Min > Max then + begin + Tmp := Min; + Min := Max; + Max := Tmp; + end; +end; + +function Min(A, B: LongInt): LongInt; +begin + if A < B then + Result := A + else + Result := B; +end; + +function MinFloat(A, B: Single): Single; +begin + if A < B then + Result := A + else + Result := B; +end; + +function Max(A, B: LongInt): LongInt; +begin + if A > B then + Result := A + else + Result := B; +end; + +function MaxFloat(A, B: Single): Single; +begin + if A > B then + Result := A + else + Result := B; +end; + +function MaxFloat(const A, B: Double): Double; +begin + if A > B then + Result := A + else + Result := B; +end; + +function MulDiv(Number, Numerator, Denominator: Word): Word; +{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))} +asm MUL DX DIV CX -end; -{$ELSE} -begin - Result := Number * Numerator div Denominator; -end; -{$IFEND} - -function IsLittleEndian: Boolean; -var - W: Word; -begin +end; +{$ELSE} +begin + Result := Number * Numerator div Denominator; +end; +{$IFEND} + +function SameFloat(A, B: Single; Delta: Single): Boolean; +begin + Result := Abs(A - B) <= Delta; +end; + +function SameFloat(const A, B: Double; const Delta: Double): Boolean; +begin + Result := Abs(A - B) <= Delta; +end; + +function IsLittleEndian: Boolean; +var + W: Word; +begin W := $00FF; Result := PByte(@W)^ = $FF; -end; - -function SwapEndianWord(Value: Word): Word; -{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))} -asm - XCHG AH, AL -end; -{$ELSE} -begin - TWordRec(Result).Low := TWordRec(Value).High; - TWordRec(Result).High := TWordRec(Value).Low; -end; -{$IFEND} - -procedure SwapEndianWord(P: PWordArray; Count: LongInt); -{$IFDEF USE_ASM} -asm -@Loop: - MOV CX, [EAX] - XCHG CH, CL - MOV [EAX], CX - ADD EAX, 2 - DEC EDX - JNZ @Loop -end; -{$ELSE} -var - I: LongInt; - Temp: Word; -begin - for I := 0 to Count - 1 do - begin - Temp := P[I]; - TWordRec(P[I]).Low := TWordRec(Temp).High; - TWordRec(P[I]).High := TWordRec(Temp).Low; - end; -end; -{$ENDIF} - -function SwapEndianLongWord(Value: LongWord): LongWord; -{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))} -asm - BSWAP EAX -end; -{$ELSE} -begin - TLongWordRec(Result).Bytes[0] := TLongWordRec(Value).Bytes[3]; - TLongWordRec(Result).Bytes[1] := TLongWordRec(Value).Bytes[2]; - TLongWordRec(Result).Bytes[2] := TLongWordRec(Value).Bytes[1]; - TLongWordRec(Result).Bytes[3] := TLongWordRec(Value).Bytes[0]; -end; -{$IFEND} - -procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); -{$IFDEF USE_ASM} -asm -@Loop: - MOV ECX, [EAX] - BSWAP ECX - MOV [EAX], ECX - ADD EAX, 4 - DEC EDX - JNZ @Loop -end; -{$ELSE} -var - I: LongInt; - Temp: LongWord; -begin - for I := 0 to Count - 1 do - begin - Temp := PLongWordArray(P)[I]; - TLongWordRec(PLongWordArray(P)[I]).Bytes[0] := TLongWordRec(Temp).Bytes[3]; - TLongWordRec(PLongWordArray(P)[I]).Bytes[1] := TLongWordRec(Temp).Bytes[2]; - TLongWordRec(PLongWordArray(P)[I]).Bytes[2] := TLongWordRec(Temp).Bytes[1]; - TLongWordRec(PLongWordArray(P)[I]).Bytes[3] := TLongWordRec(Temp).Bytes[0]; - end; -end; -{$ENDIF} - -type - TCrcTable = array[Byte] of LongWord; -var - CrcTable: TCrcTable; - -procedure InitCrcTable; -const - Polynom = $EDB88320; -var - I, J: LongInt; - C: LongWord; -begin - for I := 0 to 255 do - begin - C := I; - for J := 0 to 7 do - begin - if (C and $01) <> 0 then - C := Polynom xor (C shr 1) - else - C := C shr 1; - end; - CrcTable[I] := C; - end; -end; - -procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt); -var - I: LongInt; - B: PByte; -begin - B := Data; - for I := 0 to Size - 1 do - begin - Crc := (Crc shr 8) xor CrcTable[B^ xor Byte(Crc)]; - Inc(B); - end -end; - -procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte); -{$IFDEF USE_ASM} -asm - PUSH EDI - MOV EDI, EAX - MOV EAX, ECX - MOV AH, AL - MOV CX, AX - SHL EAX, 16 - MOV AX, CX - MOV ECX, EDX - SAR ECX, 2 - JS @Exit - REP STOSD - MOV ECX, EDX - AND ECX, 3 - REP STOSB - POP EDI -@Exit: -end; -{$ELSE} -begin - FillChar(Data^, Size, Value); -end; -{$ENDIF} - -procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word); -{$IFDEF USE_ASM} -asm - PUSH EDI - PUSH EBX - MOV EBX, EDX - MOV EDI, EAX - MOV EAX, ECX - MOV CX, AX - SHL EAX, 16 - MOV AX, CX - MOV ECX, EDX - SHR ECX, 2 - JZ @Word - REP STOSD -@Word: - MOV ECX, EBX - AND ECX, 2 - JZ @Byte - MOV [EDI], AX - ADD EDI, 2 -@Byte: - MOV ECX, EBX - AND ECX, 1 - JZ @Exit - MOV [EDI], AL -@Exit: - POP EBX - POP EDI -end; -{$ELSE} -var - I, V: LongWord; -begin - V := Value * $10000 + Value; - for I := 0 to Size div 4 - 1 do - PLongWordArray(Data)[I] := V; - case Size mod 4 of - 1: PByteArray(Data)[Size - 1] := Lo(Value); - 2: PWordArray(Data)[Size div 2] := Value; - 3: - begin - PWordArray(Data)[Size div 2 - 1] := Value; - PByteArray(Data)[Size - 1] := Lo(Value); - end; - end; -end; -{$ENDIF} - -procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord); -{$IFDEF USE_ASM} -asm - PUSH EDI - PUSH EBX - MOV EBX, EDX - MOV EDI, EAX - MOV EAX, ECX - MOV ECX, EDX - SHR ECX, 2 - JZ @Word - REP STOSD -@Word: - MOV ECX, EBX - AND ECX, 2 - JZ @Byte - MOV [EDI], AX - ADD EDI, 2 -@Byte: - MOV ECX, EBX - AND ECX, 1 - JZ @Exit - MOV [EDI], AL -@Exit: - POP EBX - POP EDI -end; -{$ELSE} -var - I: LongInt; -begin - for I := 0 to Size div 4 - 1 do - PLongWordArray(Data)[I] := Value; - case Size mod 4 of - 1: PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0]; - 2: PWordArray(Data)[Size div 2] := TLongWordRec(Value).Words[0]; - 3: - begin - PWordArray(Data)[Size div 2 - 1] := TLongWordRec(Value).Words[0]; - PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0]; - end; - end; -end; -{$ENDIF} - -function GetNumMipMapLevels(Width, Height: LongInt): LongInt; -begin - Result := 0; - if (Width > 0) and (Height > 0) then - begin - Result := 1; - while (Width <> 1) or (Height <> 1) do - begin - Width := Width div 2; - Height := Height div 2; - if Width < 1 then Width := 1; - if Height < 1 then Height := 1; - Inc(Result); - end; - end; -end; - -function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt; +end; + +function SwapEndianWord(Value: Word): Word; +{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))} +asm + XCHG AH, AL +end; +{$ELSE} +begin + TWordRec(Result).Low := TWordRec(Value).High; + TWordRec(Result).High := TWordRec(Value).Low; +end; +{$IFEND} + +procedure SwapEndianWord(P: PWordArray; Count: LongInt); +{$IFDEF USE_ASM} +asm +@Loop: + MOV CX, [EAX] + XCHG CH, CL + MOV [EAX], CX + ADD EAX, 2 + DEC EDX + JNZ @Loop +end; +{$ELSE} +var + I: LongInt; + Temp: Word; +begin + for I := 0 to Count - 1 do + begin + Temp := P[I]; + TWordRec(P[I]).Low := TWordRec(Temp).High; + TWordRec(P[I]).High := TWordRec(Temp).Low; + end; +end; +{$ENDIF} + +function SwapEndianUInt32(Value: UInt32): UInt32; +{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))} +asm + BSWAP EAX +end; +{$ELSE} +begin + TUInt32Rec(Result).Bytes[0] := TUInt32Rec(Value).Bytes[3]; + TUInt32Rec(Result).Bytes[1] := TUInt32Rec(Value).Bytes[2]; + TUInt32Rec(Result).Bytes[2] := TUInt32Rec(Value).Bytes[1]; + TUInt32Rec(Result).Bytes[3] := TUInt32Rec(Value).Bytes[0]; +end; +{$IFEND} + +procedure SwapEndianUInt32(P: PUInt32; Count: LongInt); +{$IFDEF USE_ASM} +asm +@Loop: + MOV ECX, [EAX] + BSWAP ECX + MOV [EAX], ECX + ADD EAX, 4 + DEC EDX + JNZ @Loop +end; +{$ELSE} +var + I: LongInt; + Temp: UInt32; +begin + for I := 0 to Count - 1 do + begin + Temp := PUInt32Array(P)[I]; + TUInt32Rec(PUInt32Array(P)[I]).Bytes[0] := TUInt32Rec(Temp).Bytes[3]; + TUInt32Rec(PUInt32Array(P)[I]).Bytes[1] := TUInt32Rec(Temp).Bytes[2]; + TUInt32Rec(PUInt32Array(P)[I]).Bytes[2] := TUInt32Rec(Temp).Bytes[1]; + TUInt32Rec(PUInt32Array(P)[I]).Bytes[3] := TUInt32Rec(Temp).Bytes[0]; + end; +end; +{$ENDIF} + +type + TCrcTable = array[Byte] of UInt32; +var + CrcTable: TCrcTable; + +procedure InitCrcTable; +const + Polynom = $EDB88320; +var + I, J: LongInt; + C: UInt32; +begin + for I := 0 to 255 do + begin + C := I; + for J := 0 to 7 do + begin + if (C and $01) <> 0 then + C := Polynom xor (C shr 1) + else + C := C shr 1; + end; + CrcTable[I] := C; + end; +end; + +procedure CalcCrc32(var Crc: UInt32; Data: Pointer; Size: LongInt); +var + I: LongInt; + B: PByte; +begin + B := Data; + for I := 0 to Size - 1 do + begin + Crc := (Crc shr 8) xor CrcTable[B^ xor Byte(Crc)]; + Inc(B); + end +end; + +procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte); +{$IFDEF USE_ASM} +asm + PUSH EDI + MOV EDI, EAX + MOV EAX, ECX + MOV AH, AL + MOV CX, AX + SHL EAX, 16 + MOV AX, CX + MOV ECX, EDX + SAR ECX, 2 + JS @Exit + REP STOSD + MOV ECX, EDX + AND ECX, 3 + REP STOSB + POP EDI +@Exit: +end; +{$ELSE} +begin + FillChar(Data^, Size, Value); +end; +{$ENDIF} + +procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word); +{$IFDEF USE_ASM} +asm + PUSH EDI + PUSH EBX + MOV EBX, EDX + MOV EDI, EAX + MOV EAX, ECX + MOV CX, AX + SHL EAX, 16 + MOV AX, CX + MOV ECX, EDX + SHR ECX, 2 + JZ @Word + REP STOSD +@Word: + MOV ECX, EBX + AND ECX, 2 + JZ @Byte + MOV [EDI], AX + ADD EDI, 2 +@Byte: + MOV ECX, EBX + AND ECX, 1 + JZ @Exit + MOV [EDI], AL +@Exit: + POP EBX + POP EDI +end; +{$ELSE} +var + I, V: UInt32; +begin + V := Value * $10000 + Value; + for I := 0 to Size div 4 - 1 do + PUInt32Array(Data)[I] := V; + case Size mod 4 of + 1: PByteArray(Data)[Size - 1] := Lo(Value); + 2: PWordArray(Data)[Size div 2] := Value; + 3: + begin + PWordArray(Data)[Size div 2 - 1] := Value; + PByteArray(Data)[Size - 1] := Lo(Value); + end; + end; +end; +{$ENDIF} + +procedure FillMemoryUInt32(Data: Pointer; Size: LongInt; Value: UInt32); +{$IFDEF USE_ASM} +asm + PUSH EDI + PUSH EBX + MOV EBX, EDX + MOV EDI, EAX + MOV EAX, ECX + MOV ECX, EDX + SHR ECX, 2 + JZ @Word + REP STOSD +@Word: + MOV ECX, EBX + AND ECX, 2 + JZ @Byte + MOV [EDI], AX + ADD EDI, 2 +@Byte: + MOV ECX, EBX + AND ECX, 1 + JZ @Exit + MOV [EDI], AL +@Exit: + POP EBX + POP EDI +end; +{$ELSE} +var + I: LongInt; +begin + for I := 0 to Size div 4 - 1 do + PUInt32Array(Data)[I] := Value; + case Size mod 4 of + 1: PByteArray(Data)[Size - 1] := TUInt32Rec(Value).Bytes[0]; + 2: PWordArray(Data)[Size div 2] := TUInt32Rec(Value).Words[0]; + 3: + begin + PWordArray(Data)[Size div 2 - 1] := TUInt32Rec(Value).Words[0]; + PByteArray(Data)[Size - 1] := TUInt32Rec(Value).Bytes[0]; + end; + end; +end; +{$ENDIF} + +procedure ZeroMemory(Data: Pointer; Size: Integer); +begin + FillMemoryByte(Data, Size, 0); +end; + +function GetNumMipMapLevels(Width, Height: LongInt): LongInt; +begin + Result := 0; + if (Width > 0) and (Height > 0) then + begin + Result := 1; + while (Width <> 1) or (Height <> 1) do + begin + Width := Width div 2; + Height := Height div 2; + if Width < 1 then Width := 1; + if Height < 1 then Height := 1; + Inc(Result); + end; + end; +end; + +function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt; var I: LongInt; begin Result := Depth; for I := 1 to MipMaps - 1 do Inc(Result, ClampInt(Depth shr I, 1, Depth)); -end; - -function BoundsToRect(X, Y, Width, Height: LongInt): TRect; -begin - Result.Left := X; - Result.Top := Y; - Result.Right := X + Width; - Result.Bottom := Y + Height; -end; - -function BoundsToRect(const R: TRect): TRect; -begin - Result.Left := R.Left; - Result.Top := R.Top; - Result.Right := R.Left + R.Right; - Result.Bottom := R.Top + R.Bottom; -end; - -function RectToBounds(const R: TRect): TRect; -begin - Result.Left := R.Left; - Result.Top := R.Top; - Result.Right := R.Right - R.Left; - Result.Bottom := R.Bottom - R.Top; -end; - -procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect); - - procedure ClipDim(var AStart, ALength: LongInt; ClipMin, ClipMax: LongInt); - begin - if AStart < ClipMin then - begin - ALength := ALength - (ClipMin - AStart); - AStart := ClipMin; - end; - if AStart + ALength > ClipMax then ALength := Max(0, ClipMax - AStart); - end; - -begin - ClipDim(X, Width, Clip.Left, Clip.Right); - ClipDim(Y, Height, Clip.Top, Clip.Bottom); -end; - -procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect); - - procedure ClipDim(var SrcPos, DstPos, Size: LongInt; SrcClipMax, - DstClipMin, DstClipMax: LongInt); - var - OldDstPos: LongInt; - Diff: LongInt; - begin - OldDstPos := Iff(DstPos < 0, DstPos, 0); - if DstPos < DstClipMin then - begin - Diff := DstClipMin - DstPos; - Size := Size - Diff; - SrcPos := SrcPos + Diff; - DstPos := DstClipMin; - end; - if SrcPos < 0 then - begin - Size := Size + SrcPos - OldDstPos; - DstPos := DstPos - SrcPos + OldDstPos; - SrcPos := 0; - end; - if SrcPos + Size > SrcClipMax then Size := SrcClipMax - SrcPos; - if DstPos + Size > DstClipMax then Size := DstClipMax - DstPos; - end; - -begin - ClipDim(SrcX, DstX, Width, SrcImageWidth, DstClip.Left, DstClip.Right); - ClipDim(SrcY, DstY, Height, SrcImageHeight, DstClip.Top, DstClip.Bottom); -end; - -procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY, - DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect); - - procedure ClipDim(var SrcPos, DstPos, SrcSize, DstSize: LongInt; SrcClipMax, - DstClipMin, DstClipMax: LongInt); - var - OldSize: LongInt; - Diff: LongInt; - Scale: Single; - begin - Scale := DstSize / SrcSize; - if DstPos < DstClipMin then - begin - Diff := DstClipMin - DstPos; - DstSize := DstSize - Diff; - SrcPos := SrcPos + Round(Diff / Scale); - SrcSize := SrcSize - Round(Diff / Scale); - DstPos := DstClipMin; - end; - if SrcPos < 0 then - begin - SrcSize := SrcSize + SrcPos; - DstPos := DstPos - Round(SrcPos * Scale); - DstSize := DstSize + Round(SrcPos * Scale); - SrcPos := 0; - end; - if SrcPos + SrcSize > SrcClipMax then - begin - OldSize := SrcSize; - SrcSize := SrcClipMax - SrcPos; - DstSize := Round(DstSize * (SrcSize / OldSize)); - end; - if DstPos + DstSize > DstClipMax then - begin - OldSize := DstSize; - DstSize := DstClipMax - DstPos; - SrcSize := Round(SrcSize * (DstSize / OldSize)); - end; - end; - -begin - ClipDim(SrcX, DstX, SrcWidth, DstWidth, SrcImageWidth, DstClip.Left, DstClip.Right); - ClipDim(SrcY, DstY, SrcHeight, DstHeight, SrcImageHeight, DstClip.Top, DstClip.Bottom); -end; - -function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect; -var - SourceWidth: LongInt; - SourceHeight: LongInt; - TargetWidth: LongInt; - TargetHeight: LongInt; - ScaledWidth: LongInt; - ScaledHeight: LongInt; -begin - SourceWidth := SourceRect.Right - SourceRect.Left; - SourceHeight := SourceRect.Bottom - SourceRect.Top; - TargetWidth := TargetRect.Right - TargetRect.Left; - TargetHeight := TargetRect.Bottom - TargetRect.Top; - - if SourceWidth * TargetHeight < SourceHeight * TargetWidth then - begin - ScaledWidth := (SourceWidth * TargetHeight) div SourceHeight; - Result := BoundsToRect(TargetRect.Left + ((TargetWidth - ScaledWidth) div 2), - TargetRect.Top, ScaledWidth, TargetHeight); - end - else - begin - ScaledHeight := (SourceHeight * TargetWidth) div SourceWidth; - Result := BoundsToRect(TargetRect.Left, TargetRect.Top + ((TargetHeight - ScaledHeight) div 2), - TargetWidth, ScaledHeight); - end; -end; - -function RectInRect(const R1, R2: TRect): Boolean; +end; + +function BoundsToRect(X, Y, Width, Height: LongInt): TRect; +begin + Result.Left := X; + Result.Top := Y; + Result.Right := X + Width; + Result.Bottom := Y + Height; +end; + +function BoundsToRect(const R: TRect): TRect; +begin + Result.Left := R.Left; + Result.Top := R.Top; + Result.Right := R.Left + R.Right; + Result.Bottom := R.Top + R.Bottom; +end; + +function RectToBounds(const R: TRect): TRect; +begin + Result.Left := R.Left; + Result.Top := R.Top; + Result.Right := R.Right - R.Left; + Result.Bottom := R.Bottom - R.Top; +end; + +procedure ClipRectBounds(var X, Y, Width, Height: LongInt; const Clip: TRect); + + procedure ClipDim(var AStart, ALength: LongInt; ClipMin, ClipMax: LongInt); + begin + if AStart < ClipMin then + begin + ALength := ALength - (ClipMin - AStart); + AStart := ClipMin; + end; + if AStart + ALength > ClipMax then ALength := Max(0, ClipMax - AStart); + end; + +begin + ClipDim(X, Width, Clip.Left, Clip.Right); + ClipDim(Y, Height, Clip.Top, Clip.Bottom); +end; + +procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect); + + procedure ClipDim(var SrcPos, DstPos, Size: LongInt; SrcClipMax, + DstClipMin, DstClipMax: LongInt); + var + OldDstPos: LongInt; + Diff: LongInt; + begin + OldDstPos := Iff(DstPos < 0, DstPos, 0); + if DstPos < DstClipMin then + begin + Diff := DstClipMin - DstPos; + Size := Size - Diff; + SrcPos := SrcPos + Diff; + DstPos := DstClipMin; + end; + if SrcPos < 0 then + begin + Size := Size + SrcPos - OldDstPos; + DstPos := DstPos - SrcPos + OldDstPos; + SrcPos := 0; + end; + if SrcPos + Size > SrcClipMax then Size := SrcClipMax - SrcPos; + if DstPos + Size > DstClipMax then Size := DstClipMax - DstPos; + end; + +begin + ClipDim(SrcX, DstX, Width, SrcImageWidth, DstClip.Left, DstClip.Right); + ClipDim(SrcY, DstY, Height, SrcImageHeight, DstClip.Top, DstClip.Bottom); +end; + +procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY, + DstWidth, DstHeight: LongInt; SrcImageWidth, SrcImageHeight: LongInt; const DstClip: TRect); + + procedure ClipDim(var SrcPos, DstPos, SrcSize, DstSize: LongInt; SrcClipMax, + DstClipMin, DstClipMax: LongInt); + var + OldSize: LongInt; + Diff: LongInt; + Scale: Single; + begin + Scale := DstSize / SrcSize; + if DstPos < DstClipMin then + begin + Diff := DstClipMin - DstPos; + DstSize := DstSize - Diff; + SrcPos := SrcPos + Round(Diff / Scale); + SrcSize := SrcSize - Round(Diff / Scale); + DstPos := DstClipMin; + end; + if SrcPos < 0 then + begin + SrcSize := SrcSize + SrcPos; + DstPos := DstPos - Round(SrcPos * Scale); + DstSize := DstSize + Round(SrcPos * Scale); + SrcPos := 0; + end; + if SrcPos + SrcSize > SrcClipMax then + begin + OldSize := SrcSize; + SrcSize := SrcClipMax - SrcPos; + DstSize := Round(DstSize * (SrcSize / OldSize)); + end; + if DstPos + DstSize > DstClipMax then + begin + OldSize := DstSize; + DstSize := DstClipMax - DstPos; + SrcSize := Round(SrcSize * (DstSize / OldSize)); + end; + end; + +begin + ClipDim(SrcX, DstX, SrcWidth, DstWidth, SrcImageWidth, DstClip.Left, DstClip.Right); + ClipDim(SrcY, DstY, SrcHeight, DstHeight, SrcImageHeight, DstClip.Top, DstClip.Bottom); +end; + +function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect; +var + SourceWidth: LongInt; + SourceHeight: LongInt; + TargetWidth: LongInt; + TargetHeight: LongInt; + ScaledWidth: LongInt; + ScaledHeight: LongInt; +begin + SourceWidth := SourceRect.Right - SourceRect.Left; + SourceHeight := SourceRect.Bottom - SourceRect.Top; + TargetWidth := TargetRect.Right - TargetRect.Left; + TargetHeight := TargetRect.Bottom - TargetRect.Top; + + if SourceWidth * TargetHeight < SourceHeight * TargetWidth then + begin + ScaledWidth := (SourceWidth * TargetHeight) div SourceHeight; + Result := BoundsToRect(TargetRect.Left + ((TargetWidth - ScaledWidth) div 2), + TargetRect.Top, ScaledWidth, TargetHeight); + end + else + begin + ScaledHeight := (SourceHeight * TargetWidth) div SourceWidth; + Result := BoundsToRect(TargetRect.Left, TargetRect.Top + ((TargetHeight - ScaledHeight) div 2), + TargetWidth, ScaledHeight); + end; +end; + +function ScaleSizeToFit(const CurrentSize, MaxSize: Types.TSize): Types.TSize; +var + SR, TR, ScaledRect: TRect; +begin + SR := Types.Rect(0, 0, CurrentSize.CX, CurrentSize.CY); + TR := Types.Rect(0, 0, MaxSize.CX, MaxSize.CY); + ScaledRect := ScaleRectToRect(SR, TR); + Result.CX := ScaledRect.Right - ScaledRect.Left; + Result.CY := ScaledRect.Bottom - ScaledRect.Top; +end; + +function RectWidth(const Rect: TRect): Integer; +begin + Result := Rect.Right - Rect.Left; +end; + +function RectHeight(const Rect: TRect): Integer; +begin + Result := Rect.Bottom - Rect.Top; +end; + +function RectInRect(const R1, R2: TRect): Boolean; begin Result:= (R1.Left >= R2.Left) and (R1.Top >= R2.Top) and (R1.Right <= R2.Right) and (R1.Bottom <= R2.Bottom); -end; - -function RectIntersects(const R1, R2: TRect): Boolean; -begin +end; + +function RectIntersects(const R1, R2: TRect): Boolean; +begin Result := not (R1.Left > R2.Right) and not (R1.Top > R2.Bottom) and not (R1.Right < R2.Left) and not (R1.Bottom < R2.Top); end; - -function FormatExceptMsg(const Msg: string; const Args: array of const): string; -begin - Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args); + +procedure NormalizeRect(var R: TRect); +begin + if R.Right < R.Left then + SwapValues(R.Right, R.Left); + if R.Bottom < R.Top then + SwapValues(R.Bottom, R.Top); end; - -procedure DebugMsg(const Msg: string; const Args: array of const); -var - FmtMsg: string; -begin - FmtMsg := Format(Msg, Args); -{$IFDEF MSWINDOWS} - if IsConsole then - WriteLn('DebugMsg: ' + FmtMsg) - else - MessageBox(GetActiveWindow, PChar(FmtMsg), 'DebugMsg', MB_OK); -{$ENDIF} -{$IFDEF UNIX} - WriteLn('DebugMsg: ' + FmtMsg); -{$ENDIF} -{$IFDEF MSDOS} - WriteLn('DebugMsg: ' + FmtMsg); -{$ENDIF} -end; - -initialization - InitCrcTable; -{$IFDEF MSWINDOWS} - QueryPerformanceFrequency(PerfFrequency); - InvPerfFrequency := 1.0 / PerfFrequency; -{$ENDIF} -{$IFDEF MSDOS} - // reset PIT - asm - MOV EAX, $34 - OUT $43, AL - XOR EAX, EAX - OUT $40, AL - OUT $40, AL - end; -{$ENDIF} - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 0.26.1 Changes/Bug Fixes ----------------------------------- - - Some formatting changes. - - Changed some string functions to work with localized strings. - - ASM version of PosEx had bugs, removed it. - - Added StrTokensToList function. - - -- 0.25.0 Changes/Bug Fixes ----------------------------------- - - Fixed error in ClipCopyBounds which was causing ... bad clipping! - - -- 0.24.3 Changes/Bug Fixes ----------------------------------- - - Added GetTimeMilliseconds function. - - Added IntToStrFmt and FloatToStrFmt helper functions. - - -- 0.23 Changes/Bug Fixes ----------------------------------- - - Added RectInRect and RectIntersects functions - - Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase. - - Moved BuildFileList here from DemoUtils. - - -- 0.21 Changes/Bug Fixes ----------------------------------- - - Moved GetVolumeLevelCount from ImagingDds here. - - Renamed FillMemory to FillMemoryByte to avoid name collision in C++ Builder. - - Added Iff function for Char, Pointer, and Int64 types. - - Added IsLittleEndian function. - - Added array types for TWordRec, TLongWordRec, and TInt64Rec. - - Added MatchFileNameMask function. - - -- 0.19 Changes/Bug Fixes ----------------------------------- - - added ScaleRectToRect (thanks to Paul Michell) - - added BoundsToRect, ClipBounds, ClipCopyBounds, ClipStretchBounds functions - - added MulDiv function - - FreeAndNil is not inline anymore - caused AV in one program - - -- 0.17 Changes/Bug Fixes ----------------------------------- - - - GetAppExe didn't return absolute path in FreeBSD, fixed - - added debug message output - - fixed Unix compatibility issues (thanks to Ales Katona). - Imaging now compiles in FreeBSD and maybe in other Unixes as well. - - -- 0.15 Changes/Bug Fixes ----------------------------------- - - added some new utility functions - - -- 0.13 Changes/Bug Fixes ----------------------------------- - - added many new utility functions - - minor change in SwapEndian to avoid range check error - -} -end. - + +function PixelSizeToDpi(SizeInMicroMeters: Single): Single; +begin + Result := 25400 / SizeInMicroMeters; +end; + +function DpiToPixelSize(Dpi: Single): Single; +begin + Result := 1e03 / (Dpi / 25.4); +end; + +function FloatPoint(AX, AY: Single): TFloatPoint; +begin + Result.X := AX; + Result.Y := AY; +end; + +function FloatRect(ALeft, ATop, ARight, ABottom: Single): TFloatRect; +begin + with Result do + begin + Left := ALeft; + Top := ATop; + Right := ARight; + Bottom := ABottom; + end; +end; + +function FloatRectWidth(const R: TFloatRect): Single; +begin + Result := R.Right - R.Left; +end; + +function FloatRectHeight(const R: TFloatRect): Single; +begin + Result := R.Bottom - R.Top; +end; + +function FloatRectFromRect(const R: TRect): TFloatRect; +begin + Result := FloatRect(R.Left, R.Top, R.Right, R.Bottom); +end; + +function FormatExceptMsg(const Msg: string; const Args: array of const): string; +begin + Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args); +end; + +procedure DebugMsg(const Msg: string; const Args: array of const); +var + FmtMsg: string; +begin + FmtMsg := Format(Msg, Args); +{$IFDEF MSWINDOWS} + if IsConsole then + WriteLn('DebugMsg: ' + FmtMsg) + else + MessageBox(GetActiveWindow, PChar(FmtMsg), 'DebugMsg', MB_OK); +{$ENDIF} +{$IFDEF UNIX} + WriteLn('DebugMsg: ' + FmtMsg); +{$ENDIF} +{$IFDEF MSDOS} + WriteLn('DebugMsg: ' + FmtMsg); +{$ENDIF} +end; + +initialization + InitCrcTable; +{$IFDEF MSWINDOWS} + QueryPerformanceFrequency(PerfFrequency); + InvPerfFrequency := 1.0 / PerfFrequency; +{$ENDIF} + +{$IF Defined(DELPHI)} + {$IF CompilerVersion >= 23} + FloatFormatSettings := TFormatSettings.Create('en-US'); + {$ELSE} + GetLocaleFormatSettings(1033, FloatFormatSettings); + {$IFEND} +{$ELSE FPC} + FloatFormatSettings := DefaultFormatSettings; + FloatFormatSettings.DecimalSeparator := '.'; + FloatFormatSettings.ThousandSeparator := ','; +{$IFEND} + +{ + File Notes: + + -- 0.77.1 ---------------------------------------------------- + - Added GetFileName, GetFileDir, RectWidth, RectHeight function. + - Added ScaleSizeToFit function. + - Added ZeroMemory and SwapValues for Booleans. + - Added Substring function. + - Renamed MatchFileNameMask to StrMaskMatch (it's for general use not + just filenames). + - Delphi XE2 new targets (Win64, OSX32) compatibility changes. + - Added GetFormatSettingsForFloats function. + + -- 0.26.5 Changes/Bug Fixes ----------------------------------- + - Added Log10 function. + - Added TFloatRect type and helper functions FloatRect, FloatRectWidth, + FloatRectHeight. + - Added string function ContainsAnySubStr. + - Added functions PixelSizeToDpi, DpiToPixelSize. + + -- 0.26.1 Changes/Bug Fixes ----------------------------------- + - Some formatting changes. + - Changed some string functions to work with localized strings. + - ASM version of PosEx had bugs, removed it. + - Added StrTokensToList function. + + -- 0.25.0 Changes/Bug Fixes ----------------------------------- + - Fixed error in ClipCopyBounds which was causing ... bad clipping! + + -- 0.24.3 Changes/Bug Fixes ----------------------------------- + - Added GetTimeMilliseconds function. + - Added IntToStrFmt and FloatToStrFmt helper functions. + + -- 0.23 Changes/Bug Fixes ----------------------------------- + - Added RectInRect and RectIntersects functions + - Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase. + - Moved BuildFileList here from DemoUtils. + + -- 0.21 Changes/Bug Fixes ----------------------------------- + - Moved GetVolumeLevelCount from ImagingDds here. + - Renamed FillMemory to FillMemoryByte to avoid name collision in C++ Builder. + - Added Iff function for Char, Pointer, and Int64 types. + - Added IsLittleEndian function. + - Added array types for TWordRec, TLongWordRec, and TInt64Rec. + - Added MatchFileNameMask function. + + -- 0.19 Changes/Bug Fixes ----------------------------------- + - added ScaleRectToRect (thanks to Paul Michell) + - added BoundsToRect, ClipBounds, ClipCopyBounds, ClipStretchBounds functions + - added MulDiv function + - FreeAndNil is not inline anymore - caused AV in one program + + -- 0.17 Changes/Bug Fixes ----------------------------------- + + - GetAppExe didn't return absolute path in FreeBSD, fixed + - added debug message output + - fixed Unix compatibility issues (thanks to Ales Katona). + Imaging now compiles in FreeBSD and maybe in other Unixes as well. + + -- 0.15 Changes/Bug Fixes ----------------------------------- + - added some new utility functions + + -- 0.13 Changes/Bug Fixes ----------------------------------- + - added many new utility functions + - minor change in SwapEndian to avoid range check error + +} +end. + + diff --git a/Imaging/JpegLib/imjcapimin.pas b/Imaging/JpegLib/imjcapimin.pas index 8a82075..581839b 100644 --- a/Imaging/JpegLib/imjcapimin.pas +++ b/Imaging/JpegLib/imjcapimin.pas @@ -1,401 +1,400 @@ -unit imjcapimin; -{$N+} -{ This file contains application interface code for the compression half - of the JPEG library. These are the "minimum" API routines that may be - needed in either the normal full-compression case or the transcoding-only - case. - - Most of the routines intended to be called directly by an application - are in this file or in jcapistd.c. But also see jcparam.c for - parameter-setup helper routines, jcomapi.c for routines shared by - compression and decompression, and jctrans.c for the transcoding case. } - -{ jcapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. } - - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjpeglib, - imjcomapi, - imjmemmgr, - imjcmarker; - -{ Initialization of JPEG compression objects. - Nomssi: This is a macro in the original code. - - jpeg_create_compress() and jpeg_create_decompress() are the exported - names that applications should call. These expand to calls on - jpeg_CreateCompress and jpeg_CreateDecompress with additional information - passed for version mismatch checking. - NB: you must set up the error-manager BEFORE calling jpeg_create_xxx. } - -procedure jpeg_create_compress(cinfo : j_compress_ptr); - - -{ Initialization of a JPEG compression object. - The error manager must already be set up (in case memory manager fails). } - -{GLOBAL} -procedure jpeg_CreateCompress (cinfo : j_compress_ptr; - version : int; - structsize : size_t); - -{ Destruction of a JPEG compression object } - -{GLOBAL} -procedure jpeg_destroy_compress (cinfo : j_compress_ptr); - - -{ Abort processing of a JPEG compression operation, - but don't destroy the object itself. } - -{GLOBAL} -procedure jpeg_abort_compress (cinfo : j_compress_ptr); - - -{ Forcibly suppress or un-suppress all quantization and Huffman tables. - Marks all currently defined tables as already written (if suppress) - or not written (if !suppress). This will control whether they get emitted - by a subsequent jpeg_start_compress call. - - This routine is exported for use by applications that want to produce - abbreviated JPEG datastreams. It logically belongs in jcparam.c, but - since it is called by jpeg_start_compress, we put it here --- otherwise - jcparam.o would be linked whether the application used it or not. } - -{GLOBAL} -procedure jpeg_suppress_tables (cinfo : j_compress_ptr; - suppress : boolean); - - -{ Finish JPEG compression. - - If a multipass operating mode was selected, this may do a great deal of - work including most of the actual output. } - -{GLOBAL} -procedure jpeg_finish_compress (cinfo : j_compress_ptr); - -{ Write a special marker. - This is only recommended for writing COM or APPn markers. - Must be called after jpeg_start_compress() and before - first call to jpeg_write_scanlines() or jpeg_write_raw_data(). } - -{GLOBAL} -procedure jpeg_write_marker (cinfo : j_compress_ptr; - marker : int; - dataptr : JOCTETptr; - datalen : uInt); - -{GLOBAL} -procedure jpeg_write_m_header (cinfo : j_compress_ptr; - marker : int; - datalen : uint); -{GLOBAL} -procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int); - -{ Alternate compression function: just write an abbreviated table file. - Before calling this, all parameters and a data destination must be set up. - - To produce a pair of files containing abbreviated tables and abbreviated - image data, one would proceed as follows: - - initialize JPEG object - set JPEG parameters - set destination to table file - jpeg_write_tables(cinfo); - set destination to image file - jpeg_start_compress(cinfo, FALSE); - write data... - jpeg_finish_compress(cinfo); - - jpeg_write_tables has the side effect of marking all tables written - (same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress - will not re-emit the tables unless it is passed write_all_tables=TRUE. } - - - -{GLOBAL} -procedure jpeg_write_tables (cinfo : j_compress_ptr); - -implementation - -procedure jpeg_create_compress(cinfo : j_compress_ptr); -begin - jpeg_CreateCompress(cinfo, JPEG_LIB_VERSION, - size_t(sizeof(jpeg_compress_struct))); -end; - -{ Initialization of a JPEG compression object. - The error manager must already be set up (in case memory manager fails). } - -{GLOBAL} -procedure jpeg_CreateCompress (cinfo : j_compress_ptr; - version : int; - structsize : size_t); -var - i : int; -var - err : jpeg_error_mgr_ptr; - client_data : voidp; -begin - - { Guard against version mismatches between library and caller. } - cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called } - if (version <> JPEG_LIB_VERSION) then - ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version); - if (structsize <> SIZEOF(jpeg_compress_struct)) then - ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE, - int(SIZEOF(jpeg_compress_struct)), int(structsize)); - - { For debugging purposes, we zero the whole master structure. - But the application has already set the err pointer, and may have set - client_data, so we have to save and restore those fields. - Note: if application hasn't set client_data, tools like Purify may - complain here. } - - err := cinfo^.err; - client_data := cinfo^.client_data; { ignore Purify complaint here } - MEMZERO(cinfo, SIZEOF(jpeg_compress_struct)); - cinfo^.err := err; - cinfo^.is_decompressor := FALSE; - - { Initialize a memory manager instance for this object } - jinit_memory_mgr(j_common_ptr(cinfo)); - - { Zero out pointers to permanent structures. } - cinfo^.progress := NIL; - cinfo^.dest := NIL; - - cinfo^.comp_info := NIL; - - for i := 0 to pred(NUM_QUANT_TBLS) do - cinfo^.quant_tbl_ptrs[i] := NIL; - - for i := 0 to pred(NUM_HUFF_TBLS) do - begin - cinfo^.dc_huff_tbl_ptrs[i] := NIL; - cinfo^.ac_huff_tbl_ptrs[i] := NIL; - end; - - cinfo^.script_space := NIL; - - cinfo^.input_gamma := 1.0; { in case application forgets } - - { OK, I'm ready } - cinfo^.global_state := CSTATE_START; -end; - - -{ Destruction of a JPEG compression object } - -{GLOBAL} -procedure jpeg_destroy_compress (cinfo : j_compress_ptr); -begin - jpeg_destroy(j_common_ptr(cinfo)); { use common routine } -end; - - -{ Abort processing of a JPEG compression operation, - but don't destroy the object itself. } - -{GLOBAL} -procedure jpeg_abort_compress (cinfo : j_compress_ptr); -begin - jpeg_abort(j_common_ptr(cinfo)); { use common routine } -end; - - -{ Forcibly suppress or un-suppress all quantization and Huffman tables. - Marks all currently defined tables as already written (if suppress) - or not written (if !suppress). This will control whether they get emitted - by a subsequent jpeg_start_compress call. - - This routine is exported for use by applications that want to produce - abbreviated JPEG datastreams. It logically belongs in jcparam.c, but - since it is called by jpeg_start_compress, we put it here --- otherwise - jcparam.o would be linked whether the application used it or not. } - -{GLOBAL} -procedure jpeg_suppress_tables (cinfo : j_compress_ptr; - suppress : boolean); -var - i : int; - qtbl : JQUANT_TBL_PTR; - htbl : JHUFF_TBL_PTR; -begin - for i := 0 to pred(NUM_QUANT_TBLS) do - begin - qtbl := cinfo^.quant_tbl_ptrs[i]; - if (qtbl <> NIL) then - qtbl^.sent_table := suppress; - end; - - for i := 0 to pred(NUM_HUFF_TBLS) do - begin - htbl := cinfo^.dc_huff_tbl_ptrs[i]; - if (htbl <> NIL) then - htbl^.sent_table := suppress; - htbl := cinfo^.ac_huff_tbl_ptrs[i]; - if (htbl <> NIL) then - htbl^.sent_table := suppress; - end; -end; - - -{ Finish JPEG compression. - - If a multipass operating mode was selected, this may do a great deal of - work including most of the actual output. } - -{GLOBAL} -procedure jpeg_finish_compress (cinfo : j_compress_ptr); -var - iMCU_row : JDIMENSION; -begin - if (cinfo^.global_state = CSTATE_SCANNING) or - (cinfo^.global_state = CSTATE_RAW_OK) then - begin - { Terminate first pass } - if (cinfo^.next_scanline < cinfo^.image_height) then - ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA); - cinfo^.master^.finish_pass (cinfo); - end - else - if (cinfo^.global_state <> CSTATE_WRCOEFS) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - { Perform any remaining passes } - while (not cinfo^.master^.is_last_pass) do - begin - cinfo^.master^.prepare_for_pass (cinfo); - for iMCU_row := 0 to pred(cinfo^.total_iMCU_rows) do - begin - if (cinfo^.progress <> NIL) then - begin - cinfo^.progress^.pass_counter := long (iMCU_row); - cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows); - cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); - end; - { We bypass the main controller and invoke coef controller directly; - all work is being done from the coefficient buffer. } - - if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(NIL))) then - ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND); - end; - cinfo^.master^.finish_pass (cinfo); - end; - { Write EOI, do final cleanup } - cinfo^.marker^.write_file_trailer (cinfo); - cinfo^.dest^.term_destination (cinfo); - { We can use jpeg_abort to release memory and reset global_state } - jpeg_abort(j_common_ptr(cinfo)); -end; - - -{ Write a special marker. - This is only recommended for writing COM or APPn markers. - Must be called after jpeg_start_compress() and before - first call to jpeg_write_scanlines() or jpeg_write_raw_data(). } - -{GLOBAL} -procedure jpeg_write_marker (cinfo : j_compress_ptr; - marker : int; - dataptr : JOCTETptr; - datalen : uInt); -var - write_marker_byte : procedure(info : j_compress_ptr; val : int); -begin - if (cinfo^.next_scanline <> 0) or - ((cinfo^.global_state <> CSTATE_SCANNING) and - (cinfo^.global_state <> CSTATE_RAW_OK) and - (cinfo^.global_state <> CSTATE_WRCOEFS)) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - - cinfo^.marker^.write_marker_header (cinfo, marker, datalen); - write_marker_byte := cinfo^.marker^.write_marker_byte; { copy for speed } - while (datalen <> 0) do - begin - Dec(datalen); - write_marker_byte (cinfo, dataptr^); - Inc(dataptr); - end; -end; - -{ Same, but piecemeal. } - -{GLOBAL} -procedure jpeg_write_m_header (cinfo : j_compress_ptr; - marker : int; - datalen : uint); -begin - if (cinfo^.next_scanline <> 0) or - ((cinfo^.global_state <> CSTATE_SCANNING) and - (cinfo^.global_state <> CSTATE_RAW_OK) and - (cinfo^.global_state <> CSTATE_WRCOEFS)) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - - cinfo^.marker^.write_marker_header (cinfo, marker, datalen); -end; - -{GLOBAL} -procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int); -begin - cinfo^.marker^.write_marker_byte (cinfo, val); -end; - - -{ Alternate compression function: just write an abbreviated table file. - Before calling this, all parameters and a data destination must be set up. - - To produce a pair of files containing abbreviated tables and abbreviated - image data, one would proceed as follows: - - initialize JPEG object - set JPEG parameters - set destination to table file - jpeg_write_tables(cinfo); - set destination to image file - jpeg_start_compress(cinfo, FALSE); - write data... - jpeg_finish_compress(cinfo); - - jpeg_write_tables has the side effect of marking all tables written - (same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress - will not re-emit the tables unless it is passed write_all_tables=TRUE. } - -{GLOBAL} -procedure jpeg_write_tables (cinfo : j_compress_ptr); -begin - if (cinfo^.global_state <> CSTATE_START) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - - { (Re)initialize error mgr and destination modules } - cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo)); - cinfo^.dest^.init_destination (cinfo); - { Initialize the marker writer ... bit of a crock to do it here. } - jinit_marker_writer(cinfo); - { Write them tables! } - cinfo^.marker^.write_tables_only (cinfo); - { And clean up. } - cinfo^.dest^.term_destination (cinfo); - - { In library releases up through v6a, we called jpeg_abort() here to free - any working memory allocated by the destination manager and marker - writer. Some applications had a problem with that: they allocated space - of their own from the library memory manager, and didn't want it to go - away during write_tables. So now we do nothing. This will cause a - memory leak if an app calls write_tables repeatedly without doing a full - compression cycle or otherwise resetting the JPEG object. However, that - seems less bad than unexpectedly freeing memory in the normal case. - An app that prefers the old behavior can call jpeg_abort for itself after - each call to jpeg_write_tables(). } -end; - -end. +unit imjcapimin; + +{ This file contains application interface code for the compression half + of the JPEG library. These are the "minimum" API routines that may be + needed in either the normal full-compression case or the transcoding-only + case. + + Most of the routines intended to be called directly by an application + are in this file or in jcapistd.c. But also see jcparam.c for + parameter-setup helper routines, jcomapi.c for routines shared by + compression and decompression, and jctrans.c for the transcoding case. } + +{ jcapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. } + + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjpeglib, + imjcomapi, + imjmemmgr, + imjcmarker; + +{ Initialization of JPEG compression objects. + Nomssi: This is a macro in the original code. + + jpeg_create_compress() and jpeg_create_decompress() are the exported + names that applications should call. These expand to calls on + jpeg_CreateCompress and jpeg_CreateDecompress with additional information + passed for version mismatch checking. + NB: you must set up the error-manager BEFORE calling jpeg_create_xxx. } + +procedure jpeg_create_compress(cinfo : j_compress_ptr); + + +{ Initialization of a JPEG compression object. + The error manager must already be set up (in case memory manager fails). } + +{GLOBAL} +procedure jpeg_CreateCompress (cinfo : j_compress_ptr; + version : int; + structsize : size_t); + +{ Destruction of a JPEG compression object } + +{GLOBAL} +procedure jpeg_destroy_compress (cinfo : j_compress_ptr); + + +{ Abort processing of a JPEG compression operation, + but don't destroy the object itself. } + +{GLOBAL} +procedure jpeg_abort_compress (cinfo : j_compress_ptr); + + +{ Forcibly suppress or un-suppress all quantization and Huffman tables. + Marks all currently defined tables as already written (if suppress) + or not written (if !suppress). This will control whether they get emitted + by a subsequent jpeg_start_compress call. + + This routine is exported for use by applications that want to produce + abbreviated JPEG datastreams. It logically belongs in jcparam.c, but + since it is called by jpeg_start_compress, we put it here --- otherwise + jcparam.o would be linked whether the application used it or not. } + +{GLOBAL} +procedure jpeg_suppress_tables (cinfo : j_compress_ptr; + suppress : boolean); + + +{ Finish JPEG compression. + + If a multipass operating mode was selected, this may do a great deal of + work including most of the actual output. } + +{GLOBAL} +procedure jpeg_finish_compress (cinfo : j_compress_ptr); + +{ Write a special marker. + This is only recommended for writing COM or APPn markers. + Must be called after jpeg_start_compress() and before + first call to jpeg_write_scanlines() or jpeg_write_raw_data(). } + +{GLOBAL} +procedure jpeg_write_marker (cinfo : j_compress_ptr; + marker : int; + dataptr : JOCTETptr; + datalen : uInt); + +{GLOBAL} +procedure jpeg_write_m_header (cinfo : j_compress_ptr; + marker : int; + datalen : uint); +{GLOBAL} +procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int); + +{ Alternate compression function: just write an abbreviated table file. + Before calling this, all parameters and a data destination must be set up. + + To produce a pair of files containing abbreviated tables and abbreviated + image data, one would proceed as follows: + + initialize JPEG object + set JPEG parameters + set destination to table file + jpeg_write_tables(cinfo); + set destination to image file + jpeg_start_compress(cinfo, FALSE); + write data... + jpeg_finish_compress(cinfo); + + jpeg_write_tables has the side effect of marking all tables written + (same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress + will not re-emit the tables unless it is passed write_all_tables=TRUE. } + + + +{GLOBAL} +procedure jpeg_write_tables (cinfo : j_compress_ptr); + +implementation + +procedure jpeg_create_compress(cinfo : j_compress_ptr); +begin + jpeg_CreateCompress(cinfo, JPEG_LIB_VERSION, + size_t(sizeof(jpeg_compress_struct))); +end; + +{ Initialization of a JPEG compression object. + The error manager must already be set up (in case memory manager fails). } + +{GLOBAL} +procedure jpeg_CreateCompress (cinfo : j_compress_ptr; + version : int; + structsize : size_t); +var + i : int; +var + err : jpeg_error_mgr_ptr; + client_data : voidp; +begin + + { Guard against version mismatches between library and caller. } + cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called } + if (version <> JPEG_LIB_VERSION) then + ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version); + if (structsize <> SIZEOF(jpeg_compress_struct)) then + ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE, + int(SIZEOF(jpeg_compress_struct)), int(structsize)); + + { For debugging purposes, we zero the whole master structure. + But the application has already set the err pointer, and may have set + client_data, so we have to save and restore those fields. } + + err := cinfo^.err; + client_data := cinfo^.client_data; + MEMZERO(cinfo, SIZEOF(jpeg_compress_struct)); + cinfo^.err := err; + cinfo^.is_decompressor := FALSE; + cinfo^.client_data := client_data; + + { Initialize a memory manager instance for this object } + jinit_memory_mgr(j_common_ptr(cinfo)); + + { Zero out pointers to permanent structures. } + cinfo^.progress := NIL; + cinfo^.dest := NIL; + + cinfo^.comp_info := NIL; + + for i := 0 to pred(NUM_QUANT_TBLS) do + cinfo^.quant_tbl_ptrs[i] := NIL; + + for i := 0 to pred(NUM_HUFF_TBLS) do + begin + cinfo^.dc_huff_tbl_ptrs[i] := NIL; + cinfo^.ac_huff_tbl_ptrs[i] := NIL; + end; + + cinfo^.script_space := NIL; + + cinfo^.input_gamma := 1.0; { in case application forgets } + + { OK, I'm ready } + cinfo^.global_state := CSTATE_START; +end; + + +{ Destruction of a JPEG compression object } + +{GLOBAL} +procedure jpeg_destroy_compress (cinfo : j_compress_ptr); +begin + jpeg_destroy(j_common_ptr(cinfo)); { use common routine } +end; + + +{ Abort processing of a JPEG compression operation, + but don't destroy the object itself. } + +{GLOBAL} +procedure jpeg_abort_compress (cinfo : j_compress_ptr); +begin + jpeg_abort(j_common_ptr(cinfo)); { use common routine } +end; + + +{ Forcibly suppress or un-suppress all quantization and Huffman tables. + Marks all currently defined tables as already written (if suppress) + or not written (if !suppress). This will control whether they get emitted + by a subsequent jpeg_start_compress call. + + This routine is exported for use by applications that want to produce + abbreviated JPEG datastreams. It logically belongs in jcparam.c, but + since it is called by jpeg_start_compress, we put it here --- otherwise + jcparam.o would be linked whether the application used it or not. } + +{GLOBAL} +procedure jpeg_suppress_tables (cinfo : j_compress_ptr; + suppress : boolean); +var + i : int; + qtbl : JQUANT_TBL_PTR; + htbl : JHUFF_TBL_PTR; +begin + for i := 0 to pred(NUM_QUANT_TBLS) do + begin + qtbl := cinfo^.quant_tbl_ptrs[i]; + if (qtbl <> NIL) then + qtbl^.sent_table := suppress; + end; + + for i := 0 to pred(NUM_HUFF_TBLS) do + begin + htbl := cinfo^.dc_huff_tbl_ptrs[i]; + if (htbl <> NIL) then + htbl^.sent_table := suppress; + htbl := cinfo^.ac_huff_tbl_ptrs[i]; + if (htbl <> NIL) then + htbl^.sent_table := suppress; + end; +end; + + +{ Finish JPEG compression. + + If a multipass operating mode was selected, this may do a great deal of + work including most of the actual output. } + +{GLOBAL} +procedure jpeg_finish_compress (cinfo : j_compress_ptr); +var + iMCU_row : JDIMENSION; +begin + if (cinfo^.global_state = CSTATE_SCANNING) or + (cinfo^.global_state = CSTATE_RAW_OK) then + begin + { Terminate first pass } + if (cinfo^.next_scanline < cinfo^.image_height) then + ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA); + cinfo^.master^.finish_pass (cinfo); + end + else + if (cinfo^.global_state <> CSTATE_WRCOEFS) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + { Perform any remaining passes } + while (not cinfo^.master^.is_last_pass) do + begin + cinfo^.master^.prepare_for_pass (cinfo); + for iMCU_row := 0 to pred(cinfo^.total_iMCU_rows) do + begin + if (cinfo^.progress <> NIL) then + begin + cinfo^.progress^.pass_counter := long (iMCU_row); + cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows); + cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); + end; + { We bypass the main controller and invoke coef controller directly; + all work is being done from the coefficient buffer. } + + if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(NIL))) then + ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND); + end; + cinfo^.master^.finish_pass (cinfo); + end; + { Write EOI, do final cleanup } + cinfo^.marker^.write_file_trailer (cinfo); + cinfo^.dest^.term_destination (cinfo); + { We can use jpeg_abort to release memory and reset global_state } + jpeg_abort(j_common_ptr(cinfo)); +end; + + +{ Write a special marker. + This is only recommended for writing COM or APPn markers. + Must be called after jpeg_start_compress() and before + first call to jpeg_write_scanlines() or jpeg_write_raw_data(). } + +{GLOBAL} +procedure jpeg_write_marker (cinfo : j_compress_ptr; + marker : int; + dataptr : JOCTETptr; + datalen : uInt); +var + write_marker_byte : procedure(info : j_compress_ptr; val : int); +begin + if (cinfo^.next_scanline <> 0) or + ((cinfo^.global_state <> CSTATE_SCANNING) and + (cinfo^.global_state <> CSTATE_RAW_OK) and + (cinfo^.global_state <> CSTATE_WRCOEFS)) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + + cinfo^.marker^.write_marker_header (cinfo, marker, datalen); + write_marker_byte := cinfo^.marker^.write_marker_byte; { copy for speed } + while (datalen <> 0) do + begin + Dec(datalen); + write_marker_byte (cinfo, dataptr^); + Inc(dataptr); + end; +end; + +{ Same, but piecemeal. } + +{GLOBAL} +procedure jpeg_write_m_header (cinfo : j_compress_ptr; + marker : int; + datalen : uint); +begin + if (cinfo^.next_scanline <> 0) or + ((cinfo^.global_state <> CSTATE_SCANNING) and + (cinfo^.global_state <> CSTATE_RAW_OK) and + (cinfo^.global_state <> CSTATE_WRCOEFS)) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + + cinfo^.marker^.write_marker_header (cinfo, marker, datalen); +end; + +{GLOBAL} +procedure jpeg_write_m_byte (cinfo : j_compress_ptr; val : int); +begin + cinfo^.marker^.write_marker_byte (cinfo, val); +end; + + +{ Alternate compression function: just write an abbreviated table file. + Before calling this, all parameters and a data destination must be set up. + + To produce a pair of files containing abbreviated tables and abbreviated + image data, one would proceed as follows: + + initialize JPEG object + set JPEG parameters + set destination to table file + jpeg_write_tables(cinfo); + set destination to image file + jpeg_start_compress(cinfo, FALSE); + write data... + jpeg_finish_compress(cinfo); + + jpeg_write_tables has the side effect of marking all tables written + (same as jpeg_suppress_tables(..., TRUE)). Thus a subsequent start_compress + will not re-emit the tables unless it is passed write_all_tables=TRUE. } + +{GLOBAL} +procedure jpeg_write_tables (cinfo : j_compress_ptr); +begin + if (cinfo^.global_state <> CSTATE_START) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + + { (Re)initialize error mgr and destination modules } + cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo)); + cinfo^.dest^.init_destination (cinfo); + { Initialize the marker writer ... bit of a crock to do it here. } + jinit_marker_writer(cinfo); + { Write them tables! } + cinfo^.marker^.write_tables_only (cinfo); + { And clean up. } + cinfo^.dest^.term_destination (cinfo); + + { In library releases up through v6a, we called jpeg_abort() here to free + any working memory allocated by the destination manager and marker + writer. Some applications had a problem with that: they allocated space + of their own from the library memory manager, and didn't want it to go + away during write_tables. So now we do nothing. This will cause a + memory leak if an app calls write_tables repeatedly without doing a full + compression cycle or otherwise resetting the JPEG object. However, that + seems less bad than unexpectedly freeing memory in the normal case. + An app that prefers the old behavior can call jpeg_abort for itself after + each call to jpeg_write_tables(). } +end; + +end. diff --git a/Imaging/JpegLib/imjcapistd.pas b/Imaging/JpegLib/imjcapistd.pas index f9ae613..7883c6e 100644 --- a/Imaging/JpegLib/imjcapistd.pas +++ b/Imaging/JpegLib/imjcapistd.pas @@ -1,222 +1,222 @@ -unit imjcapistd; - -{ Original : jcapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - -{ This file is part of the Independent JPEG Group's software. - For conditions of distribution and use, see the accompanying README file. - - This file contains application interface code for the compression half - of the JPEG library. These are the "standard" API routines that are - used in the normal full-compression case. They are not used by a - transcoding-only application. Note that if an application links in - jpeg_start_compress, it will end up linking in the entire compressor. - We thus must separate this file from jcapimin.c to avoid linking the - whole compression library into a transcoder. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjpeglib, - imjcapimin, imjcinit; - - - -{ Compression initialization. - Before calling this, all parameters and a data destination must be set up. - - We require a write_all_tables parameter as a failsafe check when writing - multiple datastreams from the same compression object. Since prior runs - will have left all the tables marked sent_table=TRUE, a subsequent run - would emit an abbreviated stream (no tables) by default. This may be what - is wanted, but for safety's sake it should not be the default behavior: - programmers should have to make a deliberate choice to emit abbreviated - images. Therefore the documentation and examples should encourage people - to pass write_all_tables=TRUE; then it will take active thought to do the - wrong thing. } - -{GLOBAL} -procedure jpeg_start_compress (cinfo : j_compress_ptr; - write_all_tables : boolean); - - -{ Write some scanlines of data to the JPEG compressor. - - The return value will be the number of lines actually written. - This should be less than the supplied num_lines only in case that - the data destination module has requested suspension of the compressor, - or if more than image_height scanlines are passed in. - - Note: we warn about excess calls to jpeg_write_scanlines() since - this likely signals an application programmer error. However, - excess scanlines passed in the last valid call are *silently* ignored, - so that the application need not adjust num_lines for end-of-image - when using a multiple-scanline buffer. } - -{GLOBAL} -function jpeg_write_scanlines (cinfo : j_compress_ptr; - scanlines : JSAMPARRAY; - num_lines : JDIMENSION) : JDIMENSION; - -{ Alternate entry point to write raw data. - Processes exactly one iMCU row per call, unless suspended. } - -{GLOBAL} -function jpeg_write_raw_data (cinfo : j_compress_ptr; - data : JSAMPIMAGE; - num_lines : JDIMENSION) : JDIMENSION; - -implementation - -{ Compression initialization. - Before calling this, all parameters and a data destination must be set up. - - We require a write_all_tables parameter as a failsafe check when writing - multiple datastreams from the same compression object. Since prior runs - will have left all the tables marked sent_table=TRUE, a subsequent run - would emit an abbreviated stream (no tables) by default. This may be what - is wanted, but for safety's sake it should not be the default behavior: - programmers should have to make a deliberate choice to emit abbreviated - images. Therefore the documentation and examples should encourage people - to pass write_all_tables=TRUE; then it will take active thought to do the - wrong thing. } - -{GLOBAL} -procedure jpeg_start_compress (cinfo : j_compress_ptr; - write_all_tables : boolean); -begin - if (cinfo^.global_state <> CSTATE_START) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - - if (write_all_tables) then - jpeg_suppress_tables(cinfo, FALSE); { mark all tables to be written } - - { (Re)initialize error mgr and destination modules } - cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo)); - cinfo^.dest^.init_destination (cinfo); - { Perform master selection of active modules } - jinit_compress_master(cinfo); - { Set up for the first pass } - cinfo^.master^.prepare_for_pass (cinfo); - { Ready for application to drive first pass through jpeg_write_scanlines - or jpeg_write_raw_data. } - - cinfo^.next_scanline := 0; - if cinfo^.raw_data_in then - cinfo^.global_state := CSTATE_RAW_OK - else - cinfo^.global_state := CSTATE_SCANNING; -end; - - -{ Write some scanlines of data to the JPEG compressor. - - The return value will be the number of lines actually written. - This should be less than the supplied num_lines only in case that - the data destination module has requested suspension of the compressor, - or if more than image_height scanlines are passed in. - - Note: we warn about excess calls to jpeg_write_scanlines() since - this likely signals an application programmer error. However, - excess scanlines passed in the last valid call are *silently* ignored, - so that the application need not adjust num_lines for end-of-image - when using a multiple-scanline buffer. } - -{GLOBAL} -function jpeg_write_scanlines (cinfo : j_compress_ptr; - scanlines : JSAMPARRAY; - num_lines : JDIMENSION) : JDIMENSION; -var - row_ctr, rows_left : JDIMENSION; -begin - if (cinfo^.global_state <> CSTATE_SCANNING) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - if (cinfo^.next_scanline >= cinfo^.image_height) then - WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); - - { Call progress monitor hook if present } - if (cinfo^.progress <> NIL) then - begin - cinfo^.progress^.pass_counter := long (cinfo^.next_scanline); - cinfo^.progress^.pass_limit := long (cinfo^.image_height); - cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); - end; - - { Give master control module another chance if this is first call to - jpeg_write_scanlines. This lets output of the frame/scan headers be - delayed so that application can write COM, etc, markers between - jpeg_start_compress and jpeg_write_scanlines. } - if (cinfo^.master^.call_pass_startup) then - cinfo^.master^.pass_startup (cinfo); - - { Ignore any extra scanlines at bottom of image. } - rows_left := cinfo^.image_height - cinfo^.next_scanline; - if (num_lines > rows_left) then - num_lines := rows_left; - - row_ctr := 0; - cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, num_lines); - Inc(cinfo^.next_scanline, row_ctr); - jpeg_write_scanlines := row_ctr; -end; - - -{ Alternate entry point to write raw data. - Processes exactly one iMCU row per call, unless suspended. } - -{GLOBAL} -function jpeg_write_raw_data (cinfo : j_compress_ptr; - data : JSAMPIMAGE; - num_lines : JDIMENSION) : JDIMENSION; -var - lines_per_iMCU_row : JDIMENSION; -begin - if (cinfo^.global_state <> CSTATE_RAW_OK) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - if (cinfo^.next_scanline >= cinfo^.image_height) then - begin - WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); - jpeg_write_raw_data := 0; - exit; - end; - - { Call progress monitor hook if present } - if (cinfo^.progress <> NIL) then - begin - cinfo^.progress^.pass_counter := long(cinfo^.next_scanline); - cinfo^.progress^.pass_limit := long(cinfo^.image_height); - cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); - end; - - { Give master control module another chance if this is first call to - jpeg_write_raw_data. This lets output of the frame/scan headers be - delayed so that application can write COM, etc, markers between - jpeg_start_compress and jpeg_write_raw_data. } - - if (cinfo^.master^.call_pass_startup) then - cinfo^.master^.pass_startup (cinfo); - - { Verify that at least one iMCU row has been passed. } - lines_per_iMCU_row := cinfo^.max_v_samp_factor * DCTSIZE; - if (num_lines < lines_per_iMCU_row) then - ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE); - - { Directly compress the row. } - if (not cinfo^.coef^.compress_data (cinfo, data)) then - begin - { If compressor did not consume the whole row, suspend processing. } - jpeg_write_raw_data := 0; - exit; - end; - - { OK, we processed one iMCU row. } - Inc(cinfo^.next_scanline, lines_per_iMCU_row); - jpeg_write_raw_data := lines_per_iMCU_row; -end; - -end. +unit imjcapistd; + +{ Original : jcapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + +{ This file is part of the Independent JPEG Group's software. + For conditions of distribution and use, see the accompanying README file. + + This file contains application interface code for the compression half + of the JPEG library. These are the "standard" API routines that are + used in the normal full-compression case. They are not used by a + transcoding-only application. Note that if an application links in + jpeg_start_compress, it will end up linking in the entire compressor. + We thus must separate this file from jcapimin.c to avoid linking the + whole compression library into a transcoder. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjpeglib, + imjcapimin, imjcinit; + + + +{ Compression initialization. + Before calling this, all parameters and a data destination must be set up. + + We require a write_all_tables parameter as a failsafe check when writing + multiple datastreams from the same compression object. Since prior runs + will have left all the tables marked sent_table=TRUE, a subsequent run + would emit an abbreviated stream (no tables) by default. This may be what + is wanted, but for safety's sake it should not be the default behavior: + programmers should have to make a deliberate choice to emit abbreviated + images. Therefore the documentation and examples should encourage people + to pass write_all_tables=TRUE; then it will take active thought to do the + wrong thing. } + +{GLOBAL} +procedure jpeg_start_compress (cinfo : j_compress_ptr; + write_all_tables : boolean); + + +{ Write some scanlines of data to the JPEG compressor. + + The return value will be the number of lines actually written. + This should be less than the supplied num_lines only in case that + the data destination module has requested suspension of the compressor, + or if more than image_height scanlines are passed in. + + Note: we warn about excess calls to jpeg_write_scanlines() since + this likely signals an application programmer error. However, + excess scanlines passed in the last valid call are *silently* ignored, + so that the application need not adjust num_lines for end-of-image + when using a multiple-scanline buffer. } + +{GLOBAL} +function jpeg_write_scanlines (cinfo : j_compress_ptr; + scanlines : JSAMPARRAY; + num_lines : JDIMENSION) : JDIMENSION; + +{ Alternate entry point to write raw data. + Processes exactly one iMCU row per call, unless suspended. } + +{GLOBAL} +function jpeg_write_raw_data (cinfo : j_compress_ptr; + data : JSAMPIMAGE; + num_lines : JDIMENSION) : JDIMENSION; + +implementation + +{ Compression initialization. + Before calling this, all parameters and a data destination must be set up. + + We require a write_all_tables parameter as a failsafe check when writing + multiple datastreams from the same compression object. Since prior runs + will have left all the tables marked sent_table=TRUE, a subsequent run + would emit an abbreviated stream (no tables) by default. This may be what + is wanted, but for safety's sake it should not be the default behavior: + programmers should have to make a deliberate choice to emit abbreviated + images. Therefore the documentation and examples should encourage people + to pass write_all_tables=TRUE; then it will take active thought to do the + wrong thing. } + +{GLOBAL} +procedure jpeg_start_compress (cinfo : j_compress_ptr; + write_all_tables : boolean); +begin + if (cinfo^.global_state <> CSTATE_START) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + + if (write_all_tables) then + jpeg_suppress_tables(cinfo, FALSE); { mark all tables to be written } + + { (Re)initialize error mgr and destination modules } + cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo)); + cinfo^.dest^.init_destination (cinfo); + { Perform master selection of active modules } + jinit_compress_master(cinfo); + { Set up for the first pass } + cinfo^.master^.prepare_for_pass (cinfo); + { Ready for application to drive first pass through jpeg_write_scanlines + or jpeg_write_raw_data. } + + cinfo^.next_scanline := 0; + if cinfo^.raw_data_in then + cinfo^.global_state := CSTATE_RAW_OK + else + cinfo^.global_state := CSTATE_SCANNING; +end; + + +{ Write some scanlines of data to the JPEG compressor. + + The return value will be the number of lines actually written. + This should be less than the supplied num_lines only in case that + the data destination module has requested suspension of the compressor, + or if more than image_height scanlines are passed in. + + Note: we warn about excess calls to jpeg_write_scanlines() since + this likely signals an application programmer error. However, + excess scanlines passed in the last valid call are *silently* ignored, + so that the application need not adjust num_lines for end-of-image + when using a multiple-scanline buffer. } + +{GLOBAL} +function jpeg_write_scanlines (cinfo : j_compress_ptr; + scanlines : JSAMPARRAY; + num_lines : JDIMENSION) : JDIMENSION; +var + row_ctr, rows_left : JDIMENSION; +begin + if (cinfo^.global_state <> CSTATE_SCANNING) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + if (cinfo^.next_scanline >= cinfo^.image_height) then + WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); + + { Call progress monitor hook if present } + if (cinfo^.progress <> NIL) then + begin + cinfo^.progress^.pass_counter := long (cinfo^.next_scanline); + cinfo^.progress^.pass_limit := long (cinfo^.image_height); + cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); + end; + + { Give master control module another chance if this is first call to + jpeg_write_scanlines. This lets output of the frame/scan headers be + delayed so that application can write COM, etc, markers between + jpeg_start_compress and jpeg_write_scanlines. } + if (cinfo^.master^.call_pass_startup) then + cinfo^.master^.pass_startup (cinfo); + + { Ignore any extra scanlines at bottom of image. } + rows_left := cinfo^.image_height - cinfo^.next_scanline; + if (num_lines > rows_left) then + num_lines := rows_left; + + row_ctr := 0; + cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, num_lines); + Inc(cinfo^.next_scanline, row_ctr); + jpeg_write_scanlines := row_ctr; +end; + + +{ Alternate entry point to write raw data. + Processes exactly one iMCU row per call, unless suspended. } + +{GLOBAL} +function jpeg_write_raw_data (cinfo : j_compress_ptr; + data : JSAMPIMAGE; + num_lines : JDIMENSION) : JDIMENSION; +var + lines_per_iMCU_row : JDIMENSION; +begin + if (cinfo^.global_state <> CSTATE_RAW_OK) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + if (cinfo^.next_scanline >= cinfo^.image_height) then + begin + WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); + jpeg_write_raw_data := 0; + exit; + end; + + { Call progress monitor hook if present } + if (cinfo^.progress <> NIL) then + begin + cinfo^.progress^.pass_counter := long(cinfo^.next_scanline); + cinfo^.progress^.pass_limit := long(cinfo^.image_height); + cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); + end; + + { Give master control module another chance if this is first call to + jpeg_write_raw_data. This lets output of the frame/scan headers be + delayed so that application can write COM, etc, markers between + jpeg_start_compress and jpeg_write_raw_data. } + + if (cinfo^.master^.call_pass_startup) then + cinfo^.master^.pass_startup (cinfo); + + { Verify that at least one iMCU row has been passed. } + lines_per_iMCU_row := cinfo^.max_v_samp_factor * DCTSIZE; + if (num_lines < lines_per_iMCU_row) then + ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE); + + { Directly compress the row. } + if (not cinfo^.coef^.compress_data (cinfo, data)) then + begin + { If compressor did not consume the whole row, suspend processing. } + jpeg_write_raw_data := 0; + exit; + end; + + { OK, we processed one iMCU row. } + Inc(cinfo^.next_scanline, lines_per_iMCU_row); + jpeg_write_raw_data := lines_per_iMCU_row; +end; + +end. diff --git a/Imaging/JpegLib/imjccoefct.pas b/Imaging/JpegLib/imjccoefct.pas index 7dd97e5..9d4c620 100644 --- a/Imaging/JpegLib/imjccoefct.pas +++ b/Imaging/JpegLib/imjccoefct.pas @@ -1,521 +1,521 @@ -unit imjccoefct; - -{ This file contains the coefficient buffer controller for compression. - This controller is the top level of the JPEG compressor proper. - The coefficient buffer lies between forward-DCT and entropy encoding steps.} - -{ Original: jccoefct.c; Copyright (C) 1994-1997, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjerror, - imjdeferr, - imjutils, - imjpeglib; - -{ We use a full-image coefficient buffer when doing Huffman optimization, - and also for writing multiple-scan JPEG files. In all cases, the DCT - step is run during the first pass, and subsequent passes need only read - the buffered coefficients. } -{$ifdef ENTROPY_OPT_SUPPORTED} - {$define FULL_COEF_BUFFER_SUPPORTED} -{$else} - {$ifdef C_MULTISCAN_FILES_SUPPORTED} - {$define FULL_COEF_BUFFER_SUPPORTED} - {$endif} -{$endif} - -{ Initialize coefficient buffer controller. } - -{GLOBAL} -procedure jinit_c_coef_controller (cinfo : j_compress_ptr; - need_full_buffer : boolean); - -implementation - -{ Private buffer controller object } - -type - my_coef_ptr = ^my_coef_controller; - my_coef_controller = record - pub : jpeg_c_coef_controller; { public fields } - - iMCU_row_num : JDIMENSION; { iMCU row # within image } - mcu_ctr : JDIMENSION; { counts MCUs processed in current row } - MCU_vert_offset : int; { counts MCU rows within iMCU row } - MCU_rows_per_iMCU_row : int; { number of such rows needed } - - { For single-pass compression, it's sufficient to buffer just one MCU - (although this may prove a bit slow in practice). We allocate a - workspace of C_MAX_BLOCKS_IN_MCU coefficient blocks, and reuse it for each - MCU constructed and sent. (On 80x86, the workspace is FAR even though - it's not really very big; this is to keep the module interfaces unchanged - when a large coefficient buffer is necessary.) - In multi-pass modes, this array points to the current MCU's blocks - within the virtual arrays. } - - MCU_buffer : array[0..C_MAX_BLOCKS_IN_MCU-1] of JBLOCKROW; - - { In multi-pass modes, we need a virtual block array for each component. } - whole_image : array[0..MAX_COMPONENTS-1] of jvirt_barray_ptr; - end; - - -{ Forward declarations } -{METHODDEF} -function compress_data(cinfo : j_compress_ptr; - input_buf : JSAMPIMAGE) : boolean; forward; -{$ifdef FULL_COEF_BUFFER_SUPPORTED} -{METHODDEF} -function compress_first_pass(cinfo : j_compress_ptr; - input_buf : JSAMPIMAGE) : boolean; forward; -{METHODDEF} -function compress_output(cinfo : j_compress_ptr; - input_buf : JSAMPIMAGE) : boolean; forward; -{$endif} - - -{LOCAL} -procedure start_iMCU_row (cinfo : j_compress_ptr); -{ Reset within-iMCU-row counters for a new row } -var - coef : my_coef_ptr; -begin - coef := my_coef_ptr (cinfo^.coef); - - { In an interleaved scan, an MCU row is the same as an iMCU row. - In a noninterleaved scan, an iMCU row has v_samp_factor MCU rows. - But at the bottom of the image, process only what's left. } - if (cinfo^.comps_in_scan > 1) then - begin - coef^.MCU_rows_per_iMCU_row := 1; - end - else - begin - if (coef^.iMCU_row_num < (cinfo^.total_iMCU_rows-1)) then - coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.v_samp_factor - else - coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.last_row_height; - end; - - coef^.mcu_ctr := 0; - coef^.MCU_vert_offset := 0; -end; - - -{ Initialize for a processing pass. } - -{METHODDEF} -procedure start_pass_coef (cinfo : j_compress_ptr; - pass_mode : J_BUF_MODE); -var - coef : my_coef_ptr; -begin - coef := my_coef_ptr (cinfo^.coef); - - coef^.iMCU_row_num := 0; - start_iMCU_row(cinfo); - - case (pass_mode) of - JBUF_PASS_THRU: - begin - if (coef^.whole_image[0] <> NIL) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - coef^.pub.compress_data := compress_data; - end; -{$ifdef FULL_COEF_BUFFER_SUPPORTED} - JBUF_SAVE_AND_PASS: - begin - if (coef^.whole_image[0] = NIL) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - coef^.pub.compress_data := compress_first_pass; - end; - JBUF_CRANK_DEST: - begin - if (coef^.whole_image[0] = NIL) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - coef^.pub.compress_data := compress_output; - end; -{$endif} - else - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - end; -end; - - -{ Process some data in the single-pass case. - We process the equivalent of one fully interleaved MCU row ("iMCU" row) - per call, ie, v_samp_factor block rows for each component in the image. - Returns TRUE if the iMCU row is completed, FALSE if suspended. - - NB: input_buf contains a plane for each component in image, - which we index according to the component's SOF position. } - - -{METHODDEF} -function compress_data (cinfo : j_compress_ptr; - input_buf : JSAMPIMAGE) : boolean; -var - coef : my_coef_ptr; - MCU_col_num : JDIMENSION; { index of current MCU within row } - last_MCU_col : JDIMENSION; - last_iMCU_row : JDIMENSION; - blkn, bi, ci, yindex, yoffset, blockcnt : int; - ypos, xpos : JDIMENSION; - compptr : jpeg_component_info_ptr; -begin - coef := my_coef_ptr (cinfo^.coef); - last_MCU_col := cinfo^.MCUs_per_row - 1; - last_iMCU_row := cinfo^.total_iMCU_rows - 1; - - { Loop to write as much as one whole iMCU row } - for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do - begin - for MCU_col_num := coef^.mcu_ctr to last_MCU_col do - begin - { Determine where data comes from in input_buf and do the DCT thing. - Each call on forward_DCT processes a horizontal row of DCT blocks - as wide as an MCU; we rely on having allocated the MCU_buffer[] blocks - sequentially. Dummy blocks at the right or bottom edge are filled in - specially. The data in them does not matter for image reconstruction, - so we fill them with values that will encode to the smallest amount of - data, viz: all zeroes in the AC entries, DC entries equal to previous - block's DC value. (Thanks to Thomas Kinsman for this idea.) } - - blkn := 0; - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - if (MCU_col_num < last_MCU_col) then - blockcnt := compptr^.MCU_width - else - blockcnt := compptr^.last_col_width; - xpos := MCU_col_num * JDIMENSION(compptr^.MCU_sample_width); - ypos := yoffset * DCTSIZE; { ypos = (yoffset+yindex) * DCTSIZE } - for yindex := 0 to pred(compptr^.MCU_height) do - begin - if (coef^.iMCU_row_num < last_iMCU_row) or - (yoffset+yindex < compptr^.last_row_height) then - begin - cinfo^.fdct^.forward_DCT (cinfo, compptr, - input_buf^[compptr^.component_index], - coef^.MCU_buffer[blkn], - ypos, xpos, JDIMENSION (blockcnt)); - - if (blockcnt < compptr^.MCU_width) then - begin - { Create some dummy blocks at the right edge of the image. } - jzero_far({FAR}pointer(coef^.MCU_buffer[blkn + blockcnt]), - (compptr^.MCU_width - blockcnt) * SIZEOF(JBLOCK)); - for bi := blockcnt to pred(compptr^.MCU_width) do - begin - coef^.MCU_buffer[blkn+bi]^[0][0] := coef^.MCU_buffer[blkn+bi-1]^[0][0]; - end; - end; - end - else - begin - { Create a row of dummy blocks at the bottom of the image. } - jzero_far({FAR}pointer(coef^.MCU_buffer[blkn]), - compptr^.MCU_width * SIZEOF(JBLOCK)); - for bi := 0 to pred(compptr^.MCU_width) do - begin - coef^.MCU_buffer[blkn+bi]^[0][0] := coef^.MCU_buffer[blkn-1]^[0][0]; - end; - end; - Inc(blkn, compptr^.MCU_width); - Inc(ypos, DCTSIZE); - end; - end; - { Try to write the MCU. In event of a suspension failure, we will - re-DCT the MCU on restart (a bit inefficient, could be fixed...) } - - if (not cinfo^.entropy^.encode_mcu (cinfo, JBLOCKARRAY(@coef^.MCU_buffer)^)) then - begin - { Suspension forced; update state counters and exit } - coef^.MCU_vert_offset := yoffset; - coef^.mcu_ctr := MCU_col_num; - compress_data := FALSE; - exit; - end; - end; - { Completed an MCU row, but perhaps not an iMCU row } - coef^.mcu_ctr := 0; - end; - { Completed the iMCU row, advance counters for next one } - Inc(coef^.iMCU_row_num); - start_iMCU_row(cinfo); - compress_data := TRUE; -end; - - -{$ifdef FULL_COEF_BUFFER_SUPPORTED} - -{ Process some data in the first pass of a multi-pass case. - We process the equivalent of one fully interleaved MCU row ("iMCU" row) - per call, ie, v_samp_factor block rows for each component in the image. - This amount of data is read from the source buffer, DCT'd and quantized, - and saved into the virtual arrays. We also generate suitable dummy blocks - as needed at the right and lower edges. (The dummy blocks are constructed - in the virtual arrays, which have been padded appropriately.) This makes - it possible for subsequent passes not to worry about real vs. dummy blocks. - - We must also emit the data to the entropy encoder. This is conveniently - done by calling compress_output() after we've loaded the current strip - of the virtual arrays. - - NB: input_buf contains a plane for each component in image. All - components are DCT'd and loaded into the virtual arrays in this pass. - However, it may be that only a subset of the components are emitted to - the entropy encoder during this first pass; be careful about looking - at the scan-dependent variables (MCU dimensions, etc). } - -{METHODDEF} -function compress_first_pass (cinfo : j_compress_ptr; - input_buf : JSAMPIMAGE) : boolean; -var - coef : my_coef_ptr; - last_iMCU_row : JDIMENSION; - blocks_across, MCUs_across, MCUindex : JDIMENSION; - bi, ci, h_samp_factor, block_row, block_rows, ndummy : int; - lastDC : JCOEF; - compptr : jpeg_component_info_ptr; - buffer : JBLOCKARRAY; - thisblockrow, lastblockrow : JBLOCKROW; -begin - coef := my_coef_ptr (cinfo^.coef); - last_iMCU_row := cinfo^.total_iMCU_rows - 1; - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - { Align the virtual buffer for this component. } - buffer := cinfo^.mem^.access_virt_barray - (j_common_ptr(cinfo), coef^.whole_image[ci], - coef^.iMCU_row_num * JDIMENSION(compptr^.v_samp_factor), - JDIMENSION (compptr^.v_samp_factor), TRUE); - { Count non-dummy DCT block rows in this iMCU row. } - if (coef^.iMCU_row_num < last_iMCU_row) then - block_rows := compptr^.v_samp_factor - else - begin - { NB: can't use last_row_height here, since may not be set! } - block_rows := int (compptr^.height_in_blocks) mod compptr^.v_samp_factor; - if (block_rows = 0) then - block_rows := compptr^.v_samp_factor; - end; - blocks_across := compptr^.width_in_blocks; - h_samp_factor := compptr^.h_samp_factor; - { Count number of dummy blocks to be added at the right margin. } - ndummy := int (blocks_across) mod h_samp_factor; - if (ndummy > 0) then - ndummy := h_samp_factor - ndummy; - { Perform DCT for all non-dummy blocks in this iMCU row. Each call - on forward_DCT processes a complete horizontal row of DCT blocks. } - - for block_row := 0 to pred(block_rows) do - begin - thisblockrow := buffer^[block_row]; - cinfo^.fdct^.forward_DCT (cinfo, compptr, - input_buf^[ci], - thisblockrow, - JDIMENSION (block_row * DCTSIZE), - JDIMENSION (0), - blocks_across); - if (ndummy > 0) then - begin - { Create dummy blocks at the right edge of the image. } - Inc(JBLOCK_PTR(thisblockrow), blocks_across); { => first dummy block } - jzero_far({FAR}pointer(thisblockrow), ndummy * SIZEOF(JBLOCK)); - {lastDC := thisblockrow^[-1][0];} - { work around Range Checking } - Dec(JBLOCK_PTR(thisblockrow)); - lastDC := thisblockrow^[0][0]; - Inc(JBLOCK_PTR(thisblockrow)); - - for bi := 0 to pred(ndummy) do - begin - thisblockrow^[bi][0] := lastDC; - end; - end; - end; - { If at end of image, create dummy block rows as needed. - The tricky part here is that within each MCU, we want the DC values - of the dummy blocks to match the last real block's DC value. - This squeezes a few more bytes out of the resulting file... } - - if (coef^.iMCU_row_num = last_iMCU_row) then - begin - Inc(blocks_across, ndummy); { include lower right corner } - MCUs_across := blocks_across div JDIMENSION(h_samp_factor); - for block_row := block_rows to pred(compptr^.v_samp_factor) do - begin - thisblockrow := buffer^[block_row]; - lastblockrow := buffer^[block_row-1]; - jzero_far({FAR} pointer(thisblockrow), - size_t(blocks_across * SIZEOF(JBLOCK))); - for MCUindex := 0 to pred(MCUs_across) do - begin - lastDC := lastblockrow^[h_samp_factor-1][0]; - for bi := 0 to pred(h_samp_factor) do - begin - thisblockrow^[bi][0] := lastDC; - end; - Inc(JBLOCK_PTR(thisblockrow), h_samp_factor); { advance to next MCU in row } - Inc(JBLOCK_PTR(lastblockrow), h_samp_factor); - end; - end; - end; - Inc(compptr); - end; - { NB: compress_output will increment iMCU_row_num if successful. - A suspension return will result in redoing all the work above next time.} - - - { Emit data to the entropy encoder, sharing code with subsequent passes } - compress_first_pass := compress_output(cinfo, input_buf); -end; - - -{ Process some data in subsequent passes of a multi-pass case. - We process the equivalent of one fully interleaved MCU row ("iMCU" row) - per call, ie, v_samp_factor block rows for each component in the scan. - The data is obtained from the virtual arrays and fed to the entropy coder. - Returns TRUE if the iMCU row is completed, FALSE if suspended. - - NB: input_buf is ignored; it is likely to be a NIL pointer. } - -{METHODDEF} -function compress_output (cinfo : j_compress_ptr; - input_buf : JSAMPIMAGE) : boolean; -var - coef : my_coef_ptr; - MCU_col_num : JDIMENSION; { index of current MCU within row } - blkn, ci, xindex, yindex, yoffset : int; - start_col : JDIMENSION; - buffer : array[0..MAX_COMPS_IN_SCAN-1] of JBLOCKARRAY; - buffer_ptr : JBLOCKROW; - compptr : jpeg_component_info_ptr; -begin - coef := my_coef_ptr (cinfo^.coef); - - { Align the virtual buffers for the components used in this scan. - NB: during first pass, this is safe only because the buffers will - already be aligned properly, so jmemmgr.c won't need to do any I/O. } - - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - buffer[ci] := cinfo^.mem^.access_virt_barray ( - j_common_ptr(cinfo), coef^.whole_image[compptr^.component_index], - coef^.iMCU_row_num * JDIMENSION(compptr^.v_samp_factor), - JDIMENSION (compptr^.v_samp_factor), FALSE); - end; - - { Loop to process one whole iMCU row } - for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do - begin - for MCU_col_num := coef^.mcu_ctr to pred(cinfo^.MCUs_per_row) do - begin - { Construct list of pointers to DCT blocks belonging to this MCU } - blkn := 0; { index of current DCT block within MCU } - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - start_col := MCU_col_num * JDIMENSION(compptr^.MCU_width); - for yindex := 0 to pred(compptr^.MCU_height) do - begin - buffer_ptr := JBLOCKROW(@ buffer[ci]^[yindex+yoffset]^[start_col]); - for xindex := 0 to pred(compptr^.MCU_width) do - begin - coef^.MCU_buffer[blkn] := buffer_ptr; - Inc(blkn); - Inc(JBLOCK_PTR(buffer_ptr)); - end; - end; - end; - { Try to write the MCU. } - if (not cinfo^.entropy^.encode_mcu (cinfo, coef^.MCU_buffer)) then - begin - { Suspension forced; update state counters and exit } - coef^.MCU_vert_offset := yoffset; - coef^.mcu_ctr := MCU_col_num; - compress_output := FALSE; - exit; - end; - end; - { Completed an MCU row, but perhaps not an iMCU row } - coef^.mcu_ctr := 0; - end; - { Completed the iMCU row, advance counters for next one } - Inc(coef^.iMCU_row_num); - start_iMCU_row(cinfo); - compress_output := TRUE; -end; - -{$endif} { FULL_COEF_BUFFER_SUPPORTED } - - -{ Initialize coefficient buffer controller. } - -{GLOBAL} -procedure jinit_c_coef_controller (cinfo : j_compress_ptr; - need_full_buffer : boolean); -var - coef : my_coef_ptr; -var - buffer : JBLOCKROW; - i : int; -var - ci : int; - compptr : jpeg_component_info_ptr; -begin - coef := my_coef_ptr ( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_coef_controller)) ); - cinfo^.coef := jpeg_c_coef_controller_ptr(coef); - coef^.pub.start_pass := start_pass_coef; - - { Create the coefficient buffer. } - if (need_full_buffer) then - begin -{$ifdef FULL_COEF_BUFFER_SUPPORTED} - { Allocate a full-image virtual array for each component, } - { padded to a multiple of samp_factor DCT blocks in each direction. } - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - coef^.whole_image[ci] := cinfo^.mem^.request_virt_barray - (j_common_ptr(cinfo), JPOOL_IMAGE, FALSE, - JDIMENSION (jround_up( long (compptr^.width_in_blocks), - long (compptr^.h_samp_factor) )), - JDIMENSION (jround_up(long (compptr^.height_in_blocks), - long (compptr^.v_samp_factor))), - JDIMENSION (compptr^.v_samp_factor)); - Inc(compptr); - end; -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); -{$endif} - end - else - begin - { We only need a single-MCU buffer. } - buffer := JBLOCKROW ( - cinfo^.mem^.alloc_large (j_common_ptr(cinfo), JPOOL_IMAGE, - C_MAX_BLOCKS_IN_MCU * SIZEOF(JBLOCK)) ); - for i := 0 to pred(C_MAX_BLOCKS_IN_MCU) do - begin - coef^.MCU_buffer[i] := JBLOCKROW(@ buffer^[i]); - end; - coef^.whole_image[0] := NIL; { flag for no virtual arrays } - end; -end; - -end. +unit imjccoefct; + +{ This file contains the coefficient buffer controller for compression. + This controller is the top level of the JPEG compressor proper. + The coefficient buffer lies between forward-DCT and entropy encoding steps.} + +{ Original: jccoefct.c; Copyright (C) 1994-1997, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjerror, + imjdeferr, + imjutils, + imjpeglib; + +{ We use a full-image coefficient buffer when doing Huffman optimization, + and also for writing multiple-scan JPEG files. In all cases, the DCT + step is run during the first pass, and subsequent passes need only read + the buffered coefficients. } +{$ifdef ENTROPY_OPT_SUPPORTED} + {$define FULL_COEF_BUFFER_SUPPORTED} +{$else} + {$ifdef C_MULTISCAN_FILES_SUPPORTED} + {$define FULL_COEF_BUFFER_SUPPORTED} + {$endif} +{$endif} + +{ Initialize coefficient buffer controller. } + +{GLOBAL} +procedure jinit_c_coef_controller (cinfo : j_compress_ptr; + need_full_buffer : boolean); + +implementation + +{ Private buffer controller object } + +type + my_coef_ptr = ^my_coef_controller; + my_coef_controller = record + pub : jpeg_c_coef_controller; { public fields } + + iMCU_row_num : JDIMENSION; { iMCU row # within image } + mcu_ctr : JDIMENSION; { counts MCUs processed in current row } + MCU_vert_offset : int; { counts MCU rows within iMCU row } + MCU_rows_per_iMCU_row : int; { number of such rows needed } + + { For single-pass compression, it's sufficient to buffer just one MCU + (although this may prove a bit slow in practice). We allocate a + workspace of C_MAX_BLOCKS_IN_MCU coefficient blocks, and reuse it for each + MCU constructed and sent. (On 80x86, the workspace is FAR even though + it's not really very big; this is to keep the module interfaces unchanged + when a large coefficient buffer is necessary.) + In multi-pass modes, this array points to the current MCU's blocks + within the virtual arrays. } + + MCU_buffer : array[0..C_MAX_BLOCKS_IN_MCU-1] of JBLOCKROW; + + { In multi-pass modes, we need a virtual block array for each component. } + whole_image : array[0..MAX_COMPONENTS-1] of jvirt_barray_ptr; + end; + + +{ Forward declarations } +{METHODDEF} +function compress_data(cinfo : j_compress_ptr; + input_buf : JSAMPIMAGE) : boolean; forward; +{$ifdef FULL_COEF_BUFFER_SUPPORTED} +{METHODDEF} +function compress_first_pass(cinfo : j_compress_ptr; + input_buf : JSAMPIMAGE) : boolean; forward; +{METHODDEF} +function compress_output(cinfo : j_compress_ptr; + input_buf : JSAMPIMAGE) : boolean; forward; +{$endif} + + +{LOCAL} +procedure start_iMCU_row (cinfo : j_compress_ptr); +{ Reset within-iMCU-row counters for a new row } +var + coef : my_coef_ptr; +begin + coef := my_coef_ptr (cinfo^.coef); + + { In an interleaved scan, an MCU row is the same as an iMCU row. + In a noninterleaved scan, an iMCU row has v_samp_factor MCU rows. + But at the bottom of the image, process only what's left. } + if (cinfo^.comps_in_scan > 1) then + begin + coef^.MCU_rows_per_iMCU_row := 1; + end + else + begin + if (coef^.iMCU_row_num < (cinfo^.total_iMCU_rows-1)) then + coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.v_samp_factor + else + coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.last_row_height; + end; + + coef^.mcu_ctr := 0; + coef^.MCU_vert_offset := 0; +end; + + +{ Initialize for a processing pass. } + +{METHODDEF} +procedure start_pass_coef (cinfo : j_compress_ptr; + pass_mode : J_BUF_MODE); +var + coef : my_coef_ptr; +begin + coef := my_coef_ptr (cinfo^.coef); + + coef^.iMCU_row_num := 0; + start_iMCU_row(cinfo); + + case (pass_mode) of + JBUF_PASS_THRU: + begin + if (coef^.whole_image[0] <> NIL) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + coef^.pub.compress_data := compress_data; + end; +{$ifdef FULL_COEF_BUFFER_SUPPORTED} + JBUF_SAVE_AND_PASS: + begin + if (coef^.whole_image[0] = NIL) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + coef^.pub.compress_data := compress_first_pass; + end; + JBUF_CRANK_DEST: + begin + if (coef^.whole_image[0] = NIL) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + coef^.pub.compress_data := compress_output; + end; +{$endif} + else + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + end; +end; + + +{ Process some data in the single-pass case. + We process the equivalent of one fully interleaved MCU row ("iMCU" row) + per call, ie, v_samp_factor block rows for each component in the image. + Returns TRUE if the iMCU row is completed, FALSE if suspended. + + NB: input_buf contains a plane for each component in image, + which we index according to the component's SOF position. } + + +{METHODDEF} +function compress_data (cinfo : j_compress_ptr; + input_buf : JSAMPIMAGE) : boolean; +var + coef : my_coef_ptr; + MCU_col_num : JDIMENSION; { index of current MCU within row } + last_MCU_col : JDIMENSION; + last_iMCU_row : JDIMENSION; + blkn, bi, ci, yindex, yoffset, blockcnt : int; + ypos, xpos : JDIMENSION; + compptr : jpeg_component_info_ptr; +begin + coef := my_coef_ptr (cinfo^.coef); + last_MCU_col := cinfo^.MCUs_per_row - 1; + last_iMCU_row := cinfo^.total_iMCU_rows - 1; + + { Loop to write as much as one whole iMCU row } + for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do + begin + for MCU_col_num := coef^.mcu_ctr to last_MCU_col do + begin + { Determine where data comes from in input_buf and do the DCT thing. + Each call on forward_DCT processes a horizontal row of DCT blocks + as wide as an MCU; we rely on having allocated the MCU_buffer[] blocks + sequentially. Dummy blocks at the right or bottom edge are filled in + specially. The data in them does not matter for image reconstruction, + so we fill them with values that will encode to the smallest amount of + data, viz: all zeroes in the AC entries, DC entries equal to previous + block's DC value. (Thanks to Thomas Kinsman for this idea.) } + + blkn := 0; + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + if (MCU_col_num < last_MCU_col) then + blockcnt := compptr^.MCU_width + else + blockcnt := compptr^.last_col_width; + xpos := MCU_col_num * JDIMENSION(compptr^.MCU_sample_width); + ypos := yoffset * DCTSIZE; { ypos = (yoffset+yindex) * DCTSIZE } + for yindex := 0 to pred(compptr^.MCU_height) do + begin + if (coef^.iMCU_row_num < last_iMCU_row) or + (yoffset+yindex < compptr^.last_row_height) then + begin + cinfo^.fdct^.forward_DCT (cinfo, compptr, + input_buf^[compptr^.component_index], + coef^.MCU_buffer[blkn], + ypos, xpos, JDIMENSION (blockcnt)); + + if (blockcnt < compptr^.MCU_width) then + begin + { Create some dummy blocks at the right edge of the image. } + jzero_far({FAR}pointer(coef^.MCU_buffer[blkn + blockcnt]), + (compptr^.MCU_width - blockcnt) * SIZEOF(JBLOCK)); + for bi := blockcnt to pred(compptr^.MCU_width) do + begin + coef^.MCU_buffer[blkn+bi]^[0][0] := coef^.MCU_buffer[blkn+bi-1]^[0][0]; + end; + end; + end + else + begin + { Create a row of dummy blocks at the bottom of the image. } + jzero_far({FAR}pointer(coef^.MCU_buffer[blkn]), + compptr^.MCU_width * SIZEOF(JBLOCK)); + for bi := 0 to pred(compptr^.MCU_width) do + begin + coef^.MCU_buffer[blkn+bi]^[0][0] := coef^.MCU_buffer[blkn-1]^[0][0]; + end; + end; + Inc(blkn, compptr^.MCU_width); + Inc(ypos, DCTSIZE); + end; + end; + { Try to write the MCU. In event of a suspension failure, we will + re-DCT the MCU on restart (a bit inefficient, could be fixed...) } + + if (not cinfo^.entropy^.encode_mcu (cinfo, JBLOCKARRAY(@coef^.MCU_buffer)^)) then + begin + { Suspension forced; update state counters and exit } + coef^.MCU_vert_offset := yoffset; + coef^.mcu_ctr := MCU_col_num; + compress_data := FALSE; + exit; + end; + end; + { Completed an MCU row, but perhaps not an iMCU row } + coef^.mcu_ctr := 0; + end; + { Completed the iMCU row, advance counters for next one } + Inc(coef^.iMCU_row_num); + start_iMCU_row(cinfo); + compress_data := TRUE; +end; + + +{$ifdef FULL_COEF_BUFFER_SUPPORTED} + +{ Process some data in the first pass of a multi-pass case. + We process the equivalent of one fully interleaved MCU row ("iMCU" row) + per call, ie, v_samp_factor block rows for each component in the image. + This amount of data is read from the source buffer, DCT'd and quantized, + and saved into the virtual arrays. We also generate suitable dummy blocks + as needed at the right and lower edges. (The dummy blocks are constructed + in the virtual arrays, which have been padded appropriately.) This makes + it possible for subsequent passes not to worry about real vs. dummy blocks. + + We must also emit the data to the entropy encoder. This is conveniently + done by calling compress_output() after we've loaded the current strip + of the virtual arrays. + + NB: input_buf contains a plane for each component in image. All + components are DCT'd and loaded into the virtual arrays in this pass. + However, it may be that only a subset of the components are emitted to + the entropy encoder during this first pass; be careful about looking + at the scan-dependent variables (MCU dimensions, etc). } + +{METHODDEF} +function compress_first_pass (cinfo : j_compress_ptr; + input_buf : JSAMPIMAGE) : boolean; +var + coef : my_coef_ptr; + last_iMCU_row : JDIMENSION; + blocks_across, MCUs_across, MCUindex : JDIMENSION; + bi, ci, h_samp_factor, block_row, block_rows, ndummy : int; + lastDC : JCOEF; + compptr : jpeg_component_info_ptr; + buffer : JBLOCKARRAY; + thisblockrow, lastblockrow : JBLOCKROW; +begin + coef := my_coef_ptr (cinfo^.coef); + last_iMCU_row := cinfo^.total_iMCU_rows - 1; + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + { Align the virtual buffer for this component. } + buffer := cinfo^.mem^.access_virt_barray + (j_common_ptr(cinfo), coef^.whole_image[ci], + coef^.iMCU_row_num * JDIMENSION(compptr^.v_samp_factor), + JDIMENSION (compptr^.v_samp_factor), TRUE); + { Count non-dummy DCT block rows in this iMCU row. } + if (coef^.iMCU_row_num < last_iMCU_row) then + block_rows := compptr^.v_samp_factor + else + begin + { NB: can't use last_row_height here, since may not be set! } + block_rows := int (compptr^.height_in_blocks) mod compptr^.v_samp_factor; + if (block_rows = 0) then + block_rows := compptr^.v_samp_factor; + end; + blocks_across := compptr^.width_in_blocks; + h_samp_factor := compptr^.h_samp_factor; + { Count number of dummy blocks to be added at the right margin. } + ndummy := int (blocks_across) mod h_samp_factor; + if (ndummy > 0) then + ndummy := h_samp_factor - ndummy; + { Perform DCT for all non-dummy blocks in this iMCU row. Each call + on forward_DCT processes a complete horizontal row of DCT blocks. } + + for block_row := 0 to pred(block_rows) do + begin + thisblockrow := buffer^[block_row]; + cinfo^.fdct^.forward_DCT (cinfo, compptr, + input_buf^[ci], + thisblockrow, + JDIMENSION (block_row * DCTSIZE), + JDIMENSION (0), + blocks_across); + if (ndummy > 0) then + begin + { Create dummy blocks at the right edge of the image. } + Inc(JBLOCK_PTR(thisblockrow), blocks_across); { => first dummy block } + jzero_far({FAR}pointer(thisblockrow), ndummy * SIZEOF(JBLOCK)); + {lastDC := thisblockrow^[-1][0];} + { work around Range Checking } + Dec(JBLOCK_PTR(thisblockrow)); + lastDC := thisblockrow^[0][0]; + Inc(JBLOCK_PTR(thisblockrow)); + + for bi := 0 to pred(ndummy) do + begin + thisblockrow^[bi][0] := lastDC; + end; + end; + end; + { If at end of image, create dummy block rows as needed. + The tricky part here is that within each MCU, we want the DC values + of the dummy blocks to match the last real block's DC value. + This squeezes a few more bytes out of the resulting file... } + + if (coef^.iMCU_row_num = last_iMCU_row) then + begin + Inc(blocks_across, ndummy); { include lower right corner } + MCUs_across := blocks_across div JDIMENSION(h_samp_factor); + for block_row := block_rows to pred(compptr^.v_samp_factor) do + begin + thisblockrow := buffer^[block_row]; + lastblockrow := buffer^[block_row-1]; + jzero_far({FAR} pointer(thisblockrow), + size_t(blocks_across * SIZEOF(JBLOCK))); + for MCUindex := 0 to pred(MCUs_across) do + begin + lastDC := lastblockrow^[h_samp_factor-1][0]; + for bi := 0 to pred(h_samp_factor) do + begin + thisblockrow^[bi][0] := lastDC; + end; + Inc(JBLOCK_PTR(thisblockrow), h_samp_factor); { advance to next MCU in row } + Inc(JBLOCK_PTR(lastblockrow), h_samp_factor); + end; + end; + end; + Inc(compptr); + end; + { NB: compress_output will increment iMCU_row_num if successful. + A suspension return will result in redoing all the work above next time.} + + + { Emit data to the entropy encoder, sharing code with subsequent passes } + compress_first_pass := compress_output(cinfo, input_buf); +end; + + +{ Process some data in subsequent passes of a multi-pass case. + We process the equivalent of one fully interleaved MCU row ("iMCU" row) + per call, ie, v_samp_factor block rows for each component in the scan. + The data is obtained from the virtual arrays and fed to the entropy coder. + Returns TRUE if the iMCU row is completed, FALSE if suspended. + + NB: input_buf is ignored; it is likely to be a NIL pointer. } + +{METHODDEF} +function compress_output (cinfo : j_compress_ptr; + input_buf : JSAMPIMAGE) : boolean; +var + coef : my_coef_ptr; + MCU_col_num : JDIMENSION; { index of current MCU within row } + blkn, ci, xindex, yindex, yoffset : int; + start_col : JDIMENSION; + buffer : array[0..MAX_COMPS_IN_SCAN-1] of JBLOCKARRAY; + buffer_ptr : JBLOCKROW; + compptr : jpeg_component_info_ptr; +begin + coef := my_coef_ptr (cinfo^.coef); + + { Align the virtual buffers for the components used in this scan. + NB: during first pass, this is safe only because the buffers will + already be aligned properly, so jmemmgr.c won't need to do any I/O. } + + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + buffer[ci] := cinfo^.mem^.access_virt_barray ( + j_common_ptr(cinfo), coef^.whole_image[compptr^.component_index], + coef^.iMCU_row_num * JDIMENSION(compptr^.v_samp_factor), + JDIMENSION (compptr^.v_samp_factor), FALSE); + end; + + { Loop to process one whole iMCU row } + for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do + begin + for MCU_col_num := coef^.mcu_ctr to pred(cinfo^.MCUs_per_row) do + begin + { Construct list of pointers to DCT blocks belonging to this MCU } + blkn := 0; { index of current DCT block within MCU } + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + start_col := MCU_col_num * JDIMENSION(compptr^.MCU_width); + for yindex := 0 to pred(compptr^.MCU_height) do + begin + buffer_ptr := JBLOCKROW(@ buffer[ci]^[yindex+yoffset]^[start_col]); + for xindex := 0 to pred(compptr^.MCU_width) do + begin + coef^.MCU_buffer[blkn] := buffer_ptr; + Inc(blkn); + Inc(JBLOCK_PTR(buffer_ptr)); + end; + end; + end; + { Try to write the MCU. } + if (not cinfo^.entropy^.encode_mcu (cinfo, coef^.MCU_buffer)) then + begin + { Suspension forced; update state counters and exit } + coef^.MCU_vert_offset := yoffset; + coef^.mcu_ctr := MCU_col_num; + compress_output := FALSE; + exit; + end; + end; + { Completed an MCU row, but perhaps not an iMCU row } + coef^.mcu_ctr := 0; + end; + { Completed the iMCU row, advance counters for next one } + Inc(coef^.iMCU_row_num); + start_iMCU_row(cinfo); + compress_output := TRUE; +end; + +{$endif} { FULL_COEF_BUFFER_SUPPORTED } + + +{ Initialize coefficient buffer controller. } + +{GLOBAL} +procedure jinit_c_coef_controller (cinfo : j_compress_ptr; + need_full_buffer : boolean); +var + coef : my_coef_ptr; +var + buffer : JBLOCKROW; + i : int; +var + ci : int; + compptr : jpeg_component_info_ptr; +begin + coef := my_coef_ptr ( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_coef_controller)) ); + cinfo^.coef := jpeg_c_coef_controller_ptr(coef); + coef^.pub.start_pass := start_pass_coef; + + { Create the coefficient buffer. } + if (need_full_buffer) then + begin +{$ifdef FULL_COEF_BUFFER_SUPPORTED} + { Allocate a full-image virtual array for each component, } + { padded to a multiple of samp_factor DCT blocks in each direction. } + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + coef^.whole_image[ci] := cinfo^.mem^.request_virt_barray + (j_common_ptr(cinfo), JPOOL_IMAGE, FALSE, + JDIMENSION (jround_up( long (compptr^.width_in_blocks), + long (compptr^.h_samp_factor) )), + JDIMENSION (jround_up(long (compptr^.height_in_blocks), + long (compptr^.v_samp_factor))), + JDIMENSION (compptr^.v_samp_factor)); + Inc(compptr); + end; +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); +{$endif} + end + else + begin + { We only need a single-MCU buffer. } + buffer := JBLOCKROW ( + cinfo^.mem^.alloc_large (j_common_ptr(cinfo), JPOOL_IMAGE, + C_MAX_BLOCKS_IN_MCU * SIZEOF(JBLOCK)) ); + for i := 0 to pred(C_MAX_BLOCKS_IN_MCU) do + begin + coef^.MCU_buffer[i] := JBLOCKROW(@ buffer^[i]); + end; + coef^.whole_image[0] := NIL; { flag for no virtual arrays } + end; +end; + +end. diff --git a/Imaging/JpegLib/imjccolor.pas b/Imaging/JpegLib/imjccolor.pas index d29c876..96a4988 100644 --- a/Imaging/JpegLib/imjccolor.pas +++ b/Imaging/JpegLib/imjccolor.pas @@ -1,533 +1,530 @@ -unit imjccolor; - -{ This file contains input colorspace conversion routines. } - -{ Original : jccolor.c ; Copyright (C) 1991-1996, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjpeglib; - -{ Module initialization routine for input colorspace conversion. } - -{GLOBAL} -procedure jinit_color_converter (cinfo : j_compress_ptr); - -implementation - -{ Private subobject } -type - jTInt32 = 0..Pred(MaxInt div SizeOf(INT32)); - INT32_FIELD = array[jTInt32] of INT32; - INT32_FIELD_PTR = ^INT32_FIELD; - -type - my_cconvert_ptr = ^my_color_converter; - my_color_converter = record - pub : jpeg_color_converter; { public fields } - - { Private state for RGB -> YCC conversion } - rgb_ycc_tab : INT32_FIELD_PTR; { => table for RGB to YCbCr conversion } - end; {my_color_converter;} - - -{*************** RGB -> YCbCr conversion: most common case *************} - -{ - YCbCr is defined per CCIR 601-1, except that Cb and Cr are - normalized to the range 0..MAXJSAMPLE rather than -0.5 .. 0.5. - The conversion equations to be implemented are therefore - Y = 0.29900 * R + 0.58700 * G + 0.11400 * B - Cb = -0.16874 * R - 0.33126 * G + 0.50000 * B + CENTERJSAMPLE - Cr = 0.50000 * R - 0.41869 * G - 0.08131 * B + CENTERJSAMPLE - (These numbers are derived from TIFF 6.0 section 21, dated 3-June-92.) - Note: older versions of the IJG code used a zero offset of MAXJSAMPLE/2, - rather than CENTERJSAMPLE, for Cb and Cr. This gave equal positive and - negative swings for Cb/Cr, but meant that grayscale values (Cb=Cr=0) - were not represented exactly. Now we sacrifice exact representation of - maximum red and maximum blue in order to get exact grayscales. - - To avoid floating-point arithmetic, we represent the fractional constants - as integers scaled up by 2^16 (about 4 digits precision); we have to divide - the products by 2^16, with appropriate rounding, to get the correct answer. - - For even more speed, we avoid doing any multiplications in the inner loop - by precalculating the constants times R,G,B for all possible values. - For 8-bit JSAMPLEs this is very reasonable (only 256 entries per table); - for 12-bit samples it is still acceptable. It's not very reasonable for - 16-bit samples, but if you want lossless storage you shouldn't be changing - colorspace anyway. - The CENTERJSAMPLE offsets and the rounding fudge-factor of 0.5 are included - in the tables to save adding them separately in the inner loop. } -const - SCALEBITS = 16; { speediest right-shift on some machines } - CBCR_OFFSET = INT32(CENTERJSAMPLE shl SCALEBITS); - ONE_HALF = INT32(1) shl (SCALEBITS-1); - - -{ We allocate one big table and divide it up into eight parts, instead of - doing eight alloc_small requests. This lets us use a single table base - address, which can be held in a register in the inner loops on many - machines (more than can hold all eight addresses, anyway). } - - R_Y_OFF = 0; { offset to R => Y section } - G_Y_OFF = 1*(MAXJSAMPLE+1); { offset to G => Y section } - B_Y_OFF = 2*(MAXJSAMPLE+1); { etc. } - R_CB_OFF = 3*(MAXJSAMPLE+1); - G_CB_OFF = 4*(MAXJSAMPLE+1); - B_CB_OFF = 5*(MAXJSAMPLE+1); - R_CR_OFF = B_CB_OFF; { B=>Cb, R=>Cr are the same } - G_CR_OFF = 6*(MAXJSAMPLE+1); - B_CR_OFF = 7*(MAXJSAMPLE+1); - TABLE_SIZE = 8*(MAXJSAMPLE+1); - - -{ Initialize for RGB->YCC colorspace conversion. } - -{METHODDEF} -procedure rgb_ycc_start (cinfo : j_compress_ptr); -const - FIX_0_29900 = INT32(Round (0.29900 * (1 shl SCALEBITS)) ); - FIX_0_58700 = INT32(Round (0.58700 * (1 shl SCALEBITS)) ); - FIX_0_11400 = INT32(Round (0.11400 * (1 shl SCALEBITS)) ); - FIX_0_16874 = INT32(Round (0.16874 * (1 shl SCALEBITS)) ); - FIX_0_33126 = INT32(Round (0.33126 * (1 shl SCALEBITS)) ); - FIX_0_50000 = INT32(Round (0.50000 * (1 shl SCALEBITS)) ); - FIX_0_41869 = INT32(Round (0.41869 * (1 shl SCALEBITS)) ); - FIX_0_08131 = INT32(Round (0.08131 * (1 shl SCALEBITS)) ); -var - cconvert : my_cconvert_ptr; - rgb_ycc_tab : INT32_FIELD_PTR; - i : INT32; -begin - cconvert := my_cconvert_ptr (cinfo^.cconvert); - - { Allocate and fill in the conversion tables. } - rgb_ycc_tab := INT32_FIELD_PTR( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - (TABLE_SIZE * SIZEOF(INT32))) ); - cconvert^.rgb_ycc_tab := rgb_ycc_tab; - - for i := 0 to MAXJSAMPLE do - begin - rgb_ycc_tab^[i+R_Y_OFF] := FIX_0_29900 * i; - rgb_ycc_tab^[i+G_Y_OFF] := FIX_0_58700 * i; - rgb_ycc_tab^[i+B_Y_OFF] := FIX_0_11400 * i + ONE_HALF; - rgb_ycc_tab^[i+R_CB_OFF] := (-FIX_0_16874) * i; - rgb_ycc_tab^[i+G_CB_OFF] := (-FIX_0_33126) * i; - { We use a rounding fudge-factor of 0.5-epsilon for Cb and Cr. - This ensures that the maximum output will round to MAXJSAMPLE - not MAXJSAMPLE+1, and thus that we don't have to range-limit. } - - rgb_ycc_tab^[i+B_CB_OFF] := FIX_0_50000 * i + CBCR_OFFSET + ONE_HALF-1; -{ B=>Cb and R=>Cr tables are the same - rgb_ycc_tab^[i+R_CR_OFF] := FIX_0_50000 * i + CBCR_OFFSET + ONE_HALF-1; -} - rgb_ycc_tab^[i+G_CR_OFF] := (-FIX_0_41869) * i; - rgb_ycc_tab^[i+B_CR_OFF] := (-FIX_0_08131) * i; - end; -end; - - -{ Convert some rows of samples to the JPEG colorspace. - - Note that we change from the application's interleaved-pixel format - to our internal noninterleaved, one-plane-per-component format. - The input buffer is therefore three times as wide as the output buffer. - - A starting row offset is provided only for the output buffer. The caller - can easily adjust the passed input_buf value to accommodate any row - offset required on that side. } - -{METHODDEF} -procedure rgb_ycc_convert (cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPIMAGE; - output_row : JDIMENSION; - num_rows : int); -var - cconvert : my_cconvert_ptr; - {register} r, g, b : int; - {register} ctab : INT32_FIELD_PTR; - {register} inptr : JSAMPROW; - {register} outptr0, outptr1, outptr2 : JSAMPROW; - {register} col : JDIMENSION; - num_cols : JDIMENSION; -begin - cconvert := my_cconvert_ptr (cinfo^.cconvert); - ctab := cconvert^.rgb_ycc_tab; - num_cols := cinfo^.image_width; - - while (num_rows > 0) do - begin - Dec(num_rows); - inptr := input_buf^[0]; - Inc(JSAMPROW_PTR(input_buf)); - outptr0 := output_buf^[0]^[output_row]; - outptr1 := output_buf^[1]^[output_row]; - outptr2 := output_buf^[2]^[output_row]; - Inc(output_row); - for col := 0 to pred(num_cols) do - begin - r := GETJSAMPLE(inptr^[RGB_RED]); - g := GETJSAMPLE(inptr^[RGB_GREEN]); - b := GETJSAMPLE(inptr^[RGB_BLUE]); - Inc(JSAMPLE_PTR(inptr), RGB_PIXELSIZE); - { If the inputs are 0..MAXJSAMPLE, the outputs of these equations - must be too; we do not need an explicit range-limiting operation. - Hence the value being shifted is never negative, and we don't - need the general RIGHT_SHIFT macro. } - - { Y } - outptr0^[col] := JSAMPLE( - ((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF]) - shr SCALEBITS) ); - { Cb } - outptr1^[col] := JSAMPLE( - ((ctab^[r+R_CB_OFF] + ctab^[g+G_CB_OFF] + ctab^[b+B_CB_OFF]) - shr SCALEBITS) ); - { Cr } - outptr2^[col] := JSAMPLE( - ((ctab^[r+R_CR_OFF] + ctab^[g+G_CR_OFF] + ctab^[b+B_CR_OFF]) - shr SCALEBITS) ); - end; - end; -end; - - -{*************** Cases other than RGB -> YCbCr *************} - - -{ Convert some rows of samples to the JPEG colorspace. - This version handles RGB -> grayscale conversion, which is the same - as the RGB -> Y portion of RGB -> YCbCr. - We assume rgb_ycc_start has been called (we only use the Y tables). } - -{METHODDEF} -procedure rgb_gray_convert (cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPIMAGE; - output_row : JDIMENSION; - num_rows : int); -var - cconvert : my_cconvert_ptr; - {register} r, g, b : int; - {register} ctab :INT32_FIELD_PTR; - {register} inptr : JSAMPROW; - {register} outptr : JSAMPROW; - {register} col : JDIMENSION; - num_cols : JDIMENSION; -begin - cconvert := my_cconvert_ptr (cinfo^.cconvert); - ctab := cconvert^.rgb_ycc_tab; - num_cols := cinfo^.image_width; - - while (num_rows > 0) do - begin - Dec(num_rows); - inptr := input_buf^[0]; - Inc(JSAMPROW_PTR(input_buf)); - outptr := output_buf^[0]^[output_row]; - Inc(output_row); - for col := 0 to pred(num_cols) do - begin - r := GETJSAMPLE(inptr^[RGB_RED]); - g := GETJSAMPLE(inptr^[RGB_GREEN]); - b := GETJSAMPLE(inptr^[RGB_BLUE]); - Inc(JSAMPLE_PTR(inptr), RGB_PIXELSIZE); - (* Y *) - // kylix 3 compiler crashes on this - {$IF (not Defined(LINUX)) or Defined(FPC)} - outptr^[col] := JSAMPLE ( - ((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF]) - shr SCALEBITS) ); - {$IFEND} - end; - end; - -end; - - -{ Convert some rows of samples to the JPEG colorspace. - This version handles Adobe-style CMYK -> YCCK conversion, - where we convert R=1-C, G=1-M, and B=1-Y to YCbCr using the same - conversion as above, while passing K (black) unchanged. - We assume rgb_ycc_start has been called. } - -{METHODDEF} -procedure cmyk_ycck_convert (cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPIMAGE; - output_row : JDIMENSION; - num_rows : int); -var - cconvert : my_cconvert_ptr; - {register} r, g, b : int; - {register} ctab : INT32_FIELD_PTR; - {register} inptr : JSAMPROW; - {register} outptr0, outptr1, outptr2, outptr3 : JSAMPROW; - {register} col : JDIMENSION; - num_cols : JDIMENSION; -begin - cconvert := my_cconvert_ptr (cinfo^.cconvert); - ctab := cconvert^.rgb_ycc_tab; - num_cols := cinfo^.image_width; - - while (num_rows > 0) do - begin - Dec(num_rows); - inptr := input_buf^[0]; - Inc(JSAMPROW_PTR(input_buf)); - outptr0 := output_buf^[0]^[output_row]; - outptr1 := output_buf^[1]^[output_row]; - outptr2 := output_buf^[2]^[output_row]; - outptr3 := output_buf^[3]^[output_row]; - Inc(output_row); - for col := 0 to pred(num_cols) do - begin - r := MAXJSAMPLE - GETJSAMPLE(inptr^[0]); - g := MAXJSAMPLE - GETJSAMPLE(inptr^[1]); - b := MAXJSAMPLE - GETJSAMPLE(inptr^[2]); - { K passes through as-is } - outptr3^[col] := inptr^[3]; { don't need GETJSAMPLE here } - Inc(JSAMPLE_PTR(inptr), 4); - { If the inputs are 0..MAXJSAMPLE, the outputs of these equations - must be too; we do not need an explicit range-limiting operation. - Hence the value being shifted is never negative, and we don't - need the general RIGHT_SHIFT macro. } - - { Y } - outptr0^[col] := JSAMPLE ( - ((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF]) - shr SCALEBITS) ); - { Cb } - outptr1^[col] := JSAMPLE( - ((ctab^[r+R_CB_OFF] + ctab^[g+G_CB_OFF] + ctab^[b+B_CB_OFF]) - shr SCALEBITS) ); - { Cr } - outptr2^[col] := JSAMPLE ( - ((ctab^[r+R_CR_OFF] + ctab^[g+G_CR_OFF] + ctab^[b+B_CR_OFF]) - shr SCALEBITS) ); - end; - end; -end; - - -{ Convert some rows of samples to the JPEG colorspace. - This version handles grayscale output with no conversion. - The source can be either plain grayscale or YCbCr (since Y = gray). } - -{METHODDEF} -procedure grayscale_convert (cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPIMAGE; - output_row : JDIMENSION; - num_rows: int); -var - {register} inptr : JSAMPROW; - {register} outptr : JSAMPROW; - {register} col : JDIMENSION; - num_cols :JDIMENSION; - instride : int; -begin - num_cols := cinfo^.image_width; - instride := cinfo^.input_components; - - while (num_rows > 0) do - begin - Dec(num_rows); - inptr := input_buf^[0]; - Inc(JSAMPROW_PTR(input_buf)); - outptr := output_buf^[0]^[output_row]; - Inc(output_row); - for col := 0 to pred(num_cols) do - begin - outptr^[col] := inptr^[0]; { don't need GETJSAMPLE() here } - Inc(JSAMPLE_PTR(inptr), instride); - end; - end; -end; - - -{ Convert some rows of samples to the JPEG colorspace. - This version handles multi-component colorspaces without conversion. - We assume input_components = num_components. } - -{METHODDEF} -procedure null_convert (cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPIMAGE; - output_row : JDIMENSION; - num_rows : int); -var - {register} inptr : JSAMPROW; - {register} outptr : JSAMPROW; - {register} col : JDIMENSION; - {register} ci : int; - nc : int; - num_cols : JDIMENSION; -begin - nc := cinfo^.num_components; - num_cols := cinfo^.image_width; - - while (num_rows > 0) do - begin - Dec(num_rows); - { It seems fastest to make a separate pass for each component. } - for ci := 0 to pred(nc) do - begin - inptr := input_buf^[0]; - outptr := output_buf^[ci]^[output_row]; - for col := 0 to pred(num_cols) do - begin - outptr^[col] := inptr^[ci]; { don't need GETJSAMPLE() here } - Inc(JSAMPLE_PTR(inptr), nc); - end; - end; - Inc(JSAMPROW_PTR(input_buf)); - Inc(output_row); - end; -end; - - -{ Empty method for start_pass. } - -{METHODDEF} -procedure null_method (cinfo : j_compress_ptr); -begin - { no work needed } -end; - - -{ Module initialization routine for input colorspace conversion. } - -{GLOBAL} -procedure jinit_color_converter (cinfo : j_compress_ptr); -var - cconvert : my_cconvert_ptr; -begin - cconvert := my_cconvert_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_color_converter)) ); - cinfo^.cconvert := jpeg_color_converter_ptr(cconvert); - { set start_pass to null method until we find out differently } - cconvert^.pub.start_pass := null_method; - - { Make sure input_components agrees with in_color_space } - case (cinfo^.in_color_space) of - JCS_GRAYSCALE: - if (cinfo^.input_components <> 1) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); - -{$ifdef RGB_PIXELSIZE <> 3} - JCS_RGB: - if (cinfo^.input_components <> RGB_PIXELSIZE) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); -{$else} { share code with YCbCr } - JCS_RGB, -{$endif} - JCS_YCbCr: - if (cinfo^.input_components <> 3) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); - - JCS_CMYK, - JCS_YCCK: - if (cinfo^.input_components <> 4) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); - - else { JCS_UNKNOWN can be anything } - if (cinfo^.input_components < 1) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); - end; - - { Check num_components, set conversion method based on requested space } - case (cinfo^.jpeg_color_space) of - JCS_GRAYSCALE: - begin - if (cinfo^.num_components <> 1) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); - if (cinfo^.in_color_space = JCS_GRAYSCALE) then - cconvert^.pub.color_convert := grayscale_convert - else - if (cinfo^.in_color_space = JCS_RGB) then - begin - cconvert^.pub.start_pass := rgb_ycc_start; - cconvert^.pub.color_convert := rgb_gray_convert; - end - else - if (cinfo^.in_color_space = JCS_YCbCr) then - cconvert^.pub.color_convert := grayscale_convert - else - ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); - end; - - JCS_RGB: - begin - if (cinfo^.num_components <> 3) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); - if (cinfo^.in_color_space = JCS_RGB) and (RGB_PIXELSIZE = 3) then - cconvert^.pub.color_convert := null_convert - else - ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); - end; - - JCS_YCbCr: - begin - if (cinfo^.num_components <> 3) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); - if (cinfo^.in_color_space = JCS_RGB) then - begin - cconvert^.pub.start_pass := rgb_ycc_start; - cconvert^.pub.color_convert := rgb_ycc_convert; - end - else - if (cinfo^.in_color_space = JCS_YCbCr) then - cconvert^.pub.color_convert := null_convert - else - ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); - end; - - JCS_CMYK: - begin - if (cinfo^.num_components <> 4) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); - if (cinfo^.in_color_space = JCS_CMYK) then - cconvert^.pub.color_convert := null_convert - else - ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); - end; - - JCS_YCCK: - begin - if (cinfo^.num_components <> 4) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); - if (cinfo^.in_color_space = JCS_CMYK) then - begin - cconvert^.pub.start_pass := rgb_ycc_start; - cconvert^.pub.color_convert := cmyk_ycck_convert; - end - else - if (cinfo^.in_color_space = JCS_YCCK) then - cconvert^.pub.color_convert := null_convert - else - ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); - end; - - else { allow null conversion of JCS_UNKNOWN } - begin - if (cinfo^.jpeg_color_space <> cinfo^.in_color_space) or - (cinfo^.num_components <> cinfo^.input_components) then - ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); - cconvert^.pub.color_convert := null_convert; - end; - end; -end; - -end. +unit imjccolor; + +{ This file contains input colorspace conversion routines. } + +{ Original : jccolor.c ; Copyright (C) 1991-1996, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjpeglib; + +{ Module initialization routine for input colorspace conversion. } + +{GLOBAL} +procedure jinit_color_converter (cinfo : j_compress_ptr); + +implementation + +{ Private subobject } +type + INT32_FIELD = array[0..MaxInt div SizeOf(INT32) - 1] of INT32; + INT32_FIELD_PTR = ^INT32_FIELD; + +type + my_cconvert_ptr = ^my_color_converter; + my_color_converter = record + pub : jpeg_color_converter; { public fields } + + { Private state for RGB -> YCC conversion } + rgb_ycc_tab : INT32_FIELD_PTR; { => table for RGB to YCbCr conversion } + end; {my_color_converter;} + + +{*************** RGB -> YCbCr conversion: most common case *************} + +{ + YCbCr is defined per CCIR 601-1, except that Cb and Cr are + normalized to the range 0..MAXJSAMPLE rather than -0.5 .. 0.5. + The conversion equations to be implemented are therefore + Y = 0.29900 * R + 0.58700 * G + 0.11400 * B + Cb = -0.16874 * R - 0.33126 * G + 0.50000 * B + CENTERJSAMPLE + Cr = 0.50000 * R - 0.41869 * G - 0.08131 * B + CENTERJSAMPLE + (These numbers are derived from TIFF 6.0 section 21, dated 3-June-92.) + Note: older versions of the IJG code used a zero offset of MAXJSAMPLE/2, + rather than CENTERJSAMPLE, for Cb and Cr. This gave equal positive and + negative swings for Cb/Cr, but meant that grayscale values (Cb=Cr=0) + were not represented exactly. Now we sacrifice exact representation of + maximum red and maximum blue in order to get exact grayscales. + + To avoid floating-point arithmetic, we represent the fractional constants + as integers scaled up by 2^16 (about 4 digits precision); we have to divide + the products by 2^16, with appropriate rounding, to get the correct answer. + + For even more speed, we avoid doing any multiplications in the inner loop + by precalculating the constants times R,G,B for all possible values. + For 8-bit JSAMPLEs this is very reasonable (only 256 entries per table); + for 12-bit samples it is still acceptable. It's not very reasonable for + 16-bit samples, but if you want lossless storage you shouldn't be changing + colorspace anyway. + The CENTERJSAMPLE offsets and the rounding fudge-factor of 0.5 are included + in the tables to save adding them separately in the inner loop. } +const + SCALEBITS = 16; { speediest right-shift on some machines } + CBCR_OFFSET = INT32(CENTERJSAMPLE shl SCALEBITS); + ONE_HALF = INT32(1) shl (SCALEBITS-1); + + +{ We allocate one big table and divide it up into eight parts, instead of + doing eight alloc_small requests. This lets us use a single table base + address, which can be held in a register in the inner loops on many + machines (more than can hold all eight addresses, anyway). } + + R_Y_OFF = 0; { offset to R => Y section } + G_Y_OFF = 1*(MAXJSAMPLE+1); { offset to G => Y section } + B_Y_OFF = 2*(MAXJSAMPLE+1); { etc. } + R_CB_OFF = 3*(MAXJSAMPLE+1); + G_CB_OFF = 4*(MAXJSAMPLE+1); + B_CB_OFF = 5*(MAXJSAMPLE+1); + R_CR_OFF = B_CB_OFF; { B=>Cb, R=>Cr are the same } + G_CR_OFF = 6*(MAXJSAMPLE+1); + B_CR_OFF = 7*(MAXJSAMPLE+1); + TABLE_SIZE = 8*(MAXJSAMPLE+1); + + +{ Initialize for RGB->YCC colorspace conversion. } + +{METHODDEF} +procedure rgb_ycc_start (cinfo : j_compress_ptr); +const + FIX_0_29900 = INT32(Round(0.29900 * (1 shl SCALEBITS))); + FIX_0_58700 = INT32(Round(0.58700 * (1 shl SCALEBITS))); + FIX_0_11400 = INT32(Round(0.11400 * (1 shl SCALEBITS))); + FIX_0_16874 = INT32(Round(0.16874 * (1 shl SCALEBITS))); + FIX_0_33126 = INT32(Round(0.33126 * (1 shl SCALEBITS))); + FIX_0_50000 = INT32(Round(0.50000 * (1 shl SCALEBITS))); + FIX_0_41869 = INT32(Round(0.41869 * (1 shl SCALEBITS))); + FIX_0_08131 = INT32(Round(0.08131 * (1 shl SCALEBITS))); +var + cconvert : my_cconvert_ptr; + rgb_ycc_tab : INT32_FIELD_PTR; + i : INT32; +begin + cconvert := my_cconvert_ptr (cinfo^.cconvert); + + { Allocate and fill in the conversion tables. } + rgb_ycc_tab := INT32_FIELD_PTR( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + (TABLE_SIZE * SIZEOF(INT32))) ); + cconvert^.rgb_ycc_tab := rgb_ycc_tab; + + for i := 0 to MAXJSAMPLE do + begin + rgb_ycc_tab^[i+R_Y_OFF] := FIX_0_29900 * i; + rgb_ycc_tab^[i+G_Y_OFF] := FIX_0_58700 * i; + rgb_ycc_tab^[i+B_Y_OFF] := FIX_0_11400 * i + ONE_HALF; + rgb_ycc_tab^[i+R_CB_OFF] := (-FIX_0_16874) * i; + rgb_ycc_tab^[i+G_CB_OFF] := (-FIX_0_33126) * i; + { We use a rounding fudge-factor of 0.5-epsilon for Cb and Cr. + This ensures that the maximum output will round to MAXJSAMPLE + not MAXJSAMPLE+1, and thus that we don't have to range-limit. } + + rgb_ycc_tab^[i+B_CB_OFF] := FIX_0_50000 * i + CBCR_OFFSET + ONE_HALF-1; +{ B=>Cb and R=>Cr tables are the same + rgb_ycc_tab^[i+R_CR_OFF] := FIX_0_50000 * i + CBCR_OFFSET + ONE_HALF-1; +} + rgb_ycc_tab^[i+G_CR_OFF] := (-FIX_0_41869) * i; + rgb_ycc_tab^[i+B_CR_OFF] := (-FIX_0_08131) * i; + end; +end; + + +{ Convert some rows of samples to the JPEG colorspace. + + Note that we change from the application's interleaved-pixel format + to our internal noninterleaved, one-plane-per-component format. + The input buffer is therefore three times as wide as the output buffer. + + A starting row offset is provided only for the output buffer. The caller + can easily adjust the passed input_buf value to accommodate any row + offset required on that side. } + +{METHODDEF} +procedure rgb_ycc_convert (cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPIMAGE; + output_row : JDIMENSION; + num_rows : int); +var + cconvert : my_cconvert_ptr; + {register} r, g, b : int; + {register} ctab : INT32_FIELD_PTR; + {register} inptr : JSAMPROW; + {register} outptr0, outptr1, outptr2 : JSAMPROW; + {register} col : JDIMENSION; + num_cols : JDIMENSION; +begin + cconvert := my_cconvert_ptr (cinfo^.cconvert); + ctab := cconvert^.rgb_ycc_tab; + num_cols := cinfo^.image_width; + + while (num_rows > 0) do + begin + Dec(num_rows); + inptr := input_buf^[0]; + Inc(JSAMPROW_PTR(input_buf)); + outptr0 := output_buf^[0]^[output_row]; + outptr1 := output_buf^[1]^[output_row]; + outptr2 := output_buf^[2]^[output_row]; + Inc(output_row); + for col := 0 to pred(num_cols) do + begin + r := GETJSAMPLE(inptr^[RGB_RED]); + g := GETJSAMPLE(inptr^[RGB_GREEN]); + b := GETJSAMPLE(inptr^[RGB_BLUE]); + Inc(JSAMPLE_PTR(inptr), RGB_PIXELSIZE); + { If the inputs are 0..MAXJSAMPLE, the outputs of these equations + must be too; we do not need an explicit range-limiting operation. + Hence the value being shifted is never negative, and we don't + need the general RIGHT_SHIFT macro. } + + { Y } + outptr0^[col] := JSAMPLE( + ((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF]) + shr SCALEBITS) ); + { Cb } + outptr1^[col] := JSAMPLE( + ((ctab^[r+R_CB_OFF] + ctab^[g+G_CB_OFF] + ctab^[b+B_CB_OFF]) + shr SCALEBITS) ); + { Cr } + outptr2^[col] := JSAMPLE( + ((ctab^[r+R_CR_OFF] + ctab^[g+G_CR_OFF] + ctab^[b+B_CR_OFF]) + shr SCALEBITS) ); + end; + end; +end; + + +{*************** Cases other than RGB -> YCbCr *************} + + +{ Convert some rows of samples to the JPEG colorspace. + This version handles RGB -> grayscale conversion, which is the same + as the RGB -> Y portion of RGB -> YCbCr. + We assume rgb_ycc_start has been called (we only use the Y tables). } + +{METHODDEF} +procedure rgb_gray_convert (cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPIMAGE; + output_row : JDIMENSION; + num_rows : int); +var + cconvert : my_cconvert_ptr; + {register} r, g, b : int; + {register} ctab :INT32_FIELD_PTR; + {register} inptr : JSAMPROW; + {register} outptr : JSAMPROW; + {register} col : JDIMENSION; + num_cols : JDIMENSION; +begin + cconvert := my_cconvert_ptr (cinfo^.cconvert); + ctab := cconvert^.rgb_ycc_tab; + num_cols := cinfo^.image_width; + + while (num_rows > 0) do + begin + Dec(num_rows); + inptr := input_buf[0]; + Inc(JSAMPROW_PTR(input_buf)); + outptr := output_buf[0][output_row]; + Inc(output_row); + for col := 0 to num_cols - 1 do + begin + r := GETJSAMPLE(inptr[RGB_RED]); + g := GETJSAMPLE(inptr[RGB_GREEN]); + b := GETJSAMPLE(inptr[RGB_BLUE]); + Inc(JSAMPLE_PTR(inptr), RGB_PIXELSIZE); + (* Y *) + // kylix 3 compiler crashes on this + // it also crashes Delphi OSX compiler 9 years later :( + {$IF not (Defined(DCC) and not Defined(MSWINDOWS))} + outptr[col] := JSAMPLE(((ctab[r+R_Y_OFF] + ctab[g+G_Y_OFF] + ctab[b+B_Y_OFF]) shr SCALEBITS)); + {$IFEND} + end; + end; +end; + + +{ Convert some rows of samples to the JPEG colorspace. + This version handles Adobe-style CMYK -> YCCK conversion, + where we convert R=1-C, G=1-M, and B=1-Y to YCbCr using the same + conversion as above, while passing K (black) unchanged. + We assume rgb_ycc_start has been called. } + +{METHODDEF} +procedure cmyk_ycck_convert (cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPIMAGE; + output_row : JDIMENSION; + num_rows : int); +var + cconvert : my_cconvert_ptr; + {register} r, g, b : int; + {register} ctab : INT32_FIELD_PTR; + {register} inptr : JSAMPROW; + {register} outptr0, outptr1, outptr2, outptr3 : JSAMPROW; + {register} col : JDIMENSION; + num_cols : JDIMENSION; +begin + cconvert := my_cconvert_ptr (cinfo^.cconvert); + ctab := cconvert^.rgb_ycc_tab; + num_cols := cinfo^.image_width; + + while (num_rows > 0) do + begin + Dec(num_rows); + inptr := input_buf^[0]; + Inc(JSAMPROW_PTR(input_buf)); + outptr0 := output_buf^[0]^[output_row]; + outptr1 := output_buf^[1]^[output_row]; + outptr2 := output_buf^[2]^[output_row]; + outptr3 := output_buf^[3]^[output_row]; + Inc(output_row); + for col := 0 to pred(num_cols) do + begin + r := MAXJSAMPLE - GETJSAMPLE(inptr^[0]); + g := MAXJSAMPLE - GETJSAMPLE(inptr^[1]); + b := MAXJSAMPLE - GETJSAMPLE(inptr^[2]); + { K passes through as-is } + outptr3^[col] := inptr^[3]; { don't need GETJSAMPLE here } + Inc(JSAMPLE_PTR(inptr), 4); + { If the inputs are 0..MAXJSAMPLE, the outputs of these equations + must be too; we do not need an explicit range-limiting operation. + Hence the value being shifted is never negative, and we don't + need the general RIGHT_SHIFT macro. } + + { Y } + outptr0^[col] := JSAMPLE ( + ((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF]) + shr SCALEBITS) ); + { Cb } + outptr1^[col] := JSAMPLE( + ((ctab^[r+R_CB_OFF] + ctab^[g+G_CB_OFF] + ctab^[b+B_CB_OFF]) + shr SCALEBITS) ); + { Cr } + outptr2^[col] := JSAMPLE ( + ((ctab^[r+R_CR_OFF] + ctab^[g+G_CR_OFF] + ctab^[b+B_CR_OFF]) + shr SCALEBITS) ); + end; + end; +end; + + +{ Convert some rows of samples to the JPEG colorspace. + This version handles grayscale output with no conversion. + The source can be either plain grayscale or YCbCr (since Y = gray). } + +{METHODDEF} +procedure grayscale_convert (cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPIMAGE; + output_row : JDIMENSION; + num_rows: int); +var + {register} inptr : JSAMPROW; + {register} outptr : JSAMPROW; + {register} col : JDIMENSION; + num_cols :JDIMENSION; + instride : int; +begin + num_cols := cinfo^.image_width; + instride := cinfo^.input_components; + + while (num_rows > 0) do + begin + Dec(num_rows); + inptr := input_buf^[0]; + Inc(JSAMPROW_PTR(input_buf)); + outptr := output_buf^[0]^[output_row]; + Inc(output_row); + for col := 0 to pred(num_cols) do + begin + outptr^[col] := inptr^[0]; { don't need GETJSAMPLE() here } + Inc(JSAMPLE_PTR(inptr), instride); + end; + end; +end; + + +{ Convert some rows of samples to the JPEG colorspace. + This version handles multi-component colorspaces without conversion. + We assume input_components = num_components. } + +{METHODDEF} +procedure null_convert (cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPIMAGE; + output_row : JDIMENSION; + num_rows : int); +var + {register} inptr : JSAMPROW; + {register} outptr : JSAMPROW; + {register} col : JDIMENSION; + {register} ci : int; + nc : int; + num_cols : JDIMENSION; +begin + nc := cinfo^.num_components; + num_cols := cinfo^.image_width; + + while (num_rows > 0) do + begin + Dec(num_rows); + { It seems fastest to make a separate pass for each component. } + for ci := 0 to pred(nc) do + begin + inptr := input_buf^[0]; + outptr := output_buf^[ci]^[output_row]; + for col := 0 to pred(num_cols) do + begin + outptr^[col] := inptr^[ci]; { don't need GETJSAMPLE() here } + Inc(JSAMPLE_PTR(inptr), nc); + end; + end; + Inc(JSAMPROW_PTR(input_buf)); + Inc(output_row); + end; +end; + + +{ Empty method for start_pass. } + +{METHODDEF} +procedure null_method (cinfo : j_compress_ptr); +begin + { no work needed } +end; + + +{ Module initialization routine for input colorspace conversion. } + +{GLOBAL} +procedure jinit_color_converter (cinfo : j_compress_ptr); +var + cconvert : my_cconvert_ptr; +begin + cconvert := my_cconvert_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_color_converter)) ); + cinfo^.cconvert := jpeg_color_converter_ptr(cconvert); + { set start_pass to null method until we find out differently } + cconvert^.pub.start_pass := null_method; + + { Make sure input_components agrees with in_color_space } + case (cinfo^.in_color_space) of + JCS_GRAYSCALE: + if (cinfo^.input_components <> 1) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); + +{$ifdef RGB_PIXELSIZE <> 3} + JCS_RGB: + if (cinfo^.input_components <> RGB_PIXELSIZE) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); +{$else} { share code with YCbCr } + JCS_RGB, +{$endif} + JCS_YCbCr: + if (cinfo^.input_components <> 3) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); + + JCS_CMYK, + JCS_YCCK: + if (cinfo^.input_components <> 4) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); + + else { JCS_UNKNOWN can be anything } + if (cinfo^.input_components < 1) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); + end; + + { Check num_components, set conversion method based on requested space } + case (cinfo^.jpeg_color_space) of + JCS_GRAYSCALE: + begin + if (cinfo^.num_components <> 1) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); + if (cinfo^.in_color_space = JCS_GRAYSCALE) then + cconvert^.pub.color_convert := grayscale_convert + else + if (cinfo^.in_color_space = JCS_RGB) then + begin + cconvert^.pub.start_pass := rgb_ycc_start; + cconvert^.pub.color_convert := rgb_gray_convert; + end + else + if (cinfo^.in_color_space = JCS_YCbCr) then + cconvert^.pub.color_convert := grayscale_convert + else + ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); + end; + + JCS_RGB: + begin + if (cinfo^.num_components <> 3) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); + if (cinfo^.in_color_space = JCS_RGB) and (RGB_PIXELSIZE = 3) then + cconvert^.pub.color_convert := null_convert + else + ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); + end; + + JCS_YCbCr: + begin + if (cinfo^.num_components <> 3) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); + if (cinfo^.in_color_space = JCS_RGB) then + begin + cconvert^.pub.start_pass := rgb_ycc_start; + cconvert^.pub.color_convert := rgb_ycc_convert; + end + else + if (cinfo^.in_color_space = JCS_YCbCr) then + cconvert^.pub.color_convert := null_convert + else + ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); + end; + + JCS_CMYK: + begin + if (cinfo^.num_components <> 4) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); + if (cinfo^.in_color_space = JCS_CMYK) then + cconvert^.pub.color_convert := null_convert + else + ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); + end; + + JCS_YCCK: + begin + if (cinfo^.num_components <> 4) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); + if (cinfo^.in_color_space = JCS_CMYK) then + begin + cconvert^.pub.start_pass := rgb_ycc_start; + cconvert^.pub.color_convert := cmyk_ycck_convert; + end + else + if (cinfo^.in_color_space = JCS_YCCK) then + cconvert^.pub.color_convert := null_convert + else + ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); + end; + + else { allow null conversion of JCS_UNKNOWN } + begin + if (cinfo^.jpeg_color_space <> cinfo^.in_color_space) or + (cinfo^.num_components <> cinfo^.input_components) then + ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); + cconvert^.pub.color_convert := null_convert; + end; + end; +end; + +end. diff --git a/Imaging/JpegLib/imjcdctmgr.pas b/Imaging/JpegLib/imjcdctmgr.pas index 29c1dda..9f4442a 100644 --- a/Imaging/JpegLib/imjcdctmgr.pas +++ b/Imaging/JpegLib/imjcdctmgr.pas @@ -1,514 +1,513 @@ -unit imjcdctmgr; - -{ Original : jcdctmgr.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - -{ This file is part of the Independent JPEG Group's software. - For conditions of distribution and use, see the accompanying README file. - - This file contains the forward-DCT management logic. - This code selects a particular DCT implementation to be used, - and it performs related housekeeping chores including coefficient - quantization. } - -interface - -{$N+} -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjpeglib, - imjdct, { Private declarations for DCT subsystem } - imjfdctint, imjfdctfst, imjfdctflt; - -{ Initialize FDCT manager. } - -{GLOBAL} -procedure jinit_forward_dct (cinfo : j_compress_ptr); - -implementation - - -{ Private subobject for this module } - -type - my_fdct_ptr = ^my_fdct_controller; - my_fdct_controller = record - pub : jpeg_forward_dct; { public fields } - - { Pointer to the DCT routine actually in use } - do_dct : forward_DCT_method_ptr; - - { The actual post-DCT divisors --- not identical to the quant table - entries, because of scaling (especially for an unnormalized DCT). - Each table is given in normal array order. } - - divisors : array[0..NUM_QUANT_TBLS-1] of DCTELEM_FIELD_PTR; - - {$ifdef DCT_FLOAT_SUPPORTED} - { Same as above for the floating-point case. } - do_float_dct : float_DCT_method_ptr; - float_divisors : array[0..NUM_QUANT_TBLS-1] of FAST_FLOAT_FIELD_PTR; - {$endif} - end; - - -{ Initialize for a processing pass. - Verify that all referenced Q-tables are present, and set up - the divisor table for each one. - In the current implementation, DCT of all components is done during - the first pass, even if only some components will be output in the - first scan. Hence all components should be examined here. } - -{METHODDEF} -procedure start_pass_fdctmgr (cinfo : j_compress_ptr); -var - fdct : my_fdct_ptr; - ci, qtblno, i : int; - compptr : jpeg_component_info_ptr; - qtbl : JQUANT_TBL_PTR; - dtbl : DCTELEM_FIELD_PTR; -{$ifdef DCT_IFAST_SUPPORTED} -const - CONST_BITS = 14; - aanscales : array[0..DCTSIZE2-1] of INT16 = - ({ precomputed values scaled up by 14 bits } - 16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520, - 22725, 31521, 29692, 26722, 22725, 17855, 12299, 6270, - 21407, 29692, 27969, 25172, 21407, 16819, 11585, 5906, - 19266, 26722, 25172, 22654, 19266, 15137, 10426, 5315, - 16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520, - 12873, 17855, 16819, 15137, 12873, 10114, 6967, 3552, - 8867, 12299, 11585, 10426, 8867, 6967, 4799, 2446, - 4520, 6270, 5906, 5315, 4520, 3552, 2446, 1247); - {SHIFT_TEMPS} - - { Descale and correctly round an INT32 value that's scaled by N bits. - We assume RIGHT_SHIFT rounds towards minus infinity, so adding - the fudge factor is correct for either sign of X. } - - function DESCALE(x : INT32; n : int) : INT32; - var - shift_temp : INT32; - begin - shift_temp := x + (INT32(1) shl (n-1)); - {$ifdef RIGHT_SHIFT_IS_UNSIGNED} - if shift_temp < 0 then - Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) - else - {$endif} - Descale := (shift_temp shr n); - end; - -{$endif} -{$ifdef DCT_FLOAT_SUPPORTED} -var - fdtbl : FAST_FLOAT_FIELD_PTR; - row, col : int; -const - aanscalefactor : array[0..DCTSIZE-1] of double = - (1.0, 1.387039845, 1.306562965, 1.175875602, - 1.0, 0.785694958, 0.541196100, 0.275899379); -{$endif} -begin - fdct := my_fdct_ptr (cinfo^.fdct); - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - qtblno := compptr^.quant_tbl_no; - { Make sure specified quantization table is present } - if (qtblno < 0) or (qtblno >= NUM_QUANT_TBLS) or - (cinfo^.quant_tbl_ptrs[qtblno] = NIL) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, qtblno); - qtbl := cinfo^.quant_tbl_ptrs[qtblno]; - { Compute divisors for this quant table } - { We may do this more than once for same table, but it's not a big deal } - case (cinfo^.dct_method) of -{$ifdef DCT_ISLOW_SUPPORTED} - JDCT_ISLOW: - begin - { For LL&M IDCT method, divisors are equal to raw quantization - coefficients multiplied by 8 (to counteract scaling). } - - if (fdct^.divisors[qtblno] = NIL) then - begin - fdct^.divisors[qtblno] := DCTELEM_FIELD_PTR( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - DCTSIZE2 * SIZEOF(DCTELEM)) ); - end; - dtbl := fdct^.divisors[qtblno]; - for i := 0 to pred(DCTSIZE2) do - begin - dtbl^[i] := (DCTELEM(qtbl^.quantval[i])) shl 3; - end; - end; -{$endif} -{$ifdef DCT_IFAST_SUPPORTED} - JDCT_IFAST: - begin - { For AA&N IDCT method, divisors are equal to quantization - coefficients scaled by scalefactor[row]*scalefactor[col], where - scalefactor[0] := 1 - scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 - We apply a further scale factor of 8. } - - - if (fdct^.divisors[qtblno] = NIL) then - begin - fdct^.divisors[qtblno] := DCTELEM_FIELD_PTR( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - DCTSIZE2 * SIZEOF(DCTELEM)) ); - end; - dtbl := fdct^.divisors[qtblno]; - for i := 0 to pred(DCTSIZE2) do - begin - dtbl^[i] := DCTELEM( - {MULTIPLY16V16} - DESCALE( INT32(qtbl^.quantval[i]) * INT32 (aanscales[i]), - CONST_BITS-3) ); - end; - end; -{$endif} -{$ifdef DCT_FLOAT_SUPPORTED} - - JDCT_FLOAT: - begin - { For float AA&N IDCT method, divisors are equal to quantization - coefficients scaled by scalefactor[row]*scalefactor[col], where - scalefactor[0] := 1 - scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 - We apply a further scale factor of 8. - What's actually stored is 1/divisor so that the inner loop can - use a multiplication rather than a division. } - - if (fdct^.float_divisors[qtblno] = NIL) then - begin - fdct^.float_divisors[qtblno] := FAST_FLOAT_FIELD_PTR( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - DCTSIZE2 * SIZEOF(FAST_FLOAT)) ); - end; - fdtbl := fdct^.float_divisors[qtblno]; - i := 0; - for row := 0 to pred(DCTSIZE) do - begin - for col := 0 to pred(DCTSIZE) do - begin - fdtbl^[i] := {FAST_FLOAT} - (1.0 / (( {double}(qtbl^.quantval[i]) * - aanscalefactor[row] * aanscalefactor[col] * 8.0))); - Inc(i); - end; - end; - end; -{$endif} - else - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); - end; - Inc(compptr); - end; -end; - - -{ Perform forward DCT on one or more blocks of a component. - - The input samples are taken from the sample_data[] array starting at - position start_row/start_col, and moving to the right for any additional - blocks. The quantized coefficients are returned in coef_blocks[]. } - -{METHODDEF} -procedure forward_DCT (cinfo : j_compress_ptr; - compptr : jpeg_component_info_ptr; - sample_data : JSAMPARRAY; - coef_blocks : JBLOCKROW; - start_row : JDIMENSION; - start_col : JDIMENSION; - num_blocks : JDIMENSION); -{ This version is used for integer DCT implementations. } -var - { This routine is heavily used, so it's worth coding it tightly. } - fdct : my_fdct_ptr; - do_dct : forward_DCT_method_ptr; - divisors : DCTELEM_FIELD_PTR; - workspace : array[0..DCTSIZE2-1] of DCTELEM; { work area for FDCT subroutine } - bi : JDIMENSION; -var - {register} workspaceptr : DCTELEMPTR; - {register} elemptr : JSAMPLE_PTR; - {register} elemr : int; -{$ifndef DCTSIZE_IS_8} -var - {register} elemc : int; -{$endif} -var - {register} temp, qval : DCTELEM; - {register} i : int; - {register} output_ptr : JCOEFPTR; -begin - fdct := my_fdct_ptr (cinfo^.fdct); - do_dct := fdct^.do_dct; - divisors := fdct^.divisors[compptr^.quant_tbl_no]; - - Inc(JSAMPROW_PTR(sample_data), start_row); { fold in the vertical offset once } - - for bi := 0 to pred(num_blocks) do - begin - - { Load data into workspace, applying unsigned->signed conversion } - - workspaceptr := @workspace[0]; - for elemr := 0 to pred(DCTSIZE) do - begin - elemptr := @sample_data^[elemr]^[start_col]; -{$ifdef DCTSIZE_IS_8} { unroll the inner loop } - workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; - Inc(workspaceptr); - {Inc(elemptr); - Value never used } -{$else} - for elemc := pred(DCTSIZE) downto 0 do - begin - workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; - Inc(workspaceptr); - Inc(elemptr); - end; -{$endif} - end; - - { Perform the DCT } - do_dct (workspace); - - { Quantize/descale the coefficients, and store into coef_blocks[] } - - output_ptr := JCOEFPTR(@coef_blocks^[bi]); - for i := 0 to pred(DCTSIZE2) do - begin - qval := divisors^[i]; - temp := workspace[i]; - { Divide the coefficient value by qval, ensuring proper rounding. - Since C does not specify the direction of rounding for negative - quotients, we have to force the dividend positive for portability. - - In most files, at least half of the output values will be zero - (at default quantization settings, more like three-quarters...) - so we should ensure that this case is fast. On many machines, - a comparison is enough cheaper than a divide to make a special test - a win. Since both inputs will be nonnegative, we need only test - for a < b to discover whether a/b is 0. - If your machine's division is fast enough, define FAST_DIVIDE. } - - if (temp < 0) then - begin - temp := -temp; - Inc(temp, qval shr 1); { for rounding } - {DIVIDE_BY(temp, qval);} - {$ifdef FAST_DIVIDE} - temp := temp div qval; - {$else} - if (temp >= qval) then - temp := temp div qval - else - temp := 0; - {$endif} - temp := -temp; - end - else - begin - Inc(temp, qval shr 1); { for rounding } - {DIVIDE_BY(temp, qval);} - {$ifdef FAST_DIVIDE} - temp := temp div qval; - {$else} - if (temp >= qval) then - temp := temp div qval - else - temp := 0; - {$endif} - end; - output_ptr^[i] := JCOEF (temp); - end; - Inc(start_col, DCTSIZE); - end; -end; - - -{$ifdef DCT_FLOAT_SUPPORTED} - -{METHODDEF} -procedure forward_DCT_float (cinfo : j_compress_ptr; - compptr : jpeg_component_info_ptr; - sample_data : JSAMPARRAY; - coef_blocks : JBLOCKROW; - start_row : JDIMENSION; - start_col : JDIMENSION; - num_blocks : JDIMENSION); -{ This version is used for floating-point DCT implementations. } -var - { This routine is heavily used, so it's worth coding it tightly. } - fdct : my_fdct_ptr; - do_dct : float_DCT_method_ptr; - divisors : FAST_FLOAT_FIELD_PTR; - workspace : array[0..DCTSIZE2-1] of FAST_FLOAT; { work area for FDCT subroutine } - bi : JDIMENSION; -var - {register} workspaceptr : FAST_FLOAT_PTR; - {register} elemptr : JSAMPLE_PTR; - {register} elemr : int; -{$ifndef DCTSIZE_IS_8} -var - {register} elemc : int; -{$endif} -var - {register} temp : FAST_FLOAT; - {register} i : int; - {register} output_ptr : JCOEFPTR; -begin - fdct := my_fdct_ptr (cinfo^.fdct); - do_dct := fdct^.do_float_dct; - divisors := fdct^.float_divisors[compptr^.quant_tbl_no]; - - Inc(JSAMPROW_PTR(sample_data), start_row); { fold in the vertical offset once } - - for bi := 0 to pred(num_blocks) do - begin - { Load data into workspace, applying unsigned->signed conversion } - - workspaceptr := @workspace[0]; - for elemr := 0 to pred(DCTSIZE) do - begin - elemptr := @(sample_data^[elemr]^[start_col]); -{$ifdef DCTSIZE_IS_8} { unroll the inner loop } - workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); - Inc(workspaceptr); - Inc(elemptr); - workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); - Inc(workspaceptr); - {Inc(elemptr); - value never used } -{$else} - for elemc := pred(DCTSIZE) downto 0 do - begin - workspaceptr^ := {FAST_FLOAT}( - (GETJSAMPLE(elemptr^) - CENTERJSAMPLE) ); - Inc(workspaceptr); - Inc(elemptr); - end; -{$endif} - end; - - - { Perform the DCT } - do_dct (workspace); - - { Quantize/descale the coefficients, and store into coef_blocks[] } - - output_ptr := JCOEFPTR(@(coef_blocks^[bi])); - - for i := 0 to pred(DCTSIZE2) do - begin - { Apply the quantization and scaling factor } - temp := workspace[i] * divisors^[i]; - { Round to nearest integer. - Since C does not specify the direction of rounding for negative - quotients, we have to force the dividend positive for portability. - The maximum coefficient size is +-16K (for 12-bit data), so this - code should work for either 16-bit or 32-bit ints. } - output_ptr^[i] := JCOEF ( int(Trunc (temp + {FAST_FLOAT}(16384.5))) - 16384); - end; - Inc(start_col, DCTSIZE); - end; -end; - -{$endif} { DCT_FLOAT_SUPPORTED } - - -{ Initialize FDCT manager. } - -{GLOBAL} -procedure jinit_forward_dct (cinfo : j_compress_ptr); -var - fdct : my_fdct_ptr; - i : int; -begin - fdct := my_fdct_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_fdct_controller)) ); - cinfo^.fdct := jpeg_forward_dct_ptr (fdct); - fdct^.pub.start_pass := start_pass_fdctmgr; - - case (cinfo^.dct_method) of -{$ifdef DCT_ISLOW_SUPPORTED} - JDCT_ISLOW: - begin - fdct^.pub.forward_DCT := forward_DCT; - fdct^.do_dct := jpeg_fdct_islow; - end; -{$endif} -{$ifdef DCT_IFAST_SUPPORTED} - JDCT_IFAST: - begin - fdct^.pub.forward_DCT := forward_DCT; - fdct^.do_dct := jpeg_fdct_ifast; - end; -{$endif} -{$ifdef DCT_FLOAT_SUPPORTED} - JDCT_FLOAT: - begin - fdct^.pub.forward_DCT := forward_DCT_float; - fdct^.do_float_dct := jpeg_fdct_float; - end; -{$endif} - else - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); - end; - - { Mark divisor tables unallocated } - for i := 0 to pred(NUM_QUANT_TBLS) do - begin - fdct^.divisors[i] := NIL; -{$ifdef DCT_FLOAT_SUPPORTED} - fdct^.float_divisors[i] := NIL; -{$endif} - end; -end; - -end. +unit imjcdctmgr; + +{ Original : jcdctmgr.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + +{ This file is part of the Independent JPEG Group's software. + For conditions of distribution and use, see the accompanying README file. + + This file contains the forward-DCT management logic. + This code selects a particular DCT implementation to be used, + and it performs related housekeeping chores including coefficient + quantization. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjpeglib, + imjdct, { Private declarations for DCT subsystem } + imjfdctint, imjfdctfst, imjfdctflt; + +{ Initialize FDCT manager. } + +{GLOBAL} +procedure jinit_forward_dct (cinfo : j_compress_ptr); + +implementation + + +{ Private subobject for this module } + +type + my_fdct_ptr = ^my_fdct_controller; + my_fdct_controller = record + pub : jpeg_forward_dct; { public fields } + + { Pointer to the DCT routine actually in use } + do_dct : forward_DCT_method_ptr; + + { The actual post-DCT divisors --- not identical to the quant table + entries, because of scaling (especially for an unnormalized DCT). + Each table is given in normal array order. } + + divisors : array[0..NUM_QUANT_TBLS-1] of DCTELEM_FIELD_PTR; + + {$ifdef DCT_FLOAT_SUPPORTED} + { Same as above for the floating-point case. } + do_float_dct : float_DCT_method_ptr; + float_divisors : array[0..NUM_QUANT_TBLS-1] of FAST_FLOAT_FIELD_PTR; + {$endif} + end; + + +{ Initialize for a processing pass. + Verify that all referenced Q-tables are present, and set up + the divisor table for each one. + In the current implementation, DCT of all components is done during + the first pass, even if only some components will be output in the + first scan. Hence all components should be examined here. } + +{METHODDEF} +procedure start_pass_fdctmgr (cinfo : j_compress_ptr); +var + fdct : my_fdct_ptr; + ci, qtblno, i : int; + compptr : jpeg_component_info_ptr; + qtbl : JQUANT_TBL_PTR; + dtbl : DCTELEM_FIELD_PTR; +{$ifdef DCT_IFAST_SUPPORTED} +const + CONST_BITS = 14; + aanscales : array[0..DCTSIZE2-1] of INT16 = + ({ precomputed values scaled up by 14 bits } + 16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520, + 22725, 31521, 29692, 26722, 22725, 17855, 12299, 6270, + 21407, 29692, 27969, 25172, 21407, 16819, 11585, 5906, + 19266, 26722, 25172, 22654, 19266, 15137, 10426, 5315, + 16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520, + 12873, 17855, 16819, 15137, 12873, 10114, 6967, 3552, + 8867, 12299, 11585, 10426, 8867, 6967, 4799, 2446, + 4520, 6270, 5906, 5315, 4520, 3552, 2446, 1247); + {SHIFT_TEMPS} + + { Descale and correctly round an INT32 value that's scaled by N bits. + We assume RIGHT_SHIFT rounds towards minus infinity, so adding + the fudge factor is correct for either sign of X. } + + function DESCALE(x : INT32; n : int) : INT32; + var + shift_temp : INT32; + begin + shift_temp := x + (INT32(1) shl (n-1)); + {$ifdef RIGHT_SHIFT_IS_UNSIGNED} + if shift_temp < 0 then + Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) + else + {$endif} + Descale := (shift_temp shr n); + end; + +{$endif} +{$ifdef DCT_FLOAT_SUPPORTED} +var + fdtbl : FAST_FLOAT_FIELD_PTR; + row, col : int; +const + aanscalefactor : array[0..DCTSIZE-1] of double = + (1.0, 1.387039845, 1.306562965, 1.175875602, + 1.0, 0.785694958, 0.541196100, 0.275899379); +{$endif} +begin + fdct := my_fdct_ptr (cinfo^.fdct); + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + qtblno := compptr^.quant_tbl_no; + { Make sure specified quantization table is present } + if (qtblno < 0) or (qtblno >= NUM_QUANT_TBLS) or + (cinfo^.quant_tbl_ptrs[qtblno] = NIL) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, qtblno); + qtbl := cinfo^.quant_tbl_ptrs[qtblno]; + { Compute divisors for this quant table } + { We may do this more than once for same table, but it's not a big deal } + case (cinfo^.dct_method) of +{$ifdef DCT_ISLOW_SUPPORTED} + JDCT_ISLOW: + begin + { For LL&M IDCT method, divisors are equal to raw quantization + coefficients multiplied by 8 (to counteract scaling). } + + if (fdct^.divisors[qtblno] = NIL) then + begin + fdct^.divisors[qtblno] := DCTELEM_FIELD_PTR( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + DCTSIZE2 * SIZEOF(DCTELEM)) ); + end; + dtbl := fdct^.divisors[qtblno]; + for i := 0 to pred(DCTSIZE2) do + begin + dtbl^[i] := (DCTELEM(qtbl^.quantval[i])) shl 3; + end; + end; +{$endif} +{$ifdef DCT_IFAST_SUPPORTED} + JDCT_IFAST: + begin + { For AA&N IDCT method, divisors are equal to quantization + coefficients scaled by scalefactor[row]*scalefactor[col], where + scalefactor[0] := 1 + scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 + We apply a further scale factor of 8. } + + + if (fdct^.divisors[qtblno] = NIL) then + begin + fdct^.divisors[qtblno] := DCTELEM_FIELD_PTR( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + DCTSIZE2 * SIZEOF(DCTELEM)) ); + end; + dtbl := fdct^.divisors[qtblno]; + for i := 0 to pred(DCTSIZE2) do + begin + dtbl^[i] := DCTELEM( + {MULTIPLY16V16} + DESCALE( INT32(qtbl^.quantval[i]) * INT32 (aanscales[i]), + CONST_BITS-3) ); + end; + end; +{$endif} +{$ifdef DCT_FLOAT_SUPPORTED} + + JDCT_FLOAT: + begin + { For float AA&N IDCT method, divisors are equal to quantization + coefficients scaled by scalefactor[row]*scalefactor[col], where + scalefactor[0] := 1 + scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 + We apply a further scale factor of 8. + What's actually stored is 1/divisor so that the inner loop can + use a multiplication rather than a division. } + + if (fdct^.float_divisors[qtblno] = NIL) then + begin + fdct^.float_divisors[qtblno] := FAST_FLOAT_FIELD_PTR( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + DCTSIZE2 * SIZEOF(FAST_FLOAT)) ); + end; + fdtbl := fdct^.float_divisors[qtblno]; + i := 0; + for row := 0 to pred(DCTSIZE) do + begin + for col := 0 to pred(DCTSIZE) do + begin + fdtbl^[i] := {FAST_FLOAT} + (1.0 / (( {double}(qtbl^.quantval[i]) * + aanscalefactor[row] * aanscalefactor[col] * 8.0))); + Inc(i); + end; + end; + end; +{$endif} + else + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); + end; + Inc(compptr); + end; +end; + + +{ Perform forward DCT on one or more blocks of a component. + + The input samples are taken from the sample_data[] array starting at + position start_row/start_col, and moving to the right for any additional + blocks. The quantized coefficients are returned in coef_blocks[]. } + +{METHODDEF} +procedure forward_DCT (cinfo : j_compress_ptr; + compptr : jpeg_component_info_ptr; + sample_data : JSAMPARRAY; + coef_blocks : JBLOCKROW; + start_row : JDIMENSION; + start_col : JDIMENSION; + num_blocks : JDIMENSION); +{ This version is used for integer DCT implementations. } +var + { This routine is heavily used, so it's worth coding it tightly. } + fdct : my_fdct_ptr; + do_dct : forward_DCT_method_ptr; + divisors : DCTELEM_FIELD_PTR; + workspace : array[0..DCTSIZE2-1] of DCTELEM; { work area for FDCT subroutine } + bi : JDIMENSION; +var + {register} workspaceptr : DCTELEMPTR; + {register} elemptr : JSAMPLE_PTR; + {register} elemr : int; +{$ifndef DCTSIZE_IS_8} +var + {register} elemc : int; +{$endif} +var + {register} temp, qval : DCTELEM; + {register} i : int; + {register} output_ptr : JCOEFPTR; +begin + fdct := my_fdct_ptr (cinfo^.fdct); + do_dct := fdct^.do_dct; + divisors := fdct^.divisors[compptr^.quant_tbl_no]; + + Inc(JSAMPROW_PTR(sample_data), start_row); { fold in the vertical offset once } + + for bi := 0 to pred(num_blocks) do + begin + + { Load data into workspace, applying unsigned->signed conversion } + + workspaceptr := @workspace[0]; + for elemr := 0 to pred(DCTSIZE) do + begin + elemptr := @sample_data^[elemr]^[start_col]; +{$ifdef DCTSIZE_IS_8} { unroll the inner loop } + workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; + Inc(workspaceptr); + {Inc(elemptr); - Value never used } +{$else} + for elemc := pred(DCTSIZE) downto 0 do + begin + workspaceptr^ := GETJSAMPLE(elemptr^) - CENTERJSAMPLE; + Inc(workspaceptr); + Inc(elemptr); + end; +{$endif} + end; + + { Perform the DCT } + do_dct (workspace); + + { Quantize/descale the coefficients, and store into coef_blocks[] } + + output_ptr := JCOEFPTR(@coef_blocks^[bi]); + for i := 0 to pred(DCTSIZE2) do + begin + qval := divisors^[i]; + temp := workspace[i]; + { Divide the coefficient value by qval, ensuring proper rounding. + Since C does not specify the direction of rounding for negative + quotients, we have to force the dividend positive for portability. + + In most files, at least half of the output values will be zero + (at default quantization settings, more like three-quarters...) + so we should ensure that this case is fast. On many machines, + a comparison is enough cheaper than a divide to make a special test + a win. Since both inputs will be nonnegative, we need only test + for a < b to discover whether a/b is 0. + If your machine's division is fast enough, define FAST_DIVIDE. } + + if (temp < 0) then + begin + temp := -temp; + Inc(temp, qval shr 1); { for rounding } + {DIVIDE_BY(temp, qval);} + {$ifdef FAST_DIVIDE} + temp := temp div qval; + {$else} + if (temp >= qval) then + temp := temp div qval + else + temp := 0; + {$endif} + temp := -temp; + end + else + begin + Inc(temp, qval shr 1); { for rounding } + {DIVIDE_BY(temp, qval);} + {$ifdef FAST_DIVIDE} + temp := temp div qval; + {$else} + if (temp >= qval) then + temp := temp div qval + else + temp := 0; + {$endif} + end; + output_ptr^[i] := JCOEF (temp); + end; + Inc(start_col, DCTSIZE); + end; +end; + + +{$ifdef DCT_FLOAT_SUPPORTED} + +{METHODDEF} +procedure forward_DCT_float (cinfo : j_compress_ptr; + compptr : jpeg_component_info_ptr; + sample_data : JSAMPARRAY; + coef_blocks : JBLOCKROW; + start_row : JDIMENSION; + start_col : JDIMENSION; + num_blocks : JDIMENSION); +{ This version is used for floating-point DCT implementations. } +var + { This routine is heavily used, so it's worth coding it tightly. } + fdct : my_fdct_ptr; + do_dct : float_DCT_method_ptr; + divisors : FAST_FLOAT_FIELD_PTR; + workspace : array[0..DCTSIZE2-1] of FAST_FLOAT; { work area for FDCT subroutine } + bi : JDIMENSION; +var + {register} workspaceptr : FAST_FLOAT_PTR; + {register} elemptr : JSAMPLE_PTR; + {register} elemr : int; +{$ifndef DCTSIZE_IS_8} +var + {register} elemc : int; +{$endif} +var + {register} temp : FAST_FLOAT; + {register} i : int; + {register} output_ptr : JCOEFPTR; +begin + fdct := my_fdct_ptr (cinfo^.fdct); + do_dct := fdct^.do_float_dct; + divisors := fdct^.float_divisors[compptr^.quant_tbl_no]; + + Inc(JSAMPROW_PTR(sample_data), start_row); { fold in the vertical offset once } + + for bi := 0 to pred(num_blocks) do + begin + { Load data into workspace, applying unsigned->signed conversion } + + workspaceptr := @workspace[0]; + for elemr := 0 to pred(DCTSIZE) do + begin + elemptr := @(sample_data^[elemr]^[start_col]); +{$ifdef DCTSIZE_IS_8} { unroll the inner loop } + workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); + Inc(workspaceptr); + Inc(elemptr); + workspaceptr^ := {FAST_FLOAT}(GETJSAMPLE(elemptr^) - CENTERJSAMPLE); + Inc(workspaceptr); + {Inc(elemptr); - value never used } +{$else} + for elemc := pred(DCTSIZE) downto 0 do + begin + workspaceptr^ := {FAST_FLOAT}( + (GETJSAMPLE(elemptr^) - CENTERJSAMPLE) ); + Inc(workspaceptr); + Inc(elemptr); + end; +{$endif} + end; + + + { Perform the DCT } + do_dct (workspace); + + { Quantize/descale the coefficients, and store into coef_blocks[] } + + output_ptr := JCOEFPTR(@(coef_blocks^[bi])); + + for i := 0 to pred(DCTSIZE2) do + begin + { Apply the quantization and scaling factor } + temp := workspace[i] * divisors^[i]; + { Round to nearest integer. + Since C does not specify the direction of rounding for negative + quotients, we have to force the dividend positive for portability. + The maximum coefficient size is +-16K (for 12-bit data), so this + code should work for either 16-bit or 32-bit ints. } + output_ptr^[i] := JCOEF ( int(Trunc (temp + {FAST_FLOAT}(16384.5))) - 16384); + end; + Inc(start_col, DCTSIZE); + end; +end; + +{$endif} { DCT_FLOAT_SUPPORTED } + + +{ Initialize FDCT manager. } + +{GLOBAL} +procedure jinit_forward_dct (cinfo : j_compress_ptr); +var + fdct : my_fdct_ptr; + i : int; +begin + fdct := my_fdct_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_fdct_controller)) ); + cinfo^.fdct := jpeg_forward_dct_ptr (fdct); + fdct^.pub.start_pass := start_pass_fdctmgr; + + case (cinfo^.dct_method) of +{$ifdef DCT_ISLOW_SUPPORTED} + JDCT_ISLOW: + begin + fdct^.pub.forward_DCT := forward_DCT; + fdct^.do_dct := jpeg_fdct_islow; + end; +{$endif} +{$ifdef DCT_IFAST_SUPPORTED} + JDCT_IFAST: + begin + fdct^.pub.forward_DCT := forward_DCT; + fdct^.do_dct := jpeg_fdct_ifast; + end; +{$endif} +{$ifdef DCT_FLOAT_SUPPORTED} + JDCT_FLOAT: + begin + fdct^.pub.forward_DCT := forward_DCT_float; + fdct^.do_float_dct := jpeg_fdct_float; + end; +{$endif} + else + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); + end; + + { Mark divisor tables unallocated } + for i := 0 to pred(NUM_QUANT_TBLS) do + begin + fdct^.divisors[i] := NIL; +{$ifdef DCT_FLOAT_SUPPORTED} + fdct^.float_divisors[i] := NIL; +{$endif} + end; +end; + +end. diff --git a/Imaging/JpegLib/imjchuff.pas b/Imaging/JpegLib/imjchuff.pas index ff004a4..5691aa4 100644 --- a/Imaging/JpegLib/imjchuff.pas +++ b/Imaging/JpegLib/imjchuff.pas @@ -1,1116 +1,1116 @@ -unit imjchuff; - -{ This file contains Huffman entropy encoding routines. - - Much of the complexity here has to do with supporting output suspension. - If the data destination module demands suspension, we want to be able to - back up to the start of the current MCU. To do this, we copy state - variables into local working storage, and update them back to the - permanent JPEG objects only upon successful completion of an MCU. } - -{ Original: jchuff.c; Copyright (C) 1991-1997, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, { longptr definition missing } - imjpeglib, - imjdeferr, - imjerror, - imjutils, - imjinclude, - imjcomapi; - -{ The legal range of a DCT coefficient is - -1024 .. +1023 for 8-bit data; - -16384 .. +16383 for 12-bit data. - Hence the magnitude should always fit in 10 or 14 bits respectively. } - - -{$ifdef BITS_IN_JSAMPLE_IS_8} -const - MAX_COEF_BITS = 10; -{$else} -const - MAX_COEF_BITS = 14; -{$endif} - -{ Derived data constructed for each Huffman table } -{ Declarations shared with jcphuff.c } -type - c_derived_tbl_ptr = ^c_derived_tbl; - c_derived_tbl = record - ehufco : array[0..256-1] of uInt; { code for each symbol } - ehufsi : array[0..256-1] of byte; { length of code for each symbol } - { If no code has been allocated for a symbol S, ehufsi[S] contains 0 } - end; -{ for JCHUFF und JCPHUFF } -type - TLongTable = array[0..256] of long; - TLongTablePtr = ^TLongTable; - -{ Compute the derived values for a Huffman table. - Note this is also used by jcphuff.c. } - -{GLOBAL} -procedure jpeg_make_c_derived_tbl (cinfo : j_compress_ptr; - isDC : boolean; - tblno : int; - var pdtbl : c_derived_tbl_ptr); - -{ Generate the optimal coding for the given counts, fill htbl. - Note this is also used by jcphuff.c. } - -{GLOBAL} -procedure jpeg_gen_optimal_table (cinfo : j_compress_ptr; - htbl : JHUFF_TBL_PTR; - var freq : TLongTable); { Nomssi } - -{ Module initialization routine for Huffman entropy encoding. } - -{GLOBAL} -procedure jinit_huff_encoder (cinfo : j_compress_ptr); - -implementation - -{ Expanded entropy encoder object for Huffman encoding. - - The savable_state subrecord contains fields that change within an MCU, - but must not be updated permanently until we complete the MCU. } - -type - savable_state = record - put_buffer : INT32; { current bit-accumulation buffer } - put_bits : int; { # of bits now in it } - last_dc_val : array[0..MAX_COMPS_IN_SCAN-1] of int; - { last DC coef for each component } - end; - - -type - huff_entropy_ptr = ^huff_entropy_encoder; - huff_entropy_encoder = record - pub : jpeg_entropy_encoder; { public fields } - - saved : savable_state; { Bit buffer & DC state at start of MCU } - - { These fields are NOT loaded into local working state. } - restarts_to_go : uInt; { MCUs left in this restart interval } - next_restart_num : int; { next restart number to write (0-7) } - - { Pointers to derived tables (these workspaces have image lifespan) } - dc_derived_tbls : array[0..NUM_HUFF_TBLS-1] of c_derived_tbl_ptr; - ac_derived_tbls : array[0..NUM_HUFF_TBLS-1] of c_derived_tbl_ptr; - - {$ifdef ENTROPY_OPT_SUPPORTED} { Statistics tables for optimization } - dc_count_ptrs : array[0..NUM_HUFF_TBLS-1] of TLongTablePtr; - ac_count_ptrs : array[0..NUM_HUFF_TBLS-1] of TLongTablePtr; - {$endif} - end; - - - -{ Working state while writing an MCU. - This struct contains all the fields that are needed by subroutines. } - -type - working_state = record - next_output_byte : JOCTETptr; { => next byte to write in buffer } - free_in_buffer : size_t; { # of byte spaces remaining in buffer } - cur : savable_state; { Current bit buffer & DC state } - cinfo : j_compress_ptr; { dump_buffer needs access to this } - end; - - -{ Forward declarations } -{METHODDEF} -function encode_mcu_huff (cinfo : j_compress_ptr; - const MCU_data : array of JBLOCKROW) : boolean; - forward; -{METHODDEF} -procedure finish_pass_huff (cinfo : j_compress_ptr); forward; -{$ifdef ENTROPY_OPT_SUPPORTED} -{METHODDEF} -function encode_mcu_gather (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; - forward; - -{METHODDEF} -procedure finish_pass_gather (cinfo : j_compress_ptr); forward; -{$endif} - - -{ Initialize for a Huffman-compressed scan. - If gather_statistics is TRUE, we do not output anything during the scan, - just count the Huffman symbols used and generate Huffman code tables. } - -{METHODDEF} -procedure start_pass_huff (cinfo : j_compress_ptr; - gather_statistics : boolean); -var - entropy : huff_entropy_ptr; - ci, dctbl, actbl : int; - compptr : jpeg_component_info_ptr; -begin - entropy := huff_entropy_ptr (cinfo^.entropy); - - if (gather_statistics) then - begin -{$ifdef ENTROPY_OPT_SUPPORTED} - entropy^.pub.encode_mcu := encode_mcu_gather; - entropy^.pub.finish_pass := finish_pass_gather; -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} - end - else - begin - entropy^.pub.encode_mcu := encode_mcu_huff; - entropy^.pub.finish_pass := finish_pass_huff; - end; - - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - dctbl := compptr^.dc_tbl_no; - actbl := compptr^.ac_tbl_no; - if (gather_statistics) then - begin -{$ifdef ENTROPY_OPT_SUPPORTED} - { Check for invalid table indexes } - { (make_c_derived_tbl does this in the other path) } - if (dctbl < 0) or (dctbl >= NUM_HUFF_TBLS) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, dctbl); - if (actbl < 0) or (actbl >= NUM_HUFF_TBLS) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, actbl); - { Allocate and zero the statistics tables } - { Note that jpeg_gen_optimal_table expects 257 entries in each table! } - if (entropy^.dc_count_ptrs[dctbl] = NIL) then - entropy^.dc_count_ptrs[dctbl] := TLongTablePtr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - 257 * SIZEOF(long)) ); - MEMZERO(entropy^.dc_count_ptrs[dctbl], 257 * SIZEOF(long)); - if (entropy^.ac_count_ptrs[actbl] = NIL) then - entropy^.ac_count_ptrs[actbl] := TLongTablePtr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - 257 * SIZEOF(long)) ); - MEMZERO(entropy^.ac_count_ptrs[actbl], 257 * SIZEOF(long)); -{$endif} - end - else - begin - { Compute derived values for Huffman tables } - { We may do this more than once for a table, but it's not expensive } - jpeg_make_c_derived_tbl(cinfo, TRUE, dctbl, - entropy^.dc_derived_tbls[dctbl]); - jpeg_make_c_derived_tbl(cinfo, FALSE, actbl, - entropy^.ac_derived_tbls[actbl]); - end; - { Initialize DC predictions to 0 } - entropy^.saved.last_dc_val[ci] := 0; - end; - - { Initialize bit buffer to empty } - entropy^.saved.put_buffer := 0; - entropy^.saved.put_bits := 0; - - { Initialize restart stuff } - entropy^.restarts_to_go := cinfo^.restart_interval; - entropy^.next_restart_num := 0; -end; - - -{ Compute the derived values for a Huffman table. - This routine also performs some validation checks on the table. - - Note this is also used by jcphuff.c. } - -{GLOBAL} -procedure jpeg_make_c_derived_tbl (cinfo : j_compress_ptr; - isDC : boolean; - tblno : int; - var pdtbl : c_derived_tbl_ptr); -var - htbl : JHUFF_TBL_PTR; - dtbl : c_derived_tbl_ptr; - p, i, l, lastp, si, maxsymbol : int; - huffsize : array[0..257-1] of byte; - huffcode : array[0..257-1] of uInt; - code : uInt; -begin - { Note that huffsize[] and huffcode[] are filled in code-length order, - paralleling the order of the symbols themselves in htbl->huffval[]. } - - { Find the input Huffman table } - if (tblno < 0) or (tblno >= NUM_HUFF_TBLS) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno); - if isDC then - htbl := cinfo^.dc_huff_tbl_ptrs[tblno] - else - htbl := cinfo^.ac_huff_tbl_ptrs[tblno]; - if (htbl = NIL) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno); - - { Allocate a workspace if we haven't already done so. } - if (pdtbl = NIL) then - pdtbl := c_derived_tbl_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(c_derived_tbl)) ); - dtbl := pdtbl; - - { Figure C.1: make table of Huffman code length for each symbol } - - p := 0; - for l := 1 to 16 do - begin - i := int(htbl^.bits[l]); - if (i < 0) and (p + i > 256) then { protect against table overrun } - ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); - while (i > 0) do - begin - huffsize[p] := byte(l); - Inc(p); - Dec(i); - end; - end; - huffsize[p] := 0; - lastp := p; - - { Figure C.2: generate the codes themselves } - { We also validate that the counts represent a legal Huffman code tree. } - - code := 0; - si := huffsize[0]; - p := 0; - while (huffsize[p] <> 0) do - begin - while (( int(huffsize[p]) ) = si) do - begin - huffcode[p] := code; - Inc(p); - Inc(code); - end; - { code is now 1 more than the last code used for codelength si; but - it must still fit in si bits, since no code is allowed to be all ones. } - - if (INT32(code) >= (INT32(1) shl si)) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); - code := code shl 1; - Inc(si); - end; - - { Figure C.3: generate encoding tables } - { These are code and size indexed by symbol value } - - { Set all codeless symbols to have code length 0; - this lets us detect duplicate VAL entries here, and later - allows emit_bits to detect any attempt to emit such symbols. } - - MEMZERO(@dtbl^.ehufsi, SIZEOF(dtbl^.ehufsi)); - - { This is also a convenient place to check for out-of-range - and duplicated VAL entries. We allow 0..255 for AC symbols - but only 0..15 for DC. (We could constrain them further - based on data depth and mode, but this seems enough.) } - - if isDC then - maxsymbol := 15 - else - maxsymbol := 255; - - for p := 0 to pred(lastp) do - begin - i := htbl^.huffval[p]; - if (i < 0) or (i > maxsymbol) or (dtbl^.ehufsi[i] <> 0) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); - dtbl^.ehufco[i] := huffcode[p]; - dtbl^.ehufsi[i] := huffsize[p]; - end; -end; - - -{ Outputting bytes to the file } - - -{LOCAL} -function dump_buffer (var state : working_state) : boolean; -{ Empty the output buffer; return TRUE if successful, FALSE if must suspend } -var - dest : jpeg_destination_mgr_ptr; -begin - dest := state.cinfo^.dest; - - if (not dest^.empty_output_buffer (state.cinfo)) then - begin - dump_buffer := FALSE; - exit; - end; - { After a successful buffer dump, must reset buffer pointers } - state.next_output_byte := dest^.next_output_byte; - state.free_in_buffer := dest^.free_in_buffer; - dump_buffer := TRUE; -end; - - -{ Outputting bits to the file } - -{ Only the right 24 bits of put_buffer are used; the valid bits are - left-justified in this part. At most 16 bits can be passed to emit_bits - in one call, and we never retain more than 7 bits in put_buffer - between calls, so 24 bits are sufficient. } - - -{LOCAL} -function emit_bits (var state : working_state; - code : uInt; - size : int) : boolean; {INLINE} -{ Emit some bits; return TRUE if successful, FALSE if must suspend } -var - { This routine is heavily used, so it's worth coding tightly. } - {register} put_buffer : INT32; - {register} put_bits : int; -var - c : int; -begin - put_buffer := INT32 (code); - put_bits := state.cur.put_bits; - - { if size is 0, caller used an invalid Huffman table entry } - if (size = 0) then - ERREXIT(j_common_ptr(state.cinfo), JERR_HUFF_MISSING_CODE); - - put_buffer := put_buffer and pred(INT32(1) shl size); - { mask off any extra bits in code } - - Inc(put_bits, size); { new number of bits in buffer } - - put_buffer := put_buffer shl (24 - put_bits); - { align incoming bits } - put_buffer := put_buffer or state.cur.put_buffer; - { and merge with old buffer contents } - while (put_bits >= 8) do - begin - c := int ((put_buffer shr 16) and $FF); - - {emit_byte(state, c, return FALSE);} - { Emit a byte, return FALSE if must suspend. } - state.next_output_byte^ := JOCTET (c); - Inc(state.next_output_byte); - Dec(state.free_in_buffer); - if (state.free_in_buffer = 0) then - if not dump_buffer(state) then - begin - emit_bits := FALSE; - exit; - end; - - if (c = $FF) then { need to stuff a zero byte? } - begin - {emit_byte(state, 0, return FALSE);} - state.next_output_byte^ := JOCTET (0); - Inc(state.next_output_byte); - Dec(state.free_in_buffer); - if (state.free_in_buffer = 0) then - if not dump_buffer(state) then - begin - emit_bits := FALSE; - exit; - end; - - end; - put_buffer := put_buffer shl 8; - Dec(put_bits, 8); - end; - - state.cur.put_buffer := put_buffer; { update state variables } - state.cur.put_bits := put_bits; - - emit_bits := TRUE; -end; - - -{LOCAL} -function flush_bits (var state : working_state) : boolean; -begin - if (not emit_bits(state, $7F, 7)) then { fill any partial byte with ones } - begin - flush_bits := FALSE; - exit; - end; - state.cur.put_buffer := 0; { and reset bit-buffer to empty } - state.cur.put_bits := 0; - flush_bits := TRUE; -end; - - -{ Encode a single block's worth of coefficients } - -{LOCAL} -function encode_one_block (var state : working_state; - const block : JBLOCK; - last_dc_val : int; - dctbl : c_derived_tbl_ptr; - actbl : c_derived_tbl_ptr) : boolean; -var - {register} temp, temp2 : int; - {register} nbits : int; - {register} k, r, i : int; -begin - { Encode the DC coefficient difference per section F.1.2.1 } - - temp2 := block[0] - last_dc_val; - temp := temp2; - - if (temp < 0) then - begin - temp := -temp; { temp is abs value of input } - { For a negative input, want temp2 := bitwise complement of abs(input) } - { This code assumes we are on a two's complement machine } - Dec(temp2); - end; - - { Find the number of bits needed for the magnitude of the coefficient } - nbits := 0; - while (temp <> 0) do - begin - Inc(nbits); - temp := temp shr 1; - end; - - { Check for out-of-range coefficient values. - Since we're encoding a difference, the range limit is twice as much. } - - if (nbits > MAX_COEF_BITS+1) then - ERREXIT(j_common_ptr(state.cinfo), JERR_BAD_DCT_COEF); - - { Emit the Huffman-coded symbol for the number of bits } - if not emit_bits(state, dctbl^.ehufco[nbits], dctbl^.ehufsi[nbits]) then - begin - encode_one_block := FALSE; - exit; - end; - - { Emit that number of bits of the value, if positive, } - { or the complement of its magnitude, if negative. } - if (nbits <> 0) then { emit_bits rejects calls with size 0 } - if not emit_bits(state, uInt(temp2), nbits) then - begin - encode_one_block := FALSE; - exit; - end; - - { Encode the AC coefficients per section F.1.2.2 } - - r := 0; { r := run length of zeros } - - for k := 1 to pred(DCTSIZE2) do - begin - temp := block[jpeg_natural_order[k]]; - if (temp = 0) then - begin - Inc(r); - end - else - begin - { if run length > 15, must emit special run-length-16 codes ($F0) } - while (r > 15) do - begin - if not emit_bits(state, actbl^.ehufco[$F0], actbl^.ehufsi[$F0]) then - begin - encode_one_block := FALSE; - exit; - end; - Dec(r, 16); - end; - - temp2 := temp; - if (temp < 0) then - begin - temp := -temp; { temp is abs value of input } - { This code assumes we are on a two's complement machine } - Dec(temp2); - end; - - { Find the number of bits needed for the magnitude of the coefficient } - nbits := 0; { there must be at least one 1 bit } - repeat - Inc(nbits); - temp := temp shr 1; - until (temp = 0); - - { Check for out-of-range coefficient values } - if (nbits > MAX_COEF_BITS) then - ERREXIT(j_common_ptr(state.cinfo), JERR_BAD_DCT_COEF); - - { Emit Huffman symbol for run length / number of bits } - i := (r shl 4) + nbits; - if not emit_bits(state, actbl^.ehufco[i], actbl^.ehufsi[i]) then - begin - encode_one_block := FALSE; - exit; - end; - - { Emit that number of bits of the value, if positive, } - { or the complement of its magnitude, if negative. } - if not emit_bits(state, uInt(temp2), nbits) then - begin - encode_one_block := FALSE; - exit; - end; - - r := 0; - end; - end; - - { If the last coef(s) were zero, emit an end-of-block code } - if (r > 0) then - if not emit_bits(state, actbl^.ehufco[0], actbl^.ehufsi[0]) then - begin - encode_one_block := FALSE; - exit; - end; - - encode_one_block := TRUE; -end; - - -{ Emit a restart marker & resynchronize predictions. } - -{LOCAL} -function emit_restart (var state : working_state; - restart_num : int) : boolean; -var - ci : int; -begin - if (not flush_bits(state)) then - begin - emit_restart := FALSE; - exit; - end; - - {emit_byte(state, $FF, return FALSE);} - { Emit a byte, return FALSE if must suspend. } - state.next_output_byte^ := JOCTET ($FF); - Inc(state.next_output_byte); - Dec(state.free_in_buffer); - if (state.free_in_buffer = 0) then - if not dump_buffer(state) then - begin - emit_restart := FALSE; - exit; - end; - - {emit_byte(state, JPEG_RST0 + restart_num, return FALSE);} - { Emit a byte, return FALSE if must suspend. } - state.next_output_byte^ := JOCTET (JPEG_RST0 + restart_num); - Inc(state.next_output_byte); - Dec(state.free_in_buffer); - if (state.free_in_buffer = 0) then - if not dump_buffer(state) then - begin - emit_restart := FALSE; - exit; - end; - - { Re-initialize DC predictions to 0 } - for ci := 0 to pred(state.cinfo^.comps_in_scan) do - state.cur.last_dc_val[ci] := 0; - - { The restart counter is not updated until we successfully write the MCU. } - - emit_restart := TRUE; -end; - - -{ Encode and output one MCU's worth of Huffman-compressed coefficients. } - -{METHODDEF} -function encode_mcu_huff (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; -var - entropy : huff_entropy_ptr; - state : working_state; - blkn, ci : int; - compptr : jpeg_component_info_ptr; -begin - entropy := huff_entropy_ptr (cinfo^.entropy); - { Load up working state } - state.next_output_byte := cinfo^.dest^.next_output_byte; - state.free_in_buffer := cinfo^.dest^.free_in_buffer; - {ASSIGN_STATE(state.cur, entropy^.saved);} - state.cur := entropy^.saved; - state.cinfo := cinfo; - - { Emit restart marker if needed } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - if not emit_restart(state, entropy^.next_restart_num) then - begin - encode_mcu_huff := FALSE; - exit; - end; - end; - - { Encode the MCU data blocks } - for blkn := 0 to pred(cinfo^.blocks_in_MCU) do - begin - ci := cinfo^.MCU_membership[blkn]; - compptr := cinfo^.cur_comp_info[ci]; - if not encode_one_block(state, - MCU_data[blkn]^[0], - state.cur.last_dc_val[ci], - entropy^.dc_derived_tbls[compptr^.dc_tbl_no], - entropy^.ac_derived_tbls[compptr^.ac_tbl_no]) then - begin - encode_mcu_huff := FALSE; - exit; - end; - { Update last_dc_val } - state.cur.last_dc_val[ci] := MCU_data[blkn]^[0][0]; - end; - - { Completed MCU, so update state } - cinfo^.dest^.next_output_byte := state.next_output_byte; - cinfo^.dest^.free_in_buffer := state.free_in_buffer; - {ASSIGN_STATE(entropy^.saved, state.cur);} - entropy^.saved := state.cur; - - { Update restart-interval state too } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - begin - entropy^.restarts_to_go := cinfo^.restart_interval; - Inc(entropy^.next_restart_num); - with entropy^ do - next_restart_num := next_restart_num and 7; - end; - Dec(entropy^.restarts_to_go); - end; - - encode_mcu_huff := TRUE; -end; - - -{ Finish up at the end of a Huffman-compressed scan. } - -{METHODDEF} -procedure finish_pass_huff (cinfo : j_compress_ptr); -var - entropy : huff_entropy_ptr; - state : working_state; -begin - entropy := huff_entropy_ptr (cinfo^.entropy); - - { Load up working state ... flush_bits needs it } - state.next_output_byte := cinfo^.dest^.next_output_byte; - state.free_in_buffer := cinfo^.dest^.free_in_buffer; - {ASSIGN_STATE(state.cur, entropy^.saved);} - state.cur := entropy^.saved; - state.cinfo := cinfo; - - { Flush out the last data } - if not flush_bits(state) then - ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND); - - { Update state } - cinfo^.dest^.next_output_byte := state.next_output_byte; - cinfo^.dest^.free_in_buffer := state.free_in_buffer; - {ASSIGN_STATE(entropy^.saved, state.cur);} - entropy^.saved := state.cur; -end; - - -{ Huffman coding optimization. - - We first scan the supplied data and count the number of uses of each symbol - that is to be Huffman-coded. (This process MUST agree with the code above.) - Then we build a Huffman coding tree for the observed counts. - Symbols which are not needed at all for the particular image are not - assigned any code, which saves space in the DHT marker as well as in - the compressed data. } - -{$ifdef ENTROPY_OPT_SUPPORTED} - - -{ Process a single block's worth of coefficients } - -{LOCAL} -procedure htest_one_block (cinfo : j_compress_ptr; - const block : JBLOCK; - last_dc_val : int; - dc_counts : TLongTablePtr; - ac_counts : TLongTablePtr); - -var - {register} temp : int; - {register} nbits : int; - {register} k, r : int; -begin - { Encode the DC coefficient difference per section F.1.2.1 } - temp := block[0] - last_dc_val; - if (temp < 0) then - temp := -temp; - - { Find the number of bits needed for the magnitude of the coefficient } - nbits := 0; - while (temp <> 0) do - begin - Inc(nbits); - temp := temp shr 1; - end; - - { Check for out-of-range coefficient values. - Since we're encoding a difference, the range limit is twice as much. } - - if (nbits > MAX_COEF_BITS+1) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_DCT_COEF); - - { Count the Huffman symbol for the number of bits } - Inc(dc_counts^[nbits]); - - { Encode the AC coefficients per section F.1.2.2 } - - r := 0; { r := run length of zeros } - - for k := 1 to pred(DCTSIZE2) do - begin - temp := block[jpeg_natural_order[k]]; - if (temp = 0) then - begin - Inc(r); - end - else - begin - { if run length > 15, must emit special run-length-16 codes ($F0) } - while (r > 15) do - begin - Inc(ac_counts^[$F0]); - Dec(r, 16); - end; - - { Find the number of bits needed for the magnitude of the coefficient } - if (temp < 0) then - temp := -temp; - - { Find the number of bits needed for the magnitude of the coefficient } - nbits := 0; { there must be at least one 1 bit } - repeat - Inc(nbits); - temp := temp shr 1; - until (temp = 0); - - - { Count Huffman symbol for run length / number of bits } - Inc(ac_counts^[(r shl 4) + nbits]); - - r := 0; - end; - end; - - { If the last coef(s) were zero, emit an end-of-block code } - if (r > 0) then - Inc(ac_counts^[0]); -end; - - -{ Trial-encode one MCU's worth of Huffman-compressed coefficients. - No data is actually output, so no suspension return is possible. } - -{METHODDEF} -function encode_mcu_gather (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; -var - entropy : huff_entropy_ptr; - blkn, ci : int; - compptr : jpeg_component_info_ptr; -begin - entropy := huff_entropy_ptr (cinfo^.entropy); - { Take care of restart intervals if needed } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - begin - { Re-initialize DC predictions to 0 } - for ci := 0 to pred(cinfo^.comps_in_scan) do - entropy^.saved.last_dc_val[ci] := 0; - { Update restart state } - entropy^.restarts_to_go := cinfo^.restart_interval; - end; - Dec(entropy^.restarts_to_go); - end; - - for blkn := 0 to pred(cinfo^.blocks_in_MCU) do - begin - ci := cinfo^.MCU_membership[blkn]; - compptr := cinfo^.cur_comp_info[ci]; - htest_one_block(cinfo, MCU_data[blkn]^[0], - entropy^.saved.last_dc_val[ci], - entropy^.dc_count_ptrs[compptr^.dc_tbl_no], - entropy^.ac_count_ptrs[compptr^.ac_tbl_no]); - entropy^.saved.last_dc_val[ci] := MCU_data[blkn]^[0][0]; - end; - - encode_mcu_gather := TRUE; -end; - - -{ Generate the best Huffman code table for the given counts, fill htbl. - Note this is also used by jcphuff.c. - - The JPEG standard requires that no symbol be assigned a codeword of all - one bits (so that padding bits added at the end of a compressed segment - can't look like a valid code). Because of the canonical ordering of - codewords, this just means that there must be an unused slot in the - longest codeword length category. Section K.2 of the JPEG spec suggests - reserving such a slot by pretending that symbol 256 is a valid symbol - with count 1. In theory that's not optimal; giving it count zero but - including it in the symbol set anyway should give a better Huffman code. - But the theoretically better code actually seems to come out worse in - practice, because it produces more all-ones bytes (which incur stuffed - zero bytes in the final file). In any case the difference is tiny. - - The JPEG standard requires Huffman codes to be no more than 16 bits long. - If some symbols have a very small but nonzero probability, the Huffman tree - must be adjusted to meet the code length restriction. We currently use - the adjustment method suggested in JPEG section K.2. This method is *not* - optimal; it may not choose the best possible limited-length code. But - typically only very-low-frequency symbols will be given less-than-optimal - lengths, so the code is almost optimal. Experimental comparisons against - an optimal limited-length-code algorithm indicate that the difference is - microscopic --- usually less than a hundredth of a percent of total size. - So the extra complexity of an optimal algorithm doesn't seem worthwhile. } - - -{GLOBAL} -procedure jpeg_gen_optimal_table (cinfo : j_compress_ptr; - htbl : JHUFF_TBL_PTR; - var freq : TLongTable); -const - MAX_CLEN = 32; { assumed maximum initial code length } -var - bits : array[0..MAX_CLEN+1-1] of UINT8; { bits[k] := # of symbols with code length k } - codesize : array[0..257-1] of int; { codesize[k] := code length of symbol k } - others : array[0..257-1] of int; { next symbol in current branch of tree } - c1, c2 : int; - p, i, j : int; - v : long; -begin - { This algorithm is explained in section K.2 of the JPEG standard } - - MEMZERO(@bits, SIZEOF(bits)); - MEMZERO(@codesize, SIZEOF(codesize)); - for i := 0 to 256 do - others[i] := -1; { init links to empty } - - freq[256] := 1; { make sure 256 has a nonzero count } - { Including the pseudo-symbol 256 in the Huffman procedure guarantees - that no real symbol is given code-value of all ones, because 256 - will be placed last in the largest codeword category. } - - { Huffman's basic algorithm to assign optimal code lengths to symbols } - - while TRUE do - begin - { Find the smallest nonzero frequency, set c1 := its symbol } - { In case of ties, take the larger symbol number } - c1 := -1; - v := long(1000000000); - for i := 0 to 256 do - begin - if (freq[i] <> 0) and (freq[i] <= v) then - begin - v := freq[i]; - c1 := i; - end; - end; - - { Find the next smallest nonzero frequency, set c2 := its symbol } - { In case of ties, take the larger symbol number } - c2 := -1; - v := long(1000000000); - for i := 0 to 256 do - begin - if (freq[i] <> 0) and (freq[i] <= v) and (i <> c1) then - begin - v := freq[i]; - c2 := i; - end; - end; - - { Done if we've merged everything into one frequency } - if (c2 < 0) then - break; - - { Else merge the two counts/trees } - Inc(freq[c1], freq[c2]); - freq[c2] := 0; - - { Increment the codesize of everything in c1's tree branch } - Inc(codesize[c1]); - while (others[c1] >= 0) do - begin - c1 := others[c1]; - Inc(codesize[c1]); - end; - - others[c1] := c2; { chain c2 onto c1's tree branch } - - { Increment the codesize of everything in c2's tree branch } - Inc(codesize[c2]); - while (others[c2] >= 0) do - begin - c2 := others[c2]; - Inc(codesize[c2]); - end; - end; - - { Now count the number of symbols of each code length } - for i := 0 to 256 do - begin - if (codesize[i]<>0) then - begin - { The JPEG standard seems to think that this can't happen, } - { but I'm paranoid... } - if (codesize[i] > MAX_CLEN) then - ERREXIT(j_common_ptr(cinfo), JERR_HUFF_CLEN_OVERFLOW); - - Inc(bits[codesize[i]]); - end; - end; - - { JPEG doesn't allow symbols with code lengths over 16 bits, so if the pure - Huffman procedure assigned any such lengths, we must adjust the coding. - Here is what the JPEG spec says about how this next bit works: - Since symbols are paired for the longest Huffman code, the symbols are - removed from this length category two at a time. The prefix for the pair - (which is one bit shorter) is allocated to one of the pair; then, - skipping the BITS entry for that prefix length, a code word from the next - shortest nonzero BITS entry is converted into a prefix for two code words - one bit longer. } - - for i := MAX_CLEN downto 17 do - begin - while (bits[i] > 0) do - begin - j := i - 2; { find length of new prefix to be used } - while (bits[j] = 0) do - Dec(j); - - Dec(bits[i], 2); { remove two symbols } - Inc(bits[i-1]); { one goes in this length } - Inc(bits[j+1], 2); { two new symbols in this length } - Dec(bits[j]); { symbol of this length is now a prefix } - end; - end; - - { Delphi 2: FOR-loop variable 'i' may be undefined after loop } - i := 16; { Nomssi: work around } - - { Remove the count for the pseudo-symbol 256 from the largest codelength } - while (bits[i] = 0) do { find largest codelength still in use } - Dec(i); - Dec(bits[i]); - - { Return final symbol counts (only for lengths 0..16) } - MEMCOPY(@htbl^.bits, @bits, SIZEOF(htbl^.bits)); - - { Return a list of the symbols sorted by code length } - { It's not real clear to me why we don't need to consider the codelength - changes made above, but the JPEG spec seems to think this works. } - - p := 0; - for i := 1 to MAX_CLEN do - begin - for j := 0 to 255 do - begin - if (codesize[j] = i) then - begin - htbl^.huffval[p] := UINT8 (j); - Inc(p); - end; - end; - end; - - { Set sent_table FALSE so updated table will be written to JPEG file. } - htbl^.sent_table := FALSE; -end; - - -{ Finish up a statistics-gathering pass and create the new Huffman tables. } - -{METHODDEF} -procedure finish_pass_gather (cinfo : j_compress_ptr); -var - entropy : huff_entropy_ptr; - ci, dctbl, actbl : int; - compptr : jpeg_component_info_ptr; - htblptr : ^JHUFF_TBL_PTR; - did_dc : array[0..NUM_HUFF_TBLS-1] of boolean; - did_ac : array[0..NUM_HUFF_TBLS-1] of boolean; -begin - entropy := huff_entropy_ptr (cinfo^.entropy); - - { It's important not to apply jpeg_gen_optimal_table more than once - per table, because it clobbers the input frequency counts! } - - MEMZERO(@did_dc, SIZEOF(did_dc)); - MEMZERO(@did_ac, SIZEOF(did_ac)); - - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - dctbl := compptr^.dc_tbl_no; - actbl := compptr^.ac_tbl_no; - if (not did_dc[dctbl]) then - begin - htblptr := @(cinfo^.dc_huff_tbl_ptrs[dctbl]); - if ( htblptr^ = NIL) then - htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo)); - jpeg_gen_optimal_table(cinfo, htblptr^, entropy^.dc_count_ptrs[dctbl]^); - did_dc[dctbl] := TRUE; - end; - if (not did_ac[actbl]) then - begin - htblptr := @(cinfo^.ac_huff_tbl_ptrs[actbl]); - if ( htblptr^ = NIL) then - htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo)); - jpeg_gen_optimal_table(cinfo, htblptr^, entropy^.ac_count_ptrs[actbl]^); - did_ac[actbl] := TRUE; - end; - end; -end; - -{$endif} { ENTROPY_OPT_SUPPORTED } - - -{ Module initialization routine for Huffman entropy encoding. } - -{GLOBAL} -procedure jinit_huff_encoder (cinfo : j_compress_ptr); -var - entropy : huff_entropy_ptr; - i : int; -begin - entropy := huff_entropy_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(huff_entropy_encoder)) ); - cinfo^.entropy := jpeg_entropy_encoder_ptr (entropy); - entropy^.pub.start_pass := start_pass_huff; - - { Mark tables unallocated } - for i := 0 to pred(NUM_HUFF_TBLS) do - begin - entropy^.ac_derived_tbls[i] := NIL; - entropy^.dc_derived_tbls[i] := NIL; -{$ifdef ENTROPY_OPT_SUPPORTED} - entropy^.ac_count_ptrs[i] := NIL; - entropy^.dc_count_ptrs[i] := NIL; -{$endif} - end; -end; - -end. +unit imjchuff; + +{ This file contains Huffman entropy encoding routines. + + Much of the complexity here has to do with supporting output suspension. + If the data destination module demands suspension, we want to be able to + back up to the start of the current MCU. To do this, we copy state + variables into local working storage, and update them back to the + permanent JPEG objects only upon successful completion of an MCU. } + +{ Original: jchuff.c; Copyright (C) 1991-1997, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, { longptr definition missing } + imjpeglib, + imjdeferr, + imjerror, + imjutils, + imjinclude, + imjcomapi; + +{ The legal range of a DCT coefficient is + -1024 .. +1023 for 8-bit data; + -16384 .. +16383 for 12-bit data. + Hence the magnitude should always fit in 10 or 14 bits respectively. } + + +{$ifdef BITS_IN_JSAMPLE_IS_8} +const + MAX_COEF_BITS = 10; +{$else} +const + MAX_COEF_BITS = 14; +{$endif} + +{ Derived data constructed for each Huffman table } +{ Declarations shared with jcphuff.c } +type + c_derived_tbl_ptr = ^c_derived_tbl; + c_derived_tbl = record + ehufco : array[0..256-1] of uInt; { code for each symbol } + ehufsi : array[0..256-1] of byte; { length of code for each symbol } + { If no code has been allocated for a symbol S, ehufsi[S] contains 0 } + end; +{ for JCHUFF und JCPHUFF } +type + TLongTable = array[0..256] of long; + TLongTablePtr = ^TLongTable; + +{ Compute the derived values for a Huffman table. + Note this is also used by jcphuff.c. } + +{GLOBAL} +procedure jpeg_make_c_derived_tbl (cinfo : j_compress_ptr; + isDC : boolean; + tblno : int; + var pdtbl : c_derived_tbl_ptr); + +{ Generate the optimal coding for the given counts, fill htbl. + Note this is also used by jcphuff.c. } + +{GLOBAL} +procedure jpeg_gen_optimal_table (cinfo : j_compress_ptr; + htbl : JHUFF_TBL_PTR; + var freq : TLongTable); { Nomssi } + +{ Module initialization routine for Huffman entropy encoding. } + +{GLOBAL} +procedure jinit_huff_encoder (cinfo : j_compress_ptr); + +implementation + +{ Expanded entropy encoder object for Huffman encoding. + + The savable_state subrecord contains fields that change within an MCU, + but must not be updated permanently until we complete the MCU. } + +type + savable_state = record + put_buffer : INT32; { current bit-accumulation buffer } + put_bits : int; { # of bits now in it } + last_dc_val : array[0..MAX_COMPS_IN_SCAN-1] of int; + { last DC coef for each component } + end; + + +type + huff_entropy_ptr = ^huff_entropy_encoder; + huff_entropy_encoder = record + pub : jpeg_entropy_encoder; { public fields } + + saved : savable_state; { Bit buffer & DC state at start of MCU } + + { These fields are NOT loaded into local working state. } + restarts_to_go : uInt; { MCUs left in this restart interval } + next_restart_num : int; { next restart number to write (0-7) } + + { Pointers to derived tables (these workspaces have image lifespan) } + dc_derived_tbls : array[0..NUM_HUFF_TBLS-1] of c_derived_tbl_ptr; + ac_derived_tbls : array[0..NUM_HUFF_TBLS-1] of c_derived_tbl_ptr; + + {$ifdef ENTROPY_OPT_SUPPORTED} { Statistics tables for optimization } + dc_count_ptrs : array[0..NUM_HUFF_TBLS-1] of TLongTablePtr; + ac_count_ptrs : array[0..NUM_HUFF_TBLS-1] of TLongTablePtr; + {$endif} + end; + + + +{ Working state while writing an MCU. + This struct contains all the fields that are needed by subroutines. } + +type + working_state = record + next_output_byte : JOCTETptr; { => next byte to write in buffer } + free_in_buffer : size_t; { # of byte spaces remaining in buffer } + cur : savable_state; { Current bit buffer & DC state } + cinfo : j_compress_ptr; { dump_buffer needs access to this } + end; + + +{ Forward declarations } +{METHODDEF} +function encode_mcu_huff (cinfo : j_compress_ptr; + const MCU_data : array of JBLOCKROW) : boolean; + forward; +{METHODDEF} +procedure finish_pass_huff (cinfo : j_compress_ptr); forward; +{$ifdef ENTROPY_OPT_SUPPORTED} +{METHODDEF} +function encode_mcu_gather (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; + forward; + +{METHODDEF} +procedure finish_pass_gather (cinfo : j_compress_ptr); forward; +{$endif} + + +{ Initialize for a Huffman-compressed scan. + If gather_statistics is TRUE, we do not output anything during the scan, + just count the Huffman symbols used and generate Huffman code tables. } + +{METHODDEF} +procedure start_pass_huff (cinfo : j_compress_ptr; + gather_statistics : boolean); +var + entropy : huff_entropy_ptr; + ci, dctbl, actbl : int; + compptr : jpeg_component_info_ptr; +begin + entropy := huff_entropy_ptr (cinfo^.entropy); + + if (gather_statistics) then + begin +{$ifdef ENTROPY_OPT_SUPPORTED} + entropy^.pub.encode_mcu := encode_mcu_gather; + entropy^.pub.finish_pass := finish_pass_gather; +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} + end + else + begin + entropy^.pub.encode_mcu := encode_mcu_huff; + entropy^.pub.finish_pass := finish_pass_huff; + end; + + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + dctbl := compptr^.dc_tbl_no; + actbl := compptr^.ac_tbl_no; + if (gather_statistics) then + begin +{$ifdef ENTROPY_OPT_SUPPORTED} + { Check for invalid table indexes } + { (make_c_derived_tbl does this in the other path) } + if (dctbl < 0) or (dctbl >= NUM_HUFF_TBLS) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, dctbl); + if (actbl < 0) or (actbl >= NUM_HUFF_TBLS) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, actbl); + { Allocate and zero the statistics tables } + { Note that jpeg_gen_optimal_table expects 257 entries in each table! } + if (entropy^.dc_count_ptrs[dctbl] = NIL) then + entropy^.dc_count_ptrs[dctbl] := TLongTablePtr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + 257 * SIZEOF(long)) ); + MEMZERO(entropy^.dc_count_ptrs[dctbl], 257 * SIZEOF(long)); + if (entropy^.ac_count_ptrs[actbl] = NIL) then + entropy^.ac_count_ptrs[actbl] := TLongTablePtr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + 257 * SIZEOF(long)) ); + MEMZERO(entropy^.ac_count_ptrs[actbl], 257 * SIZEOF(long)); +{$endif} + end + else + begin + { Compute derived values for Huffman tables } + { We may do this more than once for a table, but it's not expensive } + jpeg_make_c_derived_tbl(cinfo, TRUE, dctbl, + entropy^.dc_derived_tbls[dctbl]); + jpeg_make_c_derived_tbl(cinfo, FALSE, actbl, + entropy^.ac_derived_tbls[actbl]); + end; + { Initialize DC predictions to 0 } + entropy^.saved.last_dc_val[ci] := 0; + end; + + { Initialize bit buffer to empty } + entropy^.saved.put_buffer := 0; + entropy^.saved.put_bits := 0; + + { Initialize restart stuff } + entropy^.restarts_to_go := cinfo^.restart_interval; + entropy^.next_restart_num := 0; +end; + + +{ Compute the derived values for a Huffman table. + This routine also performs some validation checks on the table. + + Note this is also used by jcphuff.c. } + +{GLOBAL} +procedure jpeg_make_c_derived_tbl (cinfo : j_compress_ptr; + isDC : boolean; + tblno : int; + var pdtbl : c_derived_tbl_ptr); +var + htbl : JHUFF_TBL_PTR; + dtbl : c_derived_tbl_ptr; + p, i, l, lastp, si, maxsymbol : int; + huffsize : array[0..257-1] of byte; + huffcode : array[0..257-1] of uInt; + code : uInt; +begin + { Note that huffsize[] and huffcode[] are filled in code-length order, + paralleling the order of the symbols themselves in htbl->huffval[]. } + + { Find the input Huffman table } + if (tblno < 0) or (tblno >= NUM_HUFF_TBLS) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno); + if isDC then + htbl := cinfo^.dc_huff_tbl_ptrs[tblno] + else + htbl := cinfo^.ac_huff_tbl_ptrs[tblno]; + if (htbl = NIL) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno); + + { Allocate a workspace if we haven't already done so. } + if (pdtbl = NIL) then + pdtbl := c_derived_tbl_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(c_derived_tbl)) ); + dtbl := pdtbl; + + { Figure C.1: make table of Huffman code length for each symbol } + + p := 0; + for l := 1 to 16 do + begin + i := int(htbl^.bits[l]); + if (i < 0) and (p + i > 256) then { protect against table overrun } + ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); + while (i > 0) do + begin + huffsize[p] := byte(l); + Inc(p); + Dec(i); + end; + end; + huffsize[p] := 0; + lastp := p; + + { Figure C.2: generate the codes themselves } + { We also validate that the counts represent a legal Huffman code tree. } + + code := 0; + si := huffsize[0]; + p := 0; + while (huffsize[p] <> 0) do + begin + while (( int(huffsize[p]) ) = si) do + begin + huffcode[p] := code; + Inc(p); + Inc(code); + end; + { code is now 1 more than the last code used for codelength si; but + it must still fit in si bits, since no code is allowed to be all ones. } + + if (INT32(code) >= (INT32(1) shl si)) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); + code := code shl 1; + Inc(si); + end; + + { Figure C.3: generate encoding tables } + { These are code and size indexed by symbol value } + + { Set all codeless symbols to have code length 0; + this lets us detect duplicate VAL entries here, and later + allows emit_bits to detect any attempt to emit such symbols. } + + MEMZERO(@dtbl^.ehufsi, SIZEOF(dtbl^.ehufsi)); + + { This is also a convenient place to check for out-of-range + and duplicated VAL entries. We allow 0..255 for AC symbols + but only 0..15 for DC. (We could constrain them further + based on data depth and mode, but this seems enough.) } + + if isDC then + maxsymbol := 15 + else + maxsymbol := 255; + + for p := 0 to pred(lastp) do + begin + i := htbl^.huffval[p]; + if (i < 0) or (i > maxsymbol) or (dtbl^.ehufsi[i] <> 0) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); + dtbl^.ehufco[i] := huffcode[p]; + dtbl^.ehufsi[i] := huffsize[p]; + end; +end; + + +{ Outputting bytes to the file } + + +{LOCAL} +function dump_buffer (var state : working_state) : boolean; +{ Empty the output buffer; return TRUE if successful, FALSE if must suspend } +var + dest : jpeg_destination_mgr_ptr; +begin + dest := state.cinfo^.dest; + + if (not dest^.empty_output_buffer (state.cinfo)) then + begin + dump_buffer := FALSE; + exit; + end; + { After a successful buffer dump, must reset buffer pointers } + state.next_output_byte := dest^.next_output_byte; + state.free_in_buffer := dest^.free_in_buffer; + dump_buffer := TRUE; +end; + + +{ Outputting bits to the file } + +{ Only the right 24 bits of put_buffer are used; the valid bits are + left-justified in this part. At most 16 bits can be passed to emit_bits + in one call, and we never retain more than 7 bits in put_buffer + between calls, so 24 bits are sufficient. } + + +{LOCAL} +function emit_bits (var state : working_state; + code : uInt; + size : int) : boolean; {INLINE} +{ Emit some bits; return TRUE if successful, FALSE if must suspend } +var + { This routine is heavily used, so it's worth coding tightly. } + {register} put_buffer : INT32; + {register} put_bits : int; +var + c : int; +begin + put_buffer := INT32 (code); + put_bits := state.cur.put_bits; + + { if size is 0, caller used an invalid Huffman table entry } + if (size = 0) then + ERREXIT(j_common_ptr(state.cinfo), JERR_HUFF_MISSING_CODE); + + put_buffer := put_buffer and pred(INT32(1) shl size); + { mask off any extra bits in code } + + Inc(put_bits, size); { new number of bits in buffer } + + put_buffer := put_buffer shl (24 - put_bits); + { align incoming bits } + put_buffer := put_buffer or state.cur.put_buffer; + { and merge with old buffer contents } + while (put_bits >= 8) do + begin + c := int ((put_buffer shr 16) and $FF); + + {emit_byte(state, c, return FALSE);} + { Emit a byte, return FALSE if must suspend. } + state.next_output_byte^ := JOCTET (c); + Inc(state.next_output_byte); + Dec(state.free_in_buffer); + if (state.free_in_buffer = 0) then + if not dump_buffer(state) then + begin + emit_bits := FALSE; + exit; + end; + + if (c = $FF) then { need to stuff a zero byte? } + begin + {emit_byte(state, 0, return FALSE);} + state.next_output_byte^ := JOCTET (0); + Inc(state.next_output_byte); + Dec(state.free_in_buffer); + if (state.free_in_buffer = 0) then + if not dump_buffer(state) then + begin + emit_bits := FALSE; + exit; + end; + + end; + put_buffer := put_buffer shl 8; + Dec(put_bits, 8); + end; + + state.cur.put_buffer := put_buffer; { update state variables } + state.cur.put_bits := put_bits; + + emit_bits := TRUE; +end; + + +{LOCAL} +function flush_bits (var state : working_state) : boolean; +begin + if (not emit_bits(state, $7F, 7)) then { fill any partial byte with ones } + begin + flush_bits := FALSE; + exit; + end; + state.cur.put_buffer := 0; { and reset bit-buffer to empty } + state.cur.put_bits := 0; + flush_bits := TRUE; +end; + + +{ Encode a single block's worth of coefficients } + +{LOCAL} +function encode_one_block (var state : working_state; + const block : JBLOCK; + last_dc_val : int; + dctbl : c_derived_tbl_ptr; + actbl : c_derived_tbl_ptr) : boolean; +var + {register} temp, temp2 : int; + {register} nbits : int; + {register} k, r, i : int; +begin + { Encode the DC coefficient difference per section F.1.2.1 } + + temp2 := block[0] - last_dc_val; + temp := temp2; + + if (temp < 0) then + begin + temp := -temp; { temp is abs value of input } + { For a negative input, want temp2 := bitwise complement of abs(input) } + { This code assumes we are on a two's complement machine } + Dec(temp2); + end; + + { Find the number of bits needed for the magnitude of the coefficient } + nbits := 0; + while (temp <> 0) do + begin + Inc(nbits); + temp := temp shr 1; + end; + + { Check for out-of-range coefficient values. + Since we're encoding a difference, the range limit is twice as much. } + + if (nbits > MAX_COEF_BITS+1) then + ERREXIT(j_common_ptr(state.cinfo), JERR_BAD_DCT_COEF); + + { Emit the Huffman-coded symbol for the number of bits } + if not emit_bits(state, dctbl^.ehufco[nbits], dctbl^.ehufsi[nbits]) then + begin + encode_one_block := FALSE; + exit; + end; + + { Emit that number of bits of the value, if positive, } + { or the complement of its magnitude, if negative. } + if (nbits <> 0) then { emit_bits rejects calls with size 0 } + if not emit_bits(state, uInt(temp2), nbits) then + begin + encode_one_block := FALSE; + exit; + end; + + { Encode the AC coefficients per section F.1.2.2 } + + r := 0; { r := run length of zeros } + + for k := 1 to pred(DCTSIZE2) do + begin + temp := block[jpeg_natural_order[k]]; + if (temp = 0) then + begin + Inc(r); + end + else + begin + { if run length > 15, must emit special run-length-16 codes ($F0) } + while (r > 15) do + begin + if not emit_bits(state, actbl^.ehufco[$F0], actbl^.ehufsi[$F0]) then + begin + encode_one_block := FALSE; + exit; + end; + Dec(r, 16); + end; + + temp2 := temp; + if (temp < 0) then + begin + temp := -temp; { temp is abs value of input } + { This code assumes we are on a two's complement machine } + Dec(temp2); + end; + + { Find the number of bits needed for the magnitude of the coefficient } + nbits := 0; { there must be at least one 1 bit } + repeat + Inc(nbits); + temp := temp shr 1; + until (temp = 0); + + { Check for out-of-range coefficient values } + if (nbits > MAX_COEF_BITS) then + ERREXIT(j_common_ptr(state.cinfo), JERR_BAD_DCT_COEF); + + { Emit Huffman symbol for run length / number of bits } + i := (r shl 4) + nbits; + if not emit_bits(state, actbl^.ehufco[i], actbl^.ehufsi[i]) then + begin + encode_one_block := FALSE; + exit; + end; + + { Emit that number of bits of the value, if positive, } + { or the complement of its magnitude, if negative. } + if not emit_bits(state, uInt(temp2), nbits) then + begin + encode_one_block := FALSE; + exit; + end; + + r := 0; + end; + end; + + { If the last coef(s) were zero, emit an end-of-block code } + if (r > 0) then + if not emit_bits(state, actbl^.ehufco[0], actbl^.ehufsi[0]) then + begin + encode_one_block := FALSE; + exit; + end; + + encode_one_block := TRUE; +end; + + +{ Emit a restart marker & resynchronize predictions. } + +{LOCAL} +function emit_restart (var state : working_state; + restart_num : int) : boolean; +var + ci : int; +begin + if (not flush_bits(state)) then + begin + emit_restart := FALSE; + exit; + end; + + {emit_byte(state, $FF, return FALSE);} + { Emit a byte, return FALSE if must suspend. } + state.next_output_byte^ := JOCTET ($FF); + Inc(state.next_output_byte); + Dec(state.free_in_buffer); + if (state.free_in_buffer = 0) then + if not dump_buffer(state) then + begin + emit_restart := FALSE; + exit; + end; + + {emit_byte(state, JPEG_RST0 + restart_num, return FALSE);} + { Emit a byte, return FALSE if must suspend. } + state.next_output_byte^ := JOCTET (JPEG_RST0 + restart_num); + Inc(state.next_output_byte); + Dec(state.free_in_buffer); + if (state.free_in_buffer = 0) then + if not dump_buffer(state) then + begin + emit_restart := FALSE; + exit; + end; + + { Re-initialize DC predictions to 0 } + for ci := 0 to pred(state.cinfo^.comps_in_scan) do + state.cur.last_dc_val[ci] := 0; + + { The restart counter is not updated until we successfully write the MCU. } + + emit_restart := TRUE; +end; + + +{ Encode and output one MCU's worth of Huffman-compressed coefficients. } + +{METHODDEF} +function encode_mcu_huff (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; +var + entropy : huff_entropy_ptr; + state : working_state; + blkn, ci : int; + compptr : jpeg_component_info_ptr; +begin + entropy := huff_entropy_ptr (cinfo^.entropy); + { Load up working state } + state.next_output_byte := cinfo^.dest^.next_output_byte; + state.free_in_buffer := cinfo^.dest^.free_in_buffer; + {ASSIGN_STATE(state.cur, entropy^.saved);} + state.cur := entropy^.saved; + state.cinfo := cinfo; + + { Emit restart marker if needed } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + if not emit_restart(state, entropy^.next_restart_num) then + begin + encode_mcu_huff := FALSE; + exit; + end; + end; + + { Encode the MCU data blocks } + for blkn := 0 to pred(cinfo^.blocks_in_MCU) do + begin + ci := cinfo^.MCU_membership[blkn]; + compptr := cinfo^.cur_comp_info[ci]; + if not encode_one_block(state, + MCU_data[blkn]^[0], + state.cur.last_dc_val[ci], + entropy^.dc_derived_tbls[compptr^.dc_tbl_no], + entropy^.ac_derived_tbls[compptr^.ac_tbl_no]) then + begin + encode_mcu_huff := FALSE; + exit; + end; + { Update last_dc_val } + state.cur.last_dc_val[ci] := MCU_data[blkn]^[0][0]; + end; + + { Completed MCU, so update state } + cinfo^.dest^.next_output_byte := state.next_output_byte; + cinfo^.dest^.free_in_buffer := state.free_in_buffer; + {ASSIGN_STATE(entropy^.saved, state.cur);} + entropy^.saved := state.cur; + + { Update restart-interval state too } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + begin + entropy^.restarts_to_go := cinfo^.restart_interval; + Inc(entropy^.next_restart_num); + with entropy^ do + next_restart_num := next_restart_num and 7; + end; + Dec(entropy^.restarts_to_go); + end; + + encode_mcu_huff := TRUE; +end; + + +{ Finish up at the end of a Huffman-compressed scan. } + +{METHODDEF} +procedure finish_pass_huff (cinfo : j_compress_ptr); +var + entropy : huff_entropy_ptr; + state : working_state; +begin + entropy := huff_entropy_ptr (cinfo^.entropy); + + { Load up working state ... flush_bits needs it } + state.next_output_byte := cinfo^.dest^.next_output_byte; + state.free_in_buffer := cinfo^.dest^.free_in_buffer; + {ASSIGN_STATE(state.cur, entropy^.saved);} + state.cur := entropy^.saved; + state.cinfo := cinfo; + + { Flush out the last data } + if not flush_bits(state) then + ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND); + + { Update state } + cinfo^.dest^.next_output_byte := state.next_output_byte; + cinfo^.dest^.free_in_buffer := state.free_in_buffer; + {ASSIGN_STATE(entropy^.saved, state.cur);} + entropy^.saved := state.cur; +end; + + +{ Huffman coding optimization. + + We first scan the supplied data and count the number of uses of each symbol + that is to be Huffman-coded. (This process MUST agree with the code above.) + Then we build a Huffman coding tree for the observed counts. + Symbols which are not needed at all for the particular image are not + assigned any code, which saves space in the DHT marker as well as in + the compressed data. } + +{$ifdef ENTROPY_OPT_SUPPORTED} + + +{ Process a single block's worth of coefficients } + +{LOCAL} +procedure htest_one_block (cinfo : j_compress_ptr; + const block : JBLOCK; + last_dc_val : int; + dc_counts : TLongTablePtr; + ac_counts : TLongTablePtr); + +var + {register} temp : int; + {register} nbits : int; + {register} k, r : int; +begin + { Encode the DC coefficient difference per section F.1.2.1 } + temp := block[0] - last_dc_val; + if (temp < 0) then + temp := -temp; + + { Find the number of bits needed for the magnitude of the coefficient } + nbits := 0; + while (temp <> 0) do + begin + Inc(nbits); + temp := temp shr 1; + end; + + { Check for out-of-range coefficient values. + Since we're encoding a difference, the range limit is twice as much. } + + if (nbits > MAX_COEF_BITS+1) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_DCT_COEF); + + { Count the Huffman symbol for the number of bits } + Inc(dc_counts^[nbits]); + + { Encode the AC coefficients per section F.1.2.2 } + + r := 0; { r := run length of zeros } + + for k := 1 to pred(DCTSIZE2) do + begin + temp := block[jpeg_natural_order[k]]; + if (temp = 0) then + begin + Inc(r); + end + else + begin + { if run length > 15, must emit special run-length-16 codes ($F0) } + while (r > 15) do + begin + Inc(ac_counts^[$F0]); + Dec(r, 16); + end; + + { Find the number of bits needed for the magnitude of the coefficient } + if (temp < 0) then + temp := -temp; + + { Find the number of bits needed for the magnitude of the coefficient } + nbits := 0; { there must be at least one 1 bit } + repeat + Inc(nbits); + temp := temp shr 1; + until (temp = 0); + + + { Count Huffman symbol for run length / number of bits } + Inc(ac_counts^[(r shl 4) + nbits]); + + r := 0; + end; + end; + + { If the last coef(s) were zero, emit an end-of-block code } + if (r > 0) then + Inc(ac_counts^[0]); +end; + + +{ Trial-encode one MCU's worth of Huffman-compressed coefficients. + No data is actually output, so no suspension return is possible. } + +{METHODDEF} +function encode_mcu_gather (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; +var + entropy : huff_entropy_ptr; + blkn, ci : int; + compptr : jpeg_component_info_ptr; +begin + entropy := huff_entropy_ptr (cinfo^.entropy); + { Take care of restart intervals if needed } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + begin + { Re-initialize DC predictions to 0 } + for ci := 0 to pred(cinfo^.comps_in_scan) do + entropy^.saved.last_dc_val[ci] := 0; + { Update restart state } + entropy^.restarts_to_go := cinfo^.restart_interval; + end; + Dec(entropy^.restarts_to_go); + end; + + for blkn := 0 to pred(cinfo^.blocks_in_MCU) do + begin + ci := cinfo^.MCU_membership[blkn]; + compptr := cinfo^.cur_comp_info[ci]; + htest_one_block(cinfo, MCU_data[blkn]^[0], + entropy^.saved.last_dc_val[ci], + entropy^.dc_count_ptrs[compptr^.dc_tbl_no], + entropy^.ac_count_ptrs[compptr^.ac_tbl_no]); + entropy^.saved.last_dc_val[ci] := MCU_data[blkn]^[0][0]; + end; + + encode_mcu_gather := TRUE; +end; + + +{ Generate the best Huffman code table for the given counts, fill htbl. + Note this is also used by jcphuff.c. + + The JPEG standard requires that no symbol be assigned a codeword of all + one bits (so that padding bits added at the end of a compressed segment + can't look like a valid code). Because of the canonical ordering of + codewords, this just means that there must be an unused slot in the + longest codeword length category. Section K.2 of the JPEG spec suggests + reserving such a slot by pretending that symbol 256 is a valid symbol + with count 1. In theory that's not optimal; giving it count zero but + including it in the symbol set anyway should give a better Huffman code. + But the theoretically better code actually seems to come out worse in + practice, because it produces more all-ones bytes (which incur stuffed + zero bytes in the final file). In any case the difference is tiny. + + The JPEG standard requires Huffman codes to be no more than 16 bits long. + If some symbols have a very small but nonzero probability, the Huffman tree + must be adjusted to meet the code length restriction. We currently use + the adjustment method suggested in JPEG section K.2. This method is *not* + optimal; it may not choose the best possible limited-length code. But + typically only very-low-frequency symbols will be given less-than-optimal + lengths, so the code is almost optimal. Experimental comparisons against + an optimal limited-length-code algorithm indicate that the difference is + microscopic --- usually less than a hundredth of a percent of total size. + So the extra complexity of an optimal algorithm doesn't seem worthwhile. } + + +{GLOBAL} +procedure jpeg_gen_optimal_table (cinfo : j_compress_ptr; + htbl : JHUFF_TBL_PTR; + var freq : TLongTable); +const + MAX_CLEN = 32; { assumed maximum initial code length } +var + bits : array[0..MAX_CLEN+1-1] of UINT8; { bits[k] := # of symbols with code length k } + codesize : array[0..257-1] of int; { codesize[k] := code length of symbol k } + others : array[0..257-1] of int; { next symbol in current branch of tree } + c1, c2 : int; + p, i, j : int; + v : long; +begin + { This algorithm is explained in section K.2 of the JPEG standard } + + MEMZERO(@bits, SIZEOF(bits)); + MEMZERO(@codesize, SIZEOF(codesize)); + for i := 0 to 256 do + others[i] := -1; { init links to empty } + + freq[256] := 1; { make sure 256 has a nonzero count } + { Including the pseudo-symbol 256 in the Huffman procedure guarantees + that no real symbol is given code-value of all ones, because 256 + will be placed last in the largest codeword category. } + + { Huffman's basic algorithm to assign optimal code lengths to symbols } + + while TRUE do + begin + { Find the smallest nonzero frequency, set c1 := its symbol } + { In case of ties, take the larger symbol number } + c1 := -1; + v := long(1000000000); + for i := 0 to 256 do + begin + if (freq[i] <> 0) and (freq[i] <= v) then + begin + v := freq[i]; + c1 := i; + end; + end; + + { Find the next smallest nonzero frequency, set c2 := its symbol } + { In case of ties, take the larger symbol number } + c2 := -1; + v := long(1000000000); + for i := 0 to 256 do + begin + if (freq[i] <> 0) and (freq[i] <= v) and (i <> c1) then + begin + v := freq[i]; + c2 := i; + end; + end; + + { Done if we've merged everything into one frequency } + if (c2 < 0) then + break; + + { Else merge the two counts/trees } + Inc(freq[c1], freq[c2]); + freq[c2] := 0; + + { Increment the codesize of everything in c1's tree branch } + Inc(codesize[c1]); + while (others[c1] >= 0) do + begin + c1 := others[c1]; + Inc(codesize[c1]); + end; + + others[c1] := c2; { chain c2 onto c1's tree branch } + + { Increment the codesize of everything in c2's tree branch } + Inc(codesize[c2]); + while (others[c2] >= 0) do + begin + c2 := others[c2]; + Inc(codesize[c2]); + end; + end; + + { Now count the number of symbols of each code length } + for i := 0 to 256 do + begin + if (codesize[i]<>0) then + begin + { The JPEG standard seems to think that this can't happen, } + { but I'm paranoid... } + if (codesize[i] > MAX_CLEN) then + ERREXIT(j_common_ptr(cinfo), JERR_HUFF_CLEN_OVERFLOW); + + Inc(bits[codesize[i]]); + end; + end; + + { JPEG doesn't allow symbols with code lengths over 16 bits, so if the pure + Huffman procedure assigned any such lengths, we must adjust the coding. + Here is what the JPEG spec says about how this next bit works: + Since symbols are paired for the longest Huffman code, the symbols are + removed from this length category two at a time. The prefix for the pair + (which is one bit shorter) is allocated to one of the pair; then, + skipping the BITS entry for that prefix length, a code word from the next + shortest nonzero BITS entry is converted into a prefix for two code words + one bit longer. } + + for i := MAX_CLEN downto 17 do + begin + while (bits[i] > 0) do + begin + j := i - 2; { find length of new prefix to be used } + while (bits[j] = 0) do + Dec(j); + + Dec(bits[i], 2); { remove two symbols } + Inc(bits[i-1]); { one goes in this length } + Inc(bits[j+1], 2); { two new symbols in this length } + Dec(bits[j]); { symbol of this length is now a prefix } + end; + end; + + { Delphi 2: FOR-loop variable 'i' may be undefined after loop } + i := 16; { Nomssi: work around } + + { Remove the count for the pseudo-symbol 256 from the largest codelength } + while (bits[i] = 0) do { find largest codelength still in use } + Dec(i); + Dec(bits[i]); + + { Return final symbol counts (only for lengths 0..16) } + MEMCOPY(@htbl^.bits, @bits, SIZEOF(htbl^.bits)); + + { Return a list of the symbols sorted by code length } + { It's not real clear to me why we don't need to consider the codelength + changes made above, but the JPEG spec seems to think this works. } + + p := 0; + for i := 1 to MAX_CLEN do + begin + for j := 0 to 255 do + begin + if (codesize[j] = i) then + begin + htbl^.huffval[p] := UINT8 (j); + Inc(p); + end; + end; + end; + + { Set sent_table FALSE so updated table will be written to JPEG file. } + htbl^.sent_table := FALSE; +end; + + +{ Finish up a statistics-gathering pass and create the new Huffman tables. } + +{METHODDEF} +procedure finish_pass_gather (cinfo : j_compress_ptr); +var + entropy : huff_entropy_ptr; + ci, dctbl, actbl : int; + compptr : jpeg_component_info_ptr; + htblptr : ^JHUFF_TBL_PTR; + did_dc : array[0..NUM_HUFF_TBLS-1] of boolean; + did_ac : array[0..NUM_HUFF_TBLS-1] of boolean; +begin + entropy := huff_entropy_ptr (cinfo^.entropy); + + { It's important not to apply jpeg_gen_optimal_table more than once + per table, because it clobbers the input frequency counts! } + + MEMZERO(@did_dc, SIZEOF(did_dc)); + MEMZERO(@did_ac, SIZEOF(did_ac)); + + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + dctbl := compptr^.dc_tbl_no; + actbl := compptr^.ac_tbl_no; + if (not did_dc[dctbl]) then + begin + htblptr := @(cinfo^.dc_huff_tbl_ptrs[dctbl]); + if ( htblptr^ = NIL) then + htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo)); + jpeg_gen_optimal_table(cinfo, htblptr^, entropy^.dc_count_ptrs[dctbl]^); + did_dc[dctbl] := TRUE; + end; + if (not did_ac[actbl]) then + begin + htblptr := @(cinfo^.ac_huff_tbl_ptrs[actbl]); + if ( htblptr^ = NIL) then + htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo)); + jpeg_gen_optimal_table(cinfo, htblptr^, entropy^.ac_count_ptrs[actbl]^); + did_ac[actbl] := TRUE; + end; + end; +end; + +{$endif} { ENTROPY_OPT_SUPPORTED } + + +{ Module initialization routine for Huffman entropy encoding. } + +{GLOBAL} +procedure jinit_huff_encoder (cinfo : j_compress_ptr); +var + entropy : huff_entropy_ptr; + i : int; +begin + entropy := huff_entropy_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(huff_entropy_encoder)) ); + cinfo^.entropy := jpeg_entropy_encoder_ptr (entropy); + entropy^.pub.start_pass := start_pass_huff; + + { Mark tables unallocated } + for i := 0 to pred(NUM_HUFF_TBLS) do + begin + entropy^.ac_derived_tbls[i] := NIL; + entropy^.dc_derived_tbls[i] := NIL; +{$ifdef ENTROPY_OPT_SUPPORTED} + entropy^.ac_count_ptrs[i] := NIL; + entropy^.dc_count_ptrs[i] := NIL; +{$endif} + end; +end; + +end. diff --git a/Imaging/JpegLib/imjcinit.pas b/Imaging/JpegLib/imjcinit.pas index 2a844e6..2e495c0 100644 --- a/Imaging/JpegLib/imjcinit.pas +++ b/Imaging/JpegLib/imjcinit.pas @@ -1,95 +1,95 @@ -unit imjcinit; - -{ Original: jcinit.c ; Copyright (C) 1991-1997, Thomas G. Lane. } - -{ This file contains initialization logic for the JPEG compressor. - This routine is in charge of selecting the modules to be executed and - making an initialization call to each one. - - Logically, this code belongs in jcmaster.c. It's split out because - linking this routine implies linking the entire compression library. - For a transcoding-only application, we want to be able to use jcmaster.c - without linking in the whole library. } - -interface - -{$I imjconfig.inc} - -uses - imjinclude, - imjdeferr, - imjerror, - imjpeglib, -{$ifdef C_PROGRESSIVE_SUPPORTED} - imjcphuff, -{$endif} - imjchuff, imjcmaster, imjccolor, imjcsample, imjcprepct, - imjcdctmgr, imjccoefct, imjcmainct, imjcmarker; - -{ Master selection of compression modules. - This is done once at the start of processing an image. We determine - which modules will be used and give them appropriate initialization calls. } - -{GLOBAL} -procedure jinit_compress_master (cinfo : j_compress_ptr); - -implementation - - - -{ Master selection of compression modules. - This is done once at the start of processing an image. We determine - which modules will be used and give them appropriate initialization calls. } - -{GLOBAL} -procedure jinit_compress_master (cinfo : j_compress_ptr); -begin - { Initialize master control (includes parameter checking/processing) } - jinit_c_master_control(cinfo, FALSE { full compression }); - - { Preprocessing } - if (not cinfo^.raw_data_in) then - begin - jinit_color_converter(cinfo); - jinit_downsampler(cinfo); - jinit_c_prep_controller(cinfo, FALSE { never need full buffer here }); - end; - { Forward DCT } - jinit_forward_dct(cinfo); - { Entropy encoding: either Huffman or arithmetic coding. } - if (cinfo^.arith_code) then - begin - ERREXIT(j_common_ptr(cinfo), JERR_ARITH_NOTIMPL); - end - else - begin - if (cinfo^.progressive_mode) then - begin -{$ifdef C_PROGRESSIVE_SUPPORTED} - jinit_phuff_encoder(cinfo); -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} - end - else - jinit_huff_encoder(cinfo); - end; - - { Need a full-image coefficient buffer in any multi-pass mode. } - jinit_c_coef_controller(cinfo, - (cinfo^.num_scans > 1) or (cinfo^.optimize_coding)); - jinit_c_main_controller(cinfo, FALSE { never need full buffer here }); - - jinit_marker_writer(cinfo); - - { We can now tell the memory manager to allocate virtual arrays. } - cinfo^.mem^.realize_virt_arrays (j_common_ptr(cinfo)); - - { Write the datastream header (SOI) immediately. - Frame and scan headers are postponed till later. - This lets application insert special markers after the SOI. } - - cinfo^.marker^.write_file_header (cinfo); -end; - -end. +unit imjcinit; + +{ Original: jcinit.c ; Copyright (C) 1991-1997, Thomas G. Lane. } + +{ This file contains initialization logic for the JPEG compressor. + This routine is in charge of selecting the modules to be executed and + making an initialization call to each one. + + Logically, this code belongs in jcmaster.c. It's split out because + linking this routine implies linking the entire compression library. + For a transcoding-only application, we want to be able to use jcmaster.c + without linking in the whole library. } + +interface + +{$I imjconfig.inc} + +uses + imjinclude, + imjdeferr, + imjerror, + imjpeglib, +{$ifdef C_PROGRESSIVE_SUPPORTED} + imjcphuff, +{$endif} + imjchuff, imjcmaster, imjccolor, imjcsample, imjcprepct, + imjcdctmgr, imjccoefct, imjcmainct, imjcmarker; + +{ Master selection of compression modules. + This is done once at the start of processing an image. We determine + which modules will be used and give them appropriate initialization calls. } + +{GLOBAL} +procedure jinit_compress_master (cinfo : j_compress_ptr); + +implementation + + + +{ Master selection of compression modules. + This is done once at the start of processing an image. We determine + which modules will be used and give them appropriate initialization calls. } + +{GLOBAL} +procedure jinit_compress_master (cinfo : j_compress_ptr); +begin + { Initialize master control (includes parameter checking/processing) } + jinit_c_master_control(cinfo, FALSE { full compression }); + + { Preprocessing } + if (not cinfo^.raw_data_in) then + begin + jinit_color_converter(cinfo); + jinit_downsampler(cinfo); + jinit_c_prep_controller(cinfo, FALSE { never need full buffer here }); + end; + { Forward DCT } + jinit_forward_dct(cinfo); + { Entropy encoding: either Huffman or arithmetic coding. } + if (cinfo^.arith_code) then + begin + ERREXIT(j_common_ptr(cinfo), JERR_ARITH_NOTIMPL); + end + else + begin + if (cinfo^.progressive_mode) then + begin +{$ifdef C_PROGRESSIVE_SUPPORTED} + jinit_phuff_encoder(cinfo); +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} + end + else + jinit_huff_encoder(cinfo); + end; + + { Need a full-image coefficient buffer in any multi-pass mode. } + jinit_c_coef_controller(cinfo, + (cinfo^.num_scans > 1) or (cinfo^.optimize_coding)); + jinit_c_main_controller(cinfo, FALSE { never need full buffer here }); + + jinit_marker_writer(cinfo); + + { We can now tell the memory manager to allocate virtual arrays. } + cinfo^.mem^.realize_virt_arrays (j_common_ptr(cinfo)); + + { Write the datastream header (SOI) immediately. + Frame and scan headers are postponed till later. + This lets application insert special markers after the SOI. } + + cinfo^.marker^.write_file_header (cinfo); +end; + +end. diff --git a/Imaging/JpegLib/imjcmainct.pas b/Imaging/JpegLib/imjcmainct.pas index 196fad4..53c0349 100644 --- a/Imaging/JpegLib/imjcmainct.pas +++ b/Imaging/JpegLib/imjcmainct.pas @@ -1,343 +1,343 @@ -unit imjcmainct; - -{ This file contains the main buffer controller for compression. - The main buffer lies between the pre-processor and the JPEG - compressor proper; it holds downsampled data in the JPEG colorspace. } - -{ Original : jcmainct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -{ Note: currently, there is no operating mode in which a full-image buffer - is needed at this step. If there were, that mode could not be used with - "raw data" input, since this module is bypassed in that case. However, - we've left the code here for possible use in special applications. } - -{$undef FULL_MAIN_BUFFER_SUPPORTED} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, -{$ifdef FULL_MAIN_BUFFER_SUPPORTED} - imjutils, -{$endif} - imjpeglib; - -{ Initialize main buffer controller. } - -{GLOBAL} -procedure jinit_c_main_controller (cinfo : j_compress_ptr; - need_full_buffer : boolean); - -implementation - - -{ Private buffer controller object } - -type - my_main_ptr = ^my_main_controller; - my_main_controller = record - pub : jpeg_c_main_controller; { public fields } - - cur_iMCU_row : JDIMENSION; { number of current iMCU row } - rowgroup_ctr : JDIMENSION; { counts row groups received in iMCU row } - suspended : boolean; { remember if we suspended output } - pass_mode : J_BUF_MODE; { current operating mode } - - { If using just a strip buffer, this points to the entire set of buffers - (we allocate one for each component). In the full-image case, this - points to the currently accessible strips of the virtual arrays. } - - buffer : array[0..MAX_COMPONENTS-1] of JSAMPARRAY; - - {$ifdef FULL_MAIN_BUFFER_SUPPORTED} - { If using full-image storage, this array holds pointers to virtual-array - control blocks for each component. Unused if not full-image storage. } - - whole_image : array[0..MAX_COMPONENTS-1] of jvirt_sarray_ptr; - {$endif} - end; {my_main_controller} - - -{ Forward declarations } -{METHODDEF} -procedure process_data_simple_main(cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - var in_row_ctr: JDIMENSION; - in_rows_avail : JDIMENSION); forward; - -{$ifdef FULL_MAIN_BUFFER_SUPPORTED} -{METHODDEF} -procedure process_data_buffer_main(cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - var in_row_ctr : JDIMENSION; - in_rows_avail : JDIMENSION); forward; -{$endif} - - -{ Initialize for a processing pass. } - -{METHODDEF} -procedure start_pass_main (cinfo : j_compress_ptr; - pass_mode : J_BUF_MODE); -var - main : my_main_ptr; -begin - main := my_main_ptr (cinfo^.main); - - { Do nothing in raw-data mode. } - if (cinfo^.raw_data_in) then - exit; - - main^.cur_iMCU_row := 0; { initialize counters } - main^.rowgroup_ctr := 0; - main^.suspended := FALSE; - main^.pass_mode := pass_mode; { save mode for use by process_data } - - case (pass_mode) of - JBUF_PASS_THRU: - begin -{$ifdef FULL_MAIN_BUFFER_SUPPORTED} - if (main^.whole_image[0] <> NIL) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); -{$endif} - main^.pub.process_data := process_data_simple_main; - end; -{$ifdef FULL_MAIN_BUFFER_SUPPORTED} - JBUF_SAVE_SOURCE, - JBUF_CRANK_DEST, - JBUF_SAVE_AND_PASS: - begin - if (main^.whole_image[0] = NIL) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - main^.pub.process_data := process_data_buffer_main; - end; -{$endif} - else - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - end; -end; - - -{ Process some data. - This routine handles the simple pass-through mode, - where we have only a strip buffer. } - -{METHODDEF} -procedure process_data_simple_main (cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - var in_row_ctr : JDIMENSION; - in_rows_avail : JDIMENSION); -var - main : my_main_ptr; -begin - main := my_main_ptr (cinfo^.main); - - while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do - begin - { Read input data if we haven't filled the main buffer yet } - if (main^.rowgroup_ctr < DCTSIZE) then - cinfo^.prep^.pre_process_data (cinfo, - input_buf, - in_row_ctr, - in_rows_avail, - JSAMPIMAGE(@main^.buffer), - main^.rowgroup_ctr, - JDIMENSION(DCTSIZE)); - - { If we don't have a full iMCU row buffered, return to application for - more data. Note that preprocessor will always pad to fill the iMCU row - at the bottom of the image. } - if (main^.rowgroup_ctr <> DCTSIZE) then - exit; - - { Send the completed row to the compressor } - if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(@main^.buffer))) then - begin - { If compressor did not consume the whole row, then we must need to - suspend processing and return to the application. In this situation - we pretend we didn't yet consume the last input row; otherwise, if - it happened to be the last row of the image, the application would - think we were done. } - - if (not main^.suspended) then - begin - Dec(in_row_ctr); - main^.suspended := TRUE; - end; - exit; - end; - { We did finish the row. Undo our little suspension hack if a previous - call suspended; then mark the main buffer empty. } - - if (main^.suspended) then - begin - Inc(in_row_ctr); - main^.suspended := FALSE; - end; - main^.rowgroup_ctr := 0; - Inc(main^.cur_iMCU_row); - end; -end; - - -{$ifdef FULL_MAIN_BUFFER_SUPPORTED} - -{ Process some data. - This routine handles all of the modes that use a full-size buffer. } - -{METHODDEF} -procedure process_data_buffer_main (cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - var in_row_ctr : JDIMENSION; - in_rows_avail : JDIMENSION); -var - main : my_main_ptr; - ci : int; - compptr : jpeg_component_info_ptr; - writing : boolean; -begin - main := my_main_ptr (cinfo^.main); - writing := (main^.pass_mode <> JBUF_CRANK_DEST); - - while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do - begin - { Realign the virtual buffers if at the start of an iMCU row. } - if (main^.rowgroup_ctr = 0) then - begin - compptr := cinfo^.comp_info; - for ci := 0 to pred(cinfo^.num_components) do - begin - main^.buffer[ci] := cinfo^.mem^.access_virt_sarray - (j_common_ptr (cinfo), main^.whole_image[ci], - main^.cur_iMCU_row * (compptr^.v_samp_factor * DCTSIZE), - JDIMENSION (compptr^.v_samp_factor * DCTSIZE), writing); - Inc(compptr); - end; - { In a read pass, pretend we just read some source data. } - if (not writing) then - begin - Inc(in_row_ctr, cinfo^.max_v_samp_factor * DCTSIZE); - main^.rowgroup_ctr := DCTSIZE; - end; - end; - - { If a write pass, read input data until the current iMCU row is full. } - { Note: preprocessor will pad if necessary to fill the last iMCU row. } - if (writing) then - begin - cinfo^.prep^.pre_process_data (cinfo, - input_buf, in_row_ctr, in_rows_avail, - JSAMPIMAGE(@main^.buffer), - main^.rowgroup_ctr, - JDIMENSION (DCTSIZE)); - - { Return to application if we need more data to fill the iMCU row. } - if (main^.rowgroup_ctr < DCTSIZE) then - exit; - end; - - { Emit data, unless this is a sink-only pass. } - if (main^.pass_mode <> JBUF_SAVE_SOURCE) then - begin - if (not cinfo^.coef^.compress_data (cinfo, - JSAMPIMAGE(@main^.buffer))) then - begin - { If compressor did not consume the whole row, then we must need to - suspend processing and return to the application. In this situation - we pretend we didn't yet consume the last input row; otherwise, if - it happened to be the last row of the image, the application would - think we were done. } - - if (not main^.suspended) then - begin - Dec(in_row_ctr); - main^.suspended := TRUE; - end; - exit; - end; - { We did finish the row. Undo our little suspension hack if a previous - call suspended; then mark the main buffer empty. } - - if (main^.suspended) then - begin - Inc(in_row_ctr); - main^.suspended := FALSE; - end; - end; - - { If get here, we are done with this iMCU row. Mark buffer empty. } - main^.rowgroup_ctr := 0; - Inc(main^.cur_iMCU_row); - end; -end; - -{$endif} { FULL_MAIN_BUFFER_SUPPORTED } - - -{ Initialize main buffer controller. } - -{GLOBAL} -procedure jinit_c_main_controller (cinfo : j_compress_ptr; - need_full_buffer : boolean); -var - main : my_main_ptr; - ci : int; - compptr : jpeg_component_info_ptr; -begin - main := my_main_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_main_controller)) ); - cinfo^.main := jpeg_c_main_controller_ptr(main); - main^.pub.start_pass := start_pass_main; - - { We don't need to create a buffer in raw-data mode. } - if (cinfo^.raw_data_in) then - exit; - - { Create the buffer. It holds downsampled data, so each component - may be of a different size. } - - if (need_full_buffer) then - begin -{$ifdef FULL_MAIN_BUFFER_SUPPORTED} - { Allocate a full-image virtual array for each component } - { Note we pad the bottom to a multiple of the iMCU height } - compptr := cinfo^.comp_info; - for ci := 0 to pred(cinfo^.num_components) do - begin - main^.whole_image[ci] := cinfo^.mem^.request_virt_sarray - (j_common_ptr(cinfo), JPOOL_IMAGE, FALSE, - compptr^.width_in_blocks * DCTSIZE, - JDIMENSION (jround_up( long (compptr^.height_in_blocks), - long (compptr^.v_samp_factor)) * DCTSIZE), - JDIMENSION (compptr^.v_samp_factor * DCTSIZE)); - Inc(compptr); - end; -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); -{$endif} - end - else - begin -{$ifdef FULL_MAIN_BUFFER_SUPPORTED} - main^.whole_image[0] := NIL; { flag for no virtual arrays } -{$endif} - { Allocate a strip buffer for each component } - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - main^.buffer[ci] := cinfo^.mem^.alloc_sarray - (j_common_ptr(cinfo), JPOOL_IMAGE, - compptr^.width_in_blocks * DCTSIZE, - JDIMENSION (compptr^.v_samp_factor * DCTSIZE)); - Inc(compptr); - end; - end; -end; - -end. +unit imjcmainct; + +{ This file contains the main buffer controller for compression. + The main buffer lies between the pre-processor and the JPEG + compressor proper; it holds downsampled data in the JPEG colorspace. } + +{ Original : jcmainct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +{ Note: currently, there is no operating mode in which a full-image buffer + is needed at this step. If there were, that mode could not be used with + "raw data" input, since this module is bypassed in that case. However, + we've left the code here for possible use in special applications. } + +{$undef FULL_MAIN_BUFFER_SUPPORTED} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, +{$ifdef FULL_MAIN_BUFFER_SUPPORTED} + imjutils, +{$endif} + imjpeglib; + +{ Initialize main buffer controller. } + +{GLOBAL} +procedure jinit_c_main_controller (cinfo : j_compress_ptr; + need_full_buffer : boolean); + +implementation + + +{ Private buffer controller object } + +type + my_main_ptr = ^my_main_controller; + my_main_controller = record + pub : jpeg_c_main_controller; { public fields } + + cur_iMCU_row : JDIMENSION; { number of current iMCU row } + rowgroup_ctr : JDIMENSION; { counts row groups received in iMCU row } + suspended : boolean; { remember if we suspended output } + pass_mode : J_BUF_MODE; { current operating mode } + + { If using just a strip buffer, this points to the entire set of buffers + (we allocate one for each component). In the full-image case, this + points to the currently accessible strips of the virtual arrays. } + + buffer : array[0..MAX_COMPONENTS-1] of JSAMPARRAY; + + {$ifdef FULL_MAIN_BUFFER_SUPPORTED} + { If using full-image storage, this array holds pointers to virtual-array + control blocks for each component. Unused if not full-image storage. } + + whole_image : array[0..MAX_COMPONENTS-1] of jvirt_sarray_ptr; + {$endif} + end; {my_main_controller} + + +{ Forward declarations } +{METHODDEF} +procedure process_data_simple_main(cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + var in_row_ctr: JDIMENSION; + in_rows_avail : JDIMENSION); forward; + +{$ifdef FULL_MAIN_BUFFER_SUPPORTED} +{METHODDEF} +procedure process_data_buffer_main(cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + var in_row_ctr : JDIMENSION; + in_rows_avail : JDIMENSION); forward; +{$endif} + + +{ Initialize for a processing pass. } + +{METHODDEF} +procedure start_pass_main (cinfo : j_compress_ptr; + pass_mode : J_BUF_MODE); +var + main : my_main_ptr; +begin + main := my_main_ptr (cinfo^.main); + + { Do nothing in raw-data mode. } + if (cinfo^.raw_data_in) then + exit; + + main^.cur_iMCU_row := 0; { initialize counters } + main^.rowgroup_ctr := 0; + main^.suspended := FALSE; + main^.pass_mode := pass_mode; { save mode for use by process_data } + + case (pass_mode) of + JBUF_PASS_THRU: + begin +{$ifdef FULL_MAIN_BUFFER_SUPPORTED} + if (main^.whole_image[0] <> NIL) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); +{$endif} + main^.pub.process_data := process_data_simple_main; + end; +{$ifdef FULL_MAIN_BUFFER_SUPPORTED} + JBUF_SAVE_SOURCE, + JBUF_CRANK_DEST, + JBUF_SAVE_AND_PASS: + begin + if (main^.whole_image[0] = NIL) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + main^.pub.process_data := process_data_buffer_main; + end; +{$endif} + else + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + end; +end; + + +{ Process some data. + This routine handles the simple pass-through mode, + where we have only a strip buffer. } + +{METHODDEF} +procedure process_data_simple_main (cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + var in_row_ctr : JDIMENSION; + in_rows_avail : JDIMENSION); +var + main : my_main_ptr; +begin + main := my_main_ptr (cinfo^.main); + + while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do + begin + { Read input data if we haven't filled the main buffer yet } + if (main^.rowgroup_ctr < DCTSIZE) then + cinfo^.prep^.pre_process_data (cinfo, + input_buf, + in_row_ctr, + in_rows_avail, + JSAMPIMAGE(@main^.buffer), + main^.rowgroup_ctr, + JDIMENSION(DCTSIZE)); + + { If we don't have a full iMCU row buffered, return to application for + more data. Note that preprocessor will always pad to fill the iMCU row + at the bottom of the image. } + if (main^.rowgroup_ctr <> DCTSIZE) then + exit; + + { Send the completed row to the compressor } + if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(@main^.buffer))) then + begin + { If compressor did not consume the whole row, then we must need to + suspend processing and return to the application. In this situation + we pretend we didn't yet consume the last input row; otherwise, if + it happened to be the last row of the image, the application would + think we were done. } + + if (not main^.suspended) then + begin + Dec(in_row_ctr); + main^.suspended := TRUE; + end; + exit; + end; + { We did finish the row. Undo our little suspension hack if a previous + call suspended; then mark the main buffer empty. } + + if (main^.suspended) then + begin + Inc(in_row_ctr); + main^.suspended := FALSE; + end; + main^.rowgroup_ctr := 0; + Inc(main^.cur_iMCU_row); + end; +end; + + +{$ifdef FULL_MAIN_BUFFER_SUPPORTED} + +{ Process some data. + This routine handles all of the modes that use a full-size buffer. } + +{METHODDEF} +procedure process_data_buffer_main (cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + var in_row_ctr : JDIMENSION; + in_rows_avail : JDIMENSION); +var + main : my_main_ptr; + ci : int; + compptr : jpeg_component_info_ptr; + writing : boolean; +begin + main := my_main_ptr (cinfo^.main); + writing := (main^.pass_mode <> JBUF_CRANK_DEST); + + while (main^.cur_iMCU_row < cinfo^.total_iMCU_rows) do + begin + { Realign the virtual buffers if at the start of an iMCU row. } + if (main^.rowgroup_ctr = 0) then + begin + compptr := cinfo^.comp_info; + for ci := 0 to pred(cinfo^.num_components) do + begin + main^.buffer[ci] := cinfo^.mem^.access_virt_sarray + (j_common_ptr (cinfo), main^.whole_image[ci], + main^.cur_iMCU_row * (compptr^.v_samp_factor * DCTSIZE), + JDIMENSION (compptr^.v_samp_factor * DCTSIZE), writing); + Inc(compptr); + end; + { In a read pass, pretend we just read some source data. } + if (not writing) then + begin + Inc(in_row_ctr, cinfo^.max_v_samp_factor * DCTSIZE); + main^.rowgroup_ctr := DCTSIZE; + end; + end; + + { If a write pass, read input data until the current iMCU row is full. } + { Note: preprocessor will pad if necessary to fill the last iMCU row. } + if (writing) then + begin + cinfo^.prep^.pre_process_data (cinfo, + input_buf, in_row_ctr, in_rows_avail, + JSAMPIMAGE(@main^.buffer), + main^.rowgroup_ctr, + JDIMENSION (DCTSIZE)); + + { Return to application if we need more data to fill the iMCU row. } + if (main^.rowgroup_ctr < DCTSIZE) then + exit; + end; + + { Emit data, unless this is a sink-only pass. } + if (main^.pass_mode <> JBUF_SAVE_SOURCE) then + begin + if (not cinfo^.coef^.compress_data (cinfo, + JSAMPIMAGE(@main^.buffer))) then + begin + { If compressor did not consume the whole row, then we must need to + suspend processing and return to the application. In this situation + we pretend we didn't yet consume the last input row; otherwise, if + it happened to be the last row of the image, the application would + think we were done. } + + if (not main^.suspended) then + begin + Dec(in_row_ctr); + main^.suspended := TRUE; + end; + exit; + end; + { We did finish the row. Undo our little suspension hack if a previous + call suspended; then mark the main buffer empty. } + + if (main^.suspended) then + begin + Inc(in_row_ctr); + main^.suspended := FALSE; + end; + end; + + { If get here, we are done with this iMCU row. Mark buffer empty. } + main^.rowgroup_ctr := 0; + Inc(main^.cur_iMCU_row); + end; +end; + +{$endif} { FULL_MAIN_BUFFER_SUPPORTED } + + +{ Initialize main buffer controller. } + +{GLOBAL} +procedure jinit_c_main_controller (cinfo : j_compress_ptr; + need_full_buffer : boolean); +var + main : my_main_ptr; + ci : int; + compptr : jpeg_component_info_ptr; +begin + main := my_main_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_main_controller)) ); + cinfo^.main := jpeg_c_main_controller_ptr(main); + main^.pub.start_pass := start_pass_main; + + { We don't need to create a buffer in raw-data mode. } + if (cinfo^.raw_data_in) then + exit; + + { Create the buffer. It holds downsampled data, so each component + may be of a different size. } + + if (need_full_buffer) then + begin +{$ifdef FULL_MAIN_BUFFER_SUPPORTED} + { Allocate a full-image virtual array for each component } + { Note we pad the bottom to a multiple of the iMCU height } + compptr := cinfo^.comp_info; + for ci := 0 to pred(cinfo^.num_components) do + begin + main^.whole_image[ci] := cinfo^.mem^.request_virt_sarray + (j_common_ptr(cinfo), JPOOL_IMAGE, FALSE, + compptr^.width_in_blocks * DCTSIZE, + JDIMENSION (jround_up( long (compptr^.height_in_blocks), + long (compptr^.v_samp_factor)) * DCTSIZE), + JDIMENSION (compptr^.v_samp_factor * DCTSIZE)); + Inc(compptr); + end; +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); +{$endif} + end + else + begin +{$ifdef FULL_MAIN_BUFFER_SUPPORTED} + main^.whole_image[0] := NIL; { flag for no virtual arrays } +{$endif} + { Allocate a strip buffer for each component } + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + main^.buffer[ci] := cinfo^.mem^.alloc_sarray + (j_common_ptr(cinfo), JPOOL_IMAGE, + compptr^.width_in_blocks * DCTSIZE, + JDIMENSION (compptr^.v_samp_factor * DCTSIZE)); + Inc(compptr); + end; + end; +end; + +end. diff --git a/Imaging/JpegLib/imjcmarker.pas b/Imaging/JpegLib/imjcmarker.pas index d415607..9c84d27 100644 --- a/Imaging/JpegLib/imjcmarker.pas +++ b/Imaging/JpegLib/imjcmarker.pas @@ -1,724 +1,724 @@ -unit imjcmarker; - -{ This file contains routines to write JPEG datastream markers. } - -{ Original: jcmarker.c; Copyright (C) 1991-1998, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjinclude, imjmorecfg, imjerror, - imjdeferr, imjpeglib, imjutils; - - -const - { JPEG marker codes } - M_SOF0 = $c0; - M_SOF1 = $c1; - M_SOF2 = $c2; - M_SOF3 = $c3; - - M_SOF5 = $c5; - M_SOF6 = $c6; - M_SOF7 = $c7; - - M_JPG = $c8; - M_SOF9 = $c9; - M_SOF10 = $ca; - M_SOF11 = $cb; - - M_SOF13 = $cd; - M_SOF14 = $ce; - M_SOF15 = $cf; - - M_DHT = $c4; - - M_DAC = $cc; - - M_RST0 = $d0; - M_RST1 = $d1; - M_RST2 = $d2; - M_RST3 = $d3; - M_RST4 = $d4; - M_RST5 = $d5; - M_RST6 = $d6; - M_RST7 = $d7; - - M_SOI = $d8; - M_EOI = $d9; - M_SOS = $da; - M_DQT = $db; - M_DNL = $dc; - M_DRI = $dd; - M_DHP = $de; - M_EXP = $df; - - M_APP0 = $e0; - M_APP1 = $e1; - M_APP2 = $e2; - M_APP3 = $e3; - M_APP4 = $e4; - M_APP5 = $e5; - M_APP6 = $e6; - M_APP7 = $e7; - M_APP8 = $e8; - M_APP9 = $e9; - M_APP10 = $ea; - M_APP11 = $eb; - M_APP12 = $ec; - M_APP13 = $ed; - M_APP14 = $ee; - M_APP15 = $ef; - - M_JPG0 = $f0; - M_JPG13 = $fd; - M_COM = $fe; - - M_TEM = $01; - - M_ERROR = $100; - -type - JPEG_MARKER = Word; - -{ Private state } - -type - my_marker_ptr = ^my_marker_writer; - my_marker_writer = record - pub : jpeg_marker_writer; { public fields } - - last_restart_interval : uint; { last DRI value emitted; 0 after SOI } - end; - - - - -{GLOBAL} -procedure jinit_marker_writer (cinfo : j_compress_ptr); - -implementation - -{ Basic output routines. - - Note that we do not support suspension while writing a marker. - Therefore, an application using suspension must ensure that there is - enough buffer space for the initial markers (typ. 600-700 bytes) before - calling jpeg_start_compress, and enough space to write the trailing EOI - (a few bytes) before calling jpeg_finish_compress. Multipass compression - modes are not supported at all with suspension, so those two are the only - points where markers will be written. } - - -{LOCAL} -procedure emit_byte (cinfo : j_compress_ptr; val : int); -{ Emit a byte } -var - dest : jpeg_destination_mgr_ptr; -begin - dest := cinfo^.dest; - - dest^.next_output_byte^ := JOCTET(val); - Inc(dest^.next_output_byte); - - Dec(dest^.free_in_buffer); - if (dest^.free_in_buffer = 0) then - begin - if not dest^.empty_output_buffer(cinfo) then - ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND); - end; -end; - - -{LOCAL} -procedure emit_marker(cinfo : j_compress_ptr; mark : JPEG_MARKER); -{ Emit a marker code } -begin - emit_byte(cinfo, $FF); - emit_byte(cinfo, int(mark)); -end; - - -{LOCAL} -procedure emit_2bytes (cinfo : j_compress_ptr; value : int); -{ Emit a 2-byte integer; these are always MSB first in JPEG files } -begin - emit_byte(cinfo, (value shr 8) and $FF); - emit_byte(cinfo, value and $FF); -end; - - -{ Routines to write specific marker types. } - -{LOCAL} -function emit_dqt (cinfo : j_compress_ptr; index : int) : int; -{ Emit a DQT marker } -{ Returns the precision used (0 = 8bits, 1 = 16bits) for baseline checking } -var - qtbl : JQUANT_TBL_PTR; - prec : int; - i : int; -var - qval : uint; -begin - qtbl := cinfo^.quant_tbl_ptrs[index]; - if (qtbl = NIL) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, index); - - prec := 0; - for i := 0 to Pred(DCTSIZE2) do - begin - if (qtbl^.quantval[i] > 255) then - prec := 1; - end; - - if not qtbl^.sent_table then - begin - emit_marker(cinfo, M_DQT); - - if (prec <> 0) then - emit_2bytes(cinfo, DCTSIZE2*2 + 1 + 2) - else - emit_2bytes(cinfo, DCTSIZE2 + 1 + 2); - - emit_byte(cinfo, index + (prec shl 4)); - - for i := 0 to Pred(DCTSIZE2) do - begin - { The table entries must be emitted in zigzag order. } - qval := qtbl^.quantval[jpeg_natural_order[i]]; - if (prec <> 0) then - emit_byte(cinfo, int(qval shr 8)); - emit_byte(cinfo, int(qval and $FF)); - end; - - qtbl^.sent_table := TRUE; - end; - - emit_dqt := prec; -end; - - -{LOCAL} -procedure emit_dht (cinfo : j_compress_ptr; index : int; is_ac : boolean); -{ Emit a DHT marker } -var - htbl : JHUFF_TBL_PTR; - length, i : int; -begin - if (is_ac) then - begin - htbl := cinfo^.ac_huff_tbl_ptrs[index]; - index := index + $10; { output index has AC bit set } - end - else - begin - htbl := cinfo^.dc_huff_tbl_ptrs[index]; - end; - - if (htbl = NIL) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, index); - - if not htbl^.sent_table then - begin - emit_marker(cinfo, M_DHT); - - length := 0; - for i := 1 to 16 do - length := length + htbl^.bits[i]; - - emit_2bytes(cinfo, length + 2 + 1 + 16); - emit_byte(cinfo, index); - - for i := 1 to 16 do - emit_byte(cinfo, htbl^.bits[i]); - - for i := 0 to Pred(length) do - emit_byte(cinfo, htbl^.huffval[i]); - - htbl^.sent_table := TRUE; - end; -end; - - -{LOCAL} -procedure emit_dac (cinfo : j_compress_ptr); -{ Emit a DAC marker } -{ Since the useful info is so small, we want to emit all the tables in } -{ one DAC marker. Therefore this routine does its own scan of the table. } -{$ifdef C_ARITH_CODING_SUPPORTED} -var - dc_in_use : array[0..NUM_ARITH_TBLS] of byte; - ac_in_use : array[0..NUM_ARITH_TBLS] of byte; - length, i : int; - compptr : jpeg_component_info_ptr; -begin - for i := 0 to pred(NUM_ARITH_TBLS) do - begin - dc_in_use[i] := 0; - ac_in_use[i] := 0; - end; - - for i := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[i]; - dc_in_use[compptr^.dc_tbl_no] := 1; - ac_in_use[compptr^.ac_tbl_no] := 1; - end; - - length := 0; - for i := 0 to pred(NUM_ARITH_TBLS) do - Inc(length, dc_in_use[i] + ac_in_use[i]); - - emit_marker(cinfo, M_DAC); - - emit_2bytes(cinfo, length*2 + 2); - - for i := 0 to pred(NUM_ARITH_TBLS) do - begin - if (dc_in_use[i] <> 0) then - begin - emit_byte(cinfo, i); - emit_byte(cinfo, cinfo^.arith_dc_L[i] + (cinfo^.arith_dc_U[i] shl 4)); - end; - if (ac_in_use[i] <> 0) then - begin - emit_byte(cinfo, i + $10); - emit_byte(cinfo, cinfo^.arith_ac_K[i]); - end; - end; -end; -{$else} -begin -end; -{$endif} {C_ARITH_CODING_SUPPORTED} - - -{LOCAL} -procedure emit_dri (cinfo : j_compress_ptr); -{ Emit a DRI marker } -begin - emit_marker(cinfo, M_DRI); - - emit_2bytes(cinfo, 4); { fixed length } - - emit_2bytes(cinfo, int(cinfo^.restart_interval)); -end; - - -{LOCAL} -procedure emit_sof (cinfo : j_compress_ptr; code : JPEG_MARKER); -{ Emit a SOF marker } -var - ci : int; - compptr : jpeg_component_info_ptr; -begin - emit_marker(cinfo, code); - - emit_2bytes(cinfo, 3 * cinfo^.num_components + 2 + 5 + 1); { length } - - { Make sure image isn't bigger than SOF field can handle } - if (long(cinfo^.image_height) > long(65535)) or - (long(cinfo^.image_width) > long(65535)) then - ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(65535)); - - emit_byte(cinfo, cinfo^.data_precision); - emit_2bytes(cinfo, int(cinfo^.image_height)); - emit_2bytes(cinfo, int(cinfo^.image_width)); - - emit_byte(cinfo, cinfo^.num_components); - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to Pred(cinfo^.num_components) do - begin - emit_byte(cinfo, compptr^.component_id); - emit_byte(cinfo, (compptr^.h_samp_factor shl 4) + compptr^.v_samp_factor); - emit_byte(cinfo, compptr^.quant_tbl_no); - Inc(compptr); - end; -end; - - -{LOCAL} -procedure emit_sos (cinfo : j_compress_ptr); -{ Emit a SOS marker } -var - i, td, ta : int; - compptr : jpeg_component_info_ptr; -begin - emit_marker(cinfo, M_SOS); - - emit_2bytes(cinfo, 2 * cinfo^.comps_in_scan + 2 + 1 + 3); { length } - - emit_byte(cinfo, cinfo^.comps_in_scan); - - for i := 0 to Pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[i]; - emit_byte(cinfo, compptr^.component_id); - td := compptr^.dc_tbl_no; - ta := compptr^.ac_tbl_no; - if (cinfo^.progressive_mode) then - begin - { Progressive mode: only DC or only AC tables are used in one scan; - furthermore, Huffman coding of DC refinement uses no table at all. - We emit 0 for unused field(s); this is recommended by the P&M text - but does not seem to be specified in the standard. } - - if (cinfo^.Ss = 0) then - begin - ta := 0; { DC scan } - if (cinfo^.Ah <> 0) and not cinfo^.arith_code then - td := 0; { no DC table either } - end - else - begin - td := 0; { AC scan } - end; - end; - emit_byte(cinfo, (td shl 4) + ta); - end; - - emit_byte(cinfo, cinfo^.Ss); - emit_byte(cinfo, cinfo^.Se); - emit_byte(cinfo, (cinfo^.Ah shl 4) + cinfo^.Al); -end; - - -{LOCAL} -procedure emit_jfif_app0 (cinfo : j_compress_ptr); -{ Emit a JFIF-compliant APP0 marker } -{ - Length of APP0 block (2 bytes) - Block ID (4 bytes - ASCII "JFIF") - Zero byte (1 byte to terminate the ID string) - Version Major, Minor (2 bytes - major first) - Units (1 byte - $00 = none, $01 = inch, $02 = cm) - Xdpu (2 bytes - dots per unit horizontal) - Ydpu (2 bytes - dots per unit vertical) - Thumbnail X size (1 byte) - Thumbnail Y size (1 byte) -} -begin - emit_marker(cinfo, M_APP0); - - emit_2bytes(cinfo, 2 + 4 + 1 + 2 + 1 + 2 + 2 + 1 + 1); { length } - - emit_byte(cinfo, $4A); { Identifier: ASCII "JFIF" } - emit_byte(cinfo, $46); - emit_byte(cinfo, $49); - emit_byte(cinfo, $46); - emit_byte(cinfo, 0); - emit_byte(cinfo, cinfo^.JFIF_major_version); { Version fields } - emit_byte(cinfo, cinfo^.JFIF_minor_version); - emit_byte(cinfo, cinfo^.density_unit); { Pixel size information } - emit_2bytes(cinfo, int(cinfo^.X_density)); - emit_2bytes(cinfo, int(cinfo^.Y_density)); - emit_byte(cinfo, 0); { No thumbnail image } - emit_byte(cinfo, 0); -end; - - -{LOCAL} -procedure emit_adobe_app14 (cinfo : j_compress_ptr); -{ Emit an Adobe APP14 marker } -{ - Length of APP14 block (2 bytes) - Block ID (5 bytes - ASCII "Adobe") - Version Number (2 bytes - currently 100) - Flags0 (2 bytes - currently 0) - Flags1 (2 bytes - currently 0) - Color transform (1 byte) - - Although Adobe TN 5116 mentions Version = 101, all the Adobe files - now in circulation seem to use Version = 100, so that's what we write. - - We write the color transform byte as 1 if the JPEG color space is - YCbCr, 2 if it's YCCK, 0 otherwise. Adobe's definition has to do with - whether the encoder performed a transformation, which is pretty useless. -} -begin - emit_marker(cinfo, M_APP14); - - emit_2bytes(cinfo, 2 + 5 + 2 + 2 + 2 + 1); { length } - - emit_byte(cinfo, $41); { Identifier: ASCII "Adobe" } - emit_byte(cinfo, $64); - emit_byte(cinfo, $6F); - emit_byte(cinfo, $62); - emit_byte(cinfo, $65); - emit_2bytes(cinfo, 100); { Version } - emit_2bytes(cinfo, 0); { Flags0 } - emit_2bytes(cinfo, 0); { Flags1 } - case (cinfo^.jpeg_color_space) of - JCS_YCbCr: - emit_byte(cinfo, 1); { Color transform = 1 } - JCS_YCCK: - emit_byte(cinfo, 2); { Color transform = 2 } - else - emit_byte(cinfo, 0); { Color transform = 0 } - end; -end; - - -{ These routines allow writing an arbitrary marker with parameters. - The only intended use is to emit COM or APPn markers after calling - write_file_header and before calling write_frame_header. - Other uses are not guaranteed to produce desirable results. - Counting the parameter bytes properly is the caller's responsibility. } - -{METHODDEF} -procedure write_marker_header (cinfo : j_compress_ptr; - marker : int; - datalen : uint); -{ Emit an arbitrary marker header } -begin - if (datalen > uint(65533)) then { safety check } - ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); - - emit_marker(cinfo, JPEG_MARKER(marker)); - - emit_2bytes(cinfo, int(datalen + 2)); { total length } -end; - -{METHODDEF} -procedure write_marker_byte (cinfo : j_compress_ptr; val : int); -{ Emit one byte of marker parameters following write_marker_header } -begin - emit_byte(cinfo, val); -end; - -{ Write datastream header. - This consists of an SOI and optional APPn markers. - We recommend use of the JFIF marker, but not the Adobe marker, - when using YCbCr or grayscale data. The JFIF marker should NOT - be used for any other JPEG colorspace. The Adobe marker is helpful - to distinguish RGB, CMYK, and YCCK colorspaces. - Note that an application can write additional header markers after - jpeg_start_compress returns. } - - -{METHODDEF} -procedure write_file_header (cinfo : j_compress_ptr); -var - marker : my_marker_ptr; -begin - marker := my_marker_ptr(cinfo^.marker); - - emit_marker(cinfo, M_SOI); { first the SOI } - - { SOI is defined to reset restart interval to 0 } - marker^.last_restart_interval := 0; - - if (cinfo^.write_JFIF_header) then { next an optional JFIF APP0 } - emit_jfif_app0(cinfo); - if (cinfo^.write_Adobe_marker) then { next an optional Adobe APP14 } - emit_adobe_app14(cinfo); -end; - - -{ Write frame header. - This consists of DQT and SOFn markers. - Note that we do not emit the SOF until we have emitted the DQT(s). - This avoids compatibility problems with incorrect implementations that - try to error-check the quant table numbers as soon as they see the SOF. } - - -{METHODDEF} -procedure write_frame_header (cinfo : j_compress_ptr); -var - ci, prec : int; - is_baseline : boolean; - compptr : jpeg_component_info_ptr; -begin - { Emit DQT for each quantization table. - Note that emit_dqt() suppresses any duplicate tables. } - - prec := 0; - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to Pred(cinfo^.num_components) do - begin - prec := prec + emit_dqt(cinfo, compptr^.quant_tbl_no); - Inc(compptr); - end; - { now prec is nonzero iff there are any 16-bit quant tables. } - - { Check for a non-baseline specification. - Note we assume that Huffman table numbers won't be changed later. } - - if (cinfo^.arith_code) or (cinfo^.progressive_mode) - or (cinfo^.data_precision <> 8) then - begin - is_baseline := FALSE; - end - else - begin - is_baseline := TRUE; - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to Pred(cinfo^.num_components) do - begin - if (compptr^.dc_tbl_no > 1) or (compptr^.ac_tbl_no > 1) then - is_baseline := FALSE; - Inc(compptr); - end; - if (prec <> 0) and (is_baseline) then - begin - is_baseline := FALSE; - { If it's baseline except for quantizer size, warn the user } - {$IFDEF DEBUG} - TRACEMS(j_common_ptr(cinfo), 0, JTRC_16BIT_TABLES); - {$ENDIF} - end; - end; - - { Emit the proper SOF marker } - if (cinfo^.arith_code) then - begin - emit_sof(cinfo, M_SOF9); { SOF code for arithmetic coding } - end - else - begin - if (cinfo^.progressive_mode) then - emit_sof(cinfo, M_SOF2) { SOF code for progressive Huffman } - else if (is_baseline) then - emit_sof(cinfo, M_SOF0) { SOF code for baseline implementation } - else - emit_sof(cinfo, M_SOF1); { SOF code for non-baseline Huffman file } - end; -end; - - -{ Write scan header. - This consists of DHT or DAC markers, optional DRI, and SOS. - Compressed data will be written following the SOS. } - -{METHODDEF} -procedure write_scan_header (cinfo : j_compress_ptr); -var - marker : my_marker_ptr; - i : int; - compptr : jpeg_component_info_ptr; -begin - marker := my_marker_ptr(cinfo^.marker); - if (cinfo^.arith_code) then - begin - { Emit arith conditioning info. We may have some duplication - if the file has multiple scans, but it's so small it's hardly - worth worrying about. } - emit_dac(cinfo); - end - else - begin - { Emit Huffman tables. - Note that emit_dht() suppresses any duplicate tables. } - for i := 0 to Pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[i]; - if (cinfo^.progressive_mode) then - begin - { Progressive mode: only DC or only AC tables are used in one scan } - if (cinfo^.Ss = 0) then - begin - if (cinfo^.Ah = 0) then { DC needs no table for refinement scan } - emit_dht(cinfo, compptr^.dc_tbl_no, FALSE); - end - else - begin - emit_dht(cinfo, compptr^.ac_tbl_no, TRUE); - end; - end - else - begin - { Sequential mode: need both DC and AC tables } - emit_dht(cinfo, compptr^.dc_tbl_no, FALSE); - emit_dht(cinfo, compptr^.ac_tbl_no, TRUE); - end; - end; - end; - - { Emit DRI if required --- note that DRI value could change for each scan. - We avoid wasting space with unnecessary DRIs, however. } - - if (cinfo^.restart_interval <> marker^.last_restart_interval) then - begin - emit_dri(cinfo); - marker^.last_restart_interval := cinfo^.restart_interval; - end; - - emit_sos(cinfo); -end; - - - -{ Write datastream trailer. } - - -{METHODDEF} -procedure write_file_trailer (cinfo : j_compress_ptr); -begin - emit_marker(cinfo, M_EOI); -end; - - -{ Write an abbreviated table-specification datastream. - This consists of SOI, DQT and DHT tables, and EOI. - Any table that is defined and not marked sent_table = TRUE will be - emitted. Note that all tables will be marked sent_table = TRUE at exit. } - - -{METHODDEF} -procedure write_tables_only (cinfo : j_compress_ptr); -var - i : int; -begin - emit_marker(cinfo, M_SOI); - - for i := 0 to Pred(NUM_QUANT_TBLS) do - begin - if (cinfo^.quant_tbl_ptrs[i] <> NIL) then - emit_dqt(cinfo, i); { dummy := ... } - end; - - if (not cinfo^.arith_code) then - begin - for i := 0 to Pred(NUM_HUFF_TBLS) do - begin - if (cinfo^.dc_huff_tbl_ptrs[i] <> NIL) then - emit_dht(cinfo, i, FALSE); - if (cinfo^.ac_huff_tbl_ptrs[i] <> NIL) then - emit_dht(cinfo, i, TRUE); - end; - end; - - emit_marker(cinfo, M_EOI); -end; - - -{ Initialize the marker writer module. } - -{GLOBAL} -procedure jinit_marker_writer (cinfo : j_compress_ptr); -var - marker : my_marker_ptr; -begin - { Create the subobject } - marker := my_marker_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_marker_writer)) ); - cinfo^.marker := jpeg_marker_writer_ptr(marker); - { Initialize method pointers } - marker^.pub.write_file_header := write_file_header; - marker^.pub.write_frame_header := write_frame_header; - marker^.pub.write_scan_header := write_scan_header; - marker^.pub.write_file_trailer := write_file_trailer; - marker^.pub.write_tables_only := write_tables_only; - marker^.pub.write_marker_header := write_marker_header; - marker^.pub.write_marker_byte := write_marker_byte; - { Initialize private state } - marker^.last_restart_interval := 0; -end; - - -end. +unit imjcmarker; + +{ This file contains routines to write JPEG datastream markers. } + +{ Original: jcmarker.c; Copyright (C) 1991-1998, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjinclude, imjmorecfg, imjerror, + imjdeferr, imjpeglib, imjutils; + + +const + { JPEG marker codes } + M_SOF0 = $c0; + M_SOF1 = $c1; + M_SOF2 = $c2; + M_SOF3 = $c3; + + M_SOF5 = $c5; + M_SOF6 = $c6; + M_SOF7 = $c7; + + M_JPG = $c8; + M_SOF9 = $c9; + M_SOF10 = $ca; + M_SOF11 = $cb; + + M_SOF13 = $cd; + M_SOF14 = $ce; + M_SOF15 = $cf; + + M_DHT = $c4; + + M_DAC = $cc; + + M_RST0 = $d0; + M_RST1 = $d1; + M_RST2 = $d2; + M_RST3 = $d3; + M_RST4 = $d4; + M_RST5 = $d5; + M_RST6 = $d6; + M_RST7 = $d7; + + M_SOI = $d8; + M_EOI = $d9; + M_SOS = $da; + M_DQT = $db; + M_DNL = $dc; + M_DRI = $dd; + M_DHP = $de; + M_EXP = $df; + + M_APP0 = $e0; + M_APP1 = $e1; + M_APP2 = $e2; + M_APP3 = $e3; + M_APP4 = $e4; + M_APP5 = $e5; + M_APP6 = $e6; + M_APP7 = $e7; + M_APP8 = $e8; + M_APP9 = $e9; + M_APP10 = $ea; + M_APP11 = $eb; + M_APP12 = $ec; + M_APP13 = $ed; + M_APP14 = $ee; + M_APP15 = $ef; + + M_JPG0 = $f0; + M_JPG13 = $fd; + M_COM = $fe; + + M_TEM = $01; + + M_ERROR = $100; + +type + JPEG_MARKER = Word; + +{ Private state } + +type + my_marker_ptr = ^my_marker_writer; + my_marker_writer = record + pub : jpeg_marker_writer; { public fields } + + last_restart_interval : uint; { last DRI value emitted; 0 after SOI } + end; + + + + +{GLOBAL} +procedure jinit_marker_writer (cinfo : j_compress_ptr); + +implementation + +{ Basic output routines. + + Note that we do not support suspension while writing a marker. + Therefore, an application using suspension must ensure that there is + enough buffer space for the initial markers (typ. 600-700 bytes) before + calling jpeg_start_compress, and enough space to write the trailing EOI + (a few bytes) before calling jpeg_finish_compress. Multipass compression + modes are not supported at all with suspension, so those two are the only + points where markers will be written. } + + +{LOCAL} +procedure emit_byte (cinfo : j_compress_ptr; val : int); +{ Emit a byte } +var + dest : jpeg_destination_mgr_ptr; +begin + dest := cinfo^.dest; + + dest^.next_output_byte^ := JOCTET(val); + Inc(dest^.next_output_byte); + + Dec(dest^.free_in_buffer); + if (dest^.free_in_buffer = 0) then + begin + if not dest^.empty_output_buffer(cinfo) then + ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND); + end; +end; + + +{LOCAL} +procedure emit_marker(cinfo : j_compress_ptr; mark : JPEG_MARKER); +{ Emit a marker code } +begin + emit_byte(cinfo, $FF); + emit_byte(cinfo, int(mark)); +end; + + +{LOCAL} +procedure emit_2bytes (cinfo : j_compress_ptr; value : int); +{ Emit a 2-byte integer; these are always MSB first in JPEG files } +begin + emit_byte(cinfo, (value shr 8) and $FF); + emit_byte(cinfo, value and $FF); +end; + + +{ Routines to write specific marker types. } + +{LOCAL} +function emit_dqt (cinfo : j_compress_ptr; index : int) : int; +{ Emit a DQT marker } +{ Returns the precision used (0 = 8bits, 1 = 16bits) for baseline checking } +var + qtbl : JQUANT_TBL_PTR; + prec : int; + i : int; +var + qval : uint; +begin + qtbl := cinfo^.quant_tbl_ptrs[index]; + if (qtbl = NIL) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, index); + + prec := 0; + for i := 0 to Pred(DCTSIZE2) do + begin + if (qtbl^.quantval[i] > 255) then + prec := 1; + end; + + if not qtbl^.sent_table then + begin + emit_marker(cinfo, M_DQT); + + if (prec <> 0) then + emit_2bytes(cinfo, DCTSIZE2*2 + 1 + 2) + else + emit_2bytes(cinfo, DCTSIZE2 + 1 + 2); + + emit_byte(cinfo, index + (prec shl 4)); + + for i := 0 to Pred(DCTSIZE2) do + begin + { The table entries must be emitted in zigzag order. } + qval := qtbl^.quantval[jpeg_natural_order[i]]; + if (prec <> 0) then + emit_byte(cinfo, int(qval shr 8)); + emit_byte(cinfo, int(qval and $FF)); + end; + + qtbl^.sent_table := TRUE; + end; + + emit_dqt := prec; +end; + + +{LOCAL} +procedure emit_dht (cinfo : j_compress_ptr; index : int; is_ac : boolean); +{ Emit a DHT marker } +var + htbl : JHUFF_TBL_PTR; + length, i : int; +begin + if (is_ac) then + begin + htbl := cinfo^.ac_huff_tbl_ptrs[index]; + index := index + $10; { output index has AC bit set } + end + else + begin + htbl := cinfo^.dc_huff_tbl_ptrs[index]; + end; + + if (htbl = NIL) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, index); + + if not htbl^.sent_table then + begin + emit_marker(cinfo, M_DHT); + + length := 0; + for i := 1 to 16 do + length := length + htbl^.bits[i]; + + emit_2bytes(cinfo, length + 2 + 1 + 16); + emit_byte(cinfo, index); + + for i := 1 to 16 do + emit_byte(cinfo, htbl^.bits[i]); + + for i := 0 to Pred(length) do + emit_byte(cinfo, htbl^.huffval[i]); + + htbl^.sent_table := TRUE; + end; +end; + + +{LOCAL} +procedure emit_dac (cinfo : j_compress_ptr); +{ Emit a DAC marker } +{ Since the useful info is so small, we want to emit all the tables in } +{ one DAC marker. Therefore this routine does its own scan of the table. } +{$ifdef C_ARITH_CODING_SUPPORTED} +var + dc_in_use : array[0..NUM_ARITH_TBLS] of byte; + ac_in_use : array[0..NUM_ARITH_TBLS] of byte; + length, i : int; + compptr : jpeg_component_info_ptr; +begin + for i := 0 to pred(NUM_ARITH_TBLS) do + begin + dc_in_use[i] := 0; + ac_in_use[i] := 0; + end; + + for i := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[i]; + dc_in_use[compptr^.dc_tbl_no] := 1; + ac_in_use[compptr^.ac_tbl_no] := 1; + end; + + length := 0; + for i := 0 to pred(NUM_ARITH_TBLS) do + Inc(length, dc_in_use[i] + ac_in_use[i]); + + emit_marker(cinfo, M_DAC); + + emit_2bytes(cinfo, length*2 + 2); + + for i := 0 to pred(NUM_ARITH_TBLS) do + begin + if (dc_in_use[i] <> 0) then + begin + emit_byte(cinfo, i); + emit_byte(cinfo, cinfo^.arith_dc_L[i] + (cinfo^.arith_dc_U[i] shl 4)); + end; + if (ac_in_use[i] <> 0) then + begin + emit_byte(cinfo, i + $10); + emit_byte(cinfo, cinfo^.arith_ac_K[i]); + end; + end; +end; +{$else} +begin +end; +{$endif} {C_ARITH_CODING_SUPPORTED} + + +{LOCAL} +procedure emit_dri (cinfo : j_compress_ptr); +{ Emit a DRI marker } +begin + emit_marker(cinfo, M_DRI); + + emit_2bytes(cinfo, 4); { fixed length } + + emit_2bytes(cinfo, int(cinfo^.restart_interval)); +end; + + +{LOCAL} +procedure emit_sof (cinfo : j_compress_ptr; code : JPEG_MARKER); +{ Emit a SOF marker } +var + ci : int; + compptr : jpeg_component_info_ptr; +begin + emit_marker(cinfo, code); + + emit_2bytes(cinfo, 3 * cinfo^.num_components + 2 + 5 + 1); { length } + + { Make sure image isn't bigger than SOF field can handle } + if (long(cinfo^.image_height) > long(65535)) or + (long(cinfo^.image_width) > long(65535)) then + ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(65535)); + + emit_byte(cinfo, cinfo^.data_precision); + emit_2bytes(cinfo, int(cinfo^.image_height)); + emit_2bytes(cinfo, int(cinfo^.image_width)); + + emit_byte(cinfo, cinfo^.num_components); + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to Pred(cinfo^.num_components) do + begin + emit_byte(cinfo, compptr^.component_id); + emit_byte(cinfo, (compptr^.h_samp_factor shl 4) + compptr^.v_samp_factor); + emit_byte(cinfo, compptr^.quant_tbl_no); + Inc(compptr); + end; +end; + + +{LOCAL} +procedure emit_sos (cinfo : j_compress_ptr); +{ Emit a SOS marker } +var + i, td, ta : int; + compptr : jpeg_component_info_ptr; +begin + emit_marker(cinfo, M_SOS); + + emit_2bytes(cinfo, 2 * cinfo^.comps_in_scan + 2 + 1 + 3); { length } + + emit_byte(cinfo, cinfo^.comps_in_scan); + + for i := 0 to Pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[i]; + emit_byte(cinfo, compptr^.component_id); + td := compptr^.dc_tbl_no; + ta := compptr^.ac_tbl_no; + if (cinfo^.progressive_mode) then + begin + { Progressive mode: only DC or only AC tables are used in one scan; + furthermore, Huffman coding of DC refinement uses no table at all. + We emit 0 for unused field(s); this is recommended by the P&M text + but does not seem to be specified in the standard. } + + if (cinfo^.Ss = 0) then + begin + ta := 0; { DC scan } + if (cinfo^.Ah <> 0) and not cinfo^.arith_code then + td := 0; { no DC table either } + end + else + begin + td := 0; { AC scan } + end; + end; + emit_byte(cinfo, (td shl 4) + ta); + end; + + emit_byte(cinfo, cinfo^.Ss); + emit_byte(cinfo, cinfo^.Se); + emit_byte(cinfo, (cinfo^.Ah shl 4) + cinfo^.Al); +end; + + +{LOCAL} +procedure emit_jfif_app0 (cinfo : j_compress_ptr); +{ Emit a JFIF-compliant APP0 marker } +{ + Length of APP0 block (2 bytes) + Block ID (4 bytes - ASCII "JFIF") + Zero byte (1 byte to terminate the ID string) + Version Major, Minor (2 bytes - major first) + Units (1 byte - $00 = none, $01 = inch, $02 = cm) + Xdpu (2 bytes - dots per unit horizontal) + Ydpu (2 bytes - dots per unit vertical) + Thumbnail X size (1 byte) + Thumbnail Y size (1 byte) +} +begin + emit_marker(cinfo, M_APP0); + + emit_2bytes(cinfo, 2 + 4 + 1 + 2 + 1 + 2 + 2 + 1 + 1); { length } + + emit_byte(cinfo, $4A); { Identifier: ASCII "JFIF" } + emit_byte(cinfo, $46); + emit_byte(cinfo, $49); + emit_byte(cinfo, $46); + emit_byte(cinfo, 0); + emit_byte(cinfo, cinfo^.JFIF_major_version); { Version fields } + emit_byte(cinfo, cinfo^.JFIF_minor_version); + emit_byte(cinfo, cinfo^.density_unit); { Pixel size information } + emit_2bytes(cinfo, int(cinfo^.X_density)); + emit_2bytes(cinfo, int(cinfo^.Y_density)); + emit_byte(cinfo, 0); { No thumbnail image } + emit_byte(cinfo, 0); +end; + + +{LOCAL} +procedure emit_adobe_app14 (cinfo : j_compress_ptr); +{ Emit an Adobe APP14 marker } +{ + Length of APP14 block (2 bytes) + Block ID (5 bytes - ASCII "Adobe") + Version Number (2 bytes - currently 100) + Flags0 (2 bytes - currently 0) + Flags1 (2 bytes - currently 0) + Color transform (1 byte) + + Although Adobe TN 5116 mentions Version = 101, all the Adobe files + now in circulation seem to use Version = 100, so that's what we write. + + We write the color transform byte as 1 if the JPEG color space is + YCbCr, 2 if it's YCCK, 0 otherwise. Adobe's definition has to do with + whether the encoder performed a transformation, which is pretty useless. +} +begin + emit_marker(cinfo, M_APP14); + + emit_2bytes(cinfo, 2 + 5 + 2 + 2 + 2 + 1); { length } + + emit_byte(cinfo, $41); { Identifier: ASCII "Adobe" } + emit_byte(cinfo, $64); + emit_byte(cinfo, $6F); + emit_byte(cinfo, $62); + emit_byte(cinfo, $65); + emit_2bytes(cinfo, 100); { Version } + emit_2bytes(cinfo, 0); { Flags0 } + emit_2bytes(cinfo, 0); { Flags1 } + case (cinfo^.jpeg_color_space) of + JCS_YCbCr: + emit_byte(cinfo, 1); { Color transform = 1 } + JCS_YCCK: + emit_byte(cinfo, 2); { Color transform = 2 } + else + emit_byte(cinfo, 0); { Color transform = 0 } + end; +end; + + +{ These routines allow writing an arbitrary marker with parameters. + The only intended use is to emit COM or APPn markers after calling + write_file_header and before calling write_frame_header. + Other uses are not guaranteed to produce desirable results. + Counting the parameter bytes properly is the caller's responsibility. } + +{METHODDEF} +procedure write_marker_header (cinfo : j_compress_ptr; + marker : int; + datalen : uint); +{ Emit an arbitrary marker header } +begin + if (datalen > uint(65533)) then { safety check } + ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); + + emit_marker(cinfo, JPEG_MARKER(marker)); + + emit_2bytes(cinfo, int(datalen + 2)); { total length } +end; + +{METHODDEF} +procedure write_marker_byte (cinfo : j_compress_ptr; val : int); +{ Emit one byte of marker parameters following write_marker_header } +begin + emit_byte(cinfo, val); +end; + +{ Write datastream header. + This consists of an SOI and optional APPn markers. + We recommend use of the JFIF marker, but not the Adobe marker, + when using YCbCr or grayscale data. The JFIF marker should NOT + be used for any other JPEG colorspace. The Adobe marker is helpful + to distinguish RGB, CMYK, and YCCK colorspaces. + Note that an application can write additional header markers after + jpeg_start_compress returns. } + + +{METHODDEF} +procedure write_file_header (cinfo : j_compress_ptr); +var + marker : my_marker_ptr; +begin + marker := my_marker_ptr(cinfo^.marker); + + emit_marker(cinfo, M_SOI); { first the SOI } + + { SOI is defined to reset restart interval to 0 } + marker^.last_restart_interval := 0; + + if (cinfo^.write_JFIF_header) then { next an optional JFIF APP0 } + emit_jfif_app0(cinfo); + if (cinfo^.write_Adobe_marker) then { next an optional Adobe APP14 } + emit_adobe_app14(cinfo); +end; + + +{ Write frame header. + This consists of DQT and SOFn markers. + Note that we do not emit the SOF until we have emitted the DQT(s). + This avoids compatibility problems with incorrect implementations that + try to error-check the quant table numbers as soon as they see the SOF. } + + +{METHODDEF} +procedure write_frame_header (cinfo : j_compress_ptr); +var + ci, prec : int; + is_baseline : boolean; + compptr : jpeg_component_info_ptr; +begin + { Emit DQT for each quantization table. + Note that emit_dqt() suppresses any duplicate tables. } + + prec := 0; + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to Pred(cinfo^.num_components) do + begin + prec := prec + emit_dqt(cinfo, compptr^.quant_tbl_no); + Inc(compptr); + end; + { now prec is nonzero iff there are any 16-bit quant tables. } + + { Check for a non-baseline specification. + Note we assume that Huffman table numbers won't be changed later. } + + if (cinfo^.arith_code) or (cinfo^.progressive_mode) + or (cinfo^.data_precision <> 8) then + begin + is_baseline := FALSE; + end + else + begin + is_baseline := TRUE; + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to Pred(cinfo^.num_components) do + begin + if (compptr^.dc_tbl_no > 1) or (compptr^.ac_tbl_no > 1) then + is_baseline := FALSE; + Inc(compptr); + end; + if (prec <> 0) and (is_baseline) then + begin + is_baseline := FALSE; + { If it's baseline except for quantizer size, warn the user } + {$IFDEF DEBUG} + TRACEMS(j_common_ptr(cinfo), 0, JTRC_16BIT_TABLES); + {$ENDIF} + end; + end; + + { Emit the proper SOF marker } + if (cinfo^.arith_code) then + begin + emit_sof(cinfo, M_SOF9); { SOF code for arithmetic coding } + end + else + begin + if (cinfo^.progressive_mode) then + emit_sof(cinfo, M_SOF2) { SOF code for progressive Huffman } + else if (is_baseline) then + emit_sof(cinfo, M_SOF0) { SOF code for baseline implementation } + else + emit_sof(cinfo, M_SOF1); { SOF code for non-baseline Huffman file } + end; +end; + + +{ Write scan header. + This consists of DHT or DAC markers, optional DRI, and SOS. + Compressed data will be written following the SOS. } + +{METHODDEF} +procedure write_scan_header (cinfo : j_compress_ptr); +var + marker : my_marker_ptr; + i : int; + compptr : jpeg_component_info_ptr; +begin + marker := my_marker_ptr(cinfo^.marker); + if (cinfo^.arith_code) then + begin + { Emit arith conditioning info. We may have some duplication + if the file has multiple scans, but it's so small it's hardly + worth worrying about. } + emit_dac(cinfo); + end + else + begin + { Emit Huffman tables. + Note that emit_dht() suppresses any duplicate tables. } + for i := 0 to Pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[i]; + if (cinfo^.progressive_mode) then + begin + { Progressive mode: only DC or only AC tables are used in one scan } + if (cinfo^.Ss = 0) then + begin + if (cinfo^.Ah = 0) then { DC needs no table for refinement scan } + emit_dht(cinfo, compptr^.dc_tbl_no, FALSE); + end + else + begin + emit_dht(cinfo, compptr^.ac_tbl_no, TRUE); + end; + end + else + begin + { Sequential mode: need both DC and AC tables } + emit_dht(cinfo, compptr^.dc_tbl_no, FALSE); + emit_dht(cinfo, compptr^.ac_tbl_no, TRUE); + end; + end; + end; + + { Emit DRI if required --- note that DRI value could change for each scan. + We avoid wasting space with unnecessary DRIs, however. } + + if (cinfo^.restart_interval <> marker^.last_restart_interval) then + begin + emit_dri(cinfo); + marker^.last_restart_interval := cinfo^.restart_interval; + end; + + emit_sos(cinfo); +end; + + + +{ Write datastream trailer. } + + +{METHODDEF} +procedure write_file_trailer (cinfo : j_compress_ptr); +begin + emit_marker(cinfo, M_EOI); +end; + + +{ Write an abbreviated table-specification datastream. + This consists of SOI, DQT and DHT tables, and EOI. + Any table that is defined and not marked sent_table = TRUE will be + emitted. Note that all tables will be marked sent_table = TRUE at exit. } + + +{METHODDEF} +procedure write_tables_only (cinfo : j_compress_ptr); +var + i : int; +begin + emit_marker(cinfo, M_SOI); + + for i := 0 to Pred(NUM_QUANT_TBLS) do + begin + if (cinfo^.quant_tbl_ptrs[i] <> NIL) then + emit_dqt(cinfo, i); { dummy := ... } + end; + + if (not cinfo^.arith_code) then + begin + for i := 0 to Pred(NUM_HUFF_TBLS) do + begin + if (cinfo^.dc_huff_tbl_ptrs[i] <> NIL) then + emit_dht(cinfo, i, FALSE); + if (cinfo^.ac_huff_tbl_ptrs[i] <> NIL) then + emit_dht(cinfo, i, TRUE); + end; + end; + + emit_marker(cinfo, M_EOI); +end; + + +{ Initialize the marker writer module. } + +{GLOBAL} +procedure jinit_marker_writer (cinfo : j_compress_ptr); +var + marker : my_marker_ptr; +begin + { Create the subobject } + marker := my_marker_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_marker_writer)) ); + cinfo^.marker := jpeg_marker_writer_ptr(marker); + { Initialize method pointers } + marker^.pub.write_file_header := write_file_header; + marker^.pub.write_frame_header := write_frame_header; + marker^.pub.write_scan_header := write_scan_header; + marker^.pub.write_file_trailer := write_file_trailer; + marker^.pub.write_tables_only := write_tables_only; + marker^.pub.write_marker_header := write_marker_header; + marker^.pub.write_marker_byte := write_marker_byte; + { Initialize private state } + marker^.last_restart_interval := 0; +end; + + +end. diff --git a/Imaging/JpegLib/imjcmaster.pas b/Imaging/JpegLib/imjcmaster.pas index 90faeb5..0a25a66 100644 --- a/Imaging/JpegLib/imjcmaster.pas +++ b/Imaging/JpegLib/imjcmaster.pas @@ -1,701 +1,701 @@ -unit imjcmaster; - -{ This file contains master control logic for the JPEG compressor. - These routines are concerned with parameter validation, initial setup, - and inter-pass control (determining the number of passes and the work - to be done in each pass). } - -{ Original: jcmaster.c ; Copyright (C) 1991-1997, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjutils, - imjpeglib; - -{ Initialize master compression control. } - -{GLOBAL} -procedure jinit_c_master_control (cinfo : j_compress_ptr; - transcode_only : boolean); - -implementation - -{ Private state } - -type - c_pass_type = ( - main_pass, { input data, also do first output step } - huff_opt_pass, { Huffman code optimization pass } - output_pass { data output pass } - ); - -type - my_master_ptr = ^my_comp_master; - my_comp_master = record - pub : jpeg_comp_master; { public fields } - - pass_type : c_pass_type; { the type of the current pass } - - pass_number : int; { # of passes completed } - total_passes : int; { total # of passes needed } - - scan_number : int; { current index in scan_info[] } - end; - - -{ Support routines that do various essential calculations. } - -{LOCAL} -procedure initial_setup (cinfo : j_compress_ptr); -{ Do computations that are needed before master selection phase } -var - ci : int; - compptr : jpeg_component_info_ptr; - samplesperrow : long; - jd_samplesperrow : JDIMENSION; -begin - - { Sanity check on image dimensions } - if (cinfo^.image_height <= 0) or (cinfo^.image_width <= 0) or - (cinfo^.num_components <= 0) or (cinfo^.input_components <= 0) then - ERREXIT(j_common_ptr(cinfo), JERR_EMPTY_IMAGE); - - { Make sure image isn't bigger than I can handle } - if ( long(cinfo^.image_height) > long(JPEG_MAX_DIMENSION)) or - ( long(cinfo^.image_width) > long(JPEG_MAX_DIMENSION)) then - ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, - uInt(JPEG_MAX_DIMENSION)); - - { Width of an input scanline must be representable as JDIMENSION. } - samplesperrow := long (cinfo^.image_width) * long (cinfo^.input_components); - jd_samplesperrow := JDIMENSION (samplesperrow); - if ( long(jd_samplesperrow) <> samplesperrow) then - ERREXIT(j_common_ptr(cinfo), JERR_WIDTH_OVERFLOW); - - { For now, precision must match compiled-in value... } - if (cinfo^.data_precision <> BITS_IN_JSAMPLE) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PRECISION, cinfo^.data_precision); - - { Check that number of components won't exceed internal array sizes } - if (cinfo^.num_components > MAX_COMPONENTS) then - ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components, - MAX_COMPONENTS); - - { Compute maximum sampling factors; check factor validity } - cinfo^.max_h_samp_factor := 1; - cinfo^.max_v_samp_factor := 1; - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - if (compptr^.h_samp_factor<=0) or (compptr^.h_samp_factor>MAX_SAMP_FACTOR) - or (compptr^.v_samp_factor<=0) or (compptr^.v_samp_factor>MAX_SAMP_FACTOR) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_SAMPLING); - { MAX } - if cinfo^.max_h_samp_factor > compptr^.h_samp_factor then - cinfo^.max_h_samp_factor := cinfo^.max_h_samp_factor - else - cinfo^.max_h_samp_factor := compptr^.h_samp_factor; - { MAX } - if cinfo^.max_v_samp_factor > compptr^.v_samp_factor then - cinfo^.max_v_samp_factor := cinfo^.max_v_samp_factor - else - cinfo^.max_v_samp_factor := compptr^.v_samp_factor; - Inc(compptr); - end; - - { Compute dimensions of components } - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - { Fill in the correct component_index value; don't rely on application } - compptr^.component_index := ci; - { For compression, we never do DCT scaling. } - compptr^.DCT_scaled_size := DCTSIZE; - { Size in DCT blocks } - compptr^.width_in_blocks := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_width) * long (compptr^.h_samp_factor), - long (cinfo^.max_h_samp_factor * DCTSIZE)) ); - compptr^.height_in_blocks := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_height) * long (compptr^.v_samp_factor), - long (cinfo^.max_v_samp_factor * DCTSIZE)) ); - { Size in samples } - compptr^.downsampled_width := JDIMENSION ( - jdiv_round_up(long(cinfo^.image_width) * long(compptr^.h_samp_factor), - long(cinfo^.max_h_samp_factor)) ); - compptr^.downsampled_height := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor), - long (cinfo^.max_v_samp_factor)) ); - { Mark component needed (this flag isn't actually used for compression) } - compptr^.component_needed := TRUE; - Inc(compptr); - end; - - { Compute number of fully interleaved MCU rows (number of times that - main controller will call coefficient controller). } - - cinfo^.total_iMCU_rows := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_height), - long (cinfo^.max_v_samp_factor*DCTSIZE)) ); -end; - - -{$ifdef C_MULTISCAN_FILES_SUPPORTED} - -{LOCAL} -procedure validate_script (cinfo : j_compress_ptr); -{ Verify that the scan script in cinfo^.scan_info[] is valid; also - determine whether it uses progressive JPEG, and set cinfo^.progressive_mode. } -type - IntRow = array[0..DCTSIZE2-1] of int; - introw_ptr = ^IntRow; -var - {const}scanptr : jpeg_scan_info_ptr; - scanno, ncomps, ci, coefi, thisi : int; - Ss, Se, Ah, Al : int; - component_sent : array[0..MAX_COMPONENTS-1] of boolean; -{$ifdef C_PROGRESSIVE_SUPPORTED} - last_bitpos_int_ptr : int_ptr; - last_bitpos_ptr : introw_ptr; - last_bitpos : array[0..MAX_COMPONENTS-1] of IntRow; - { -1 until that coefficient has been seen; then last Al for it } - { The JPEG spec simply gives the ranges 0..13 for Ah and Al, but that - seems wrong: the upper bound ought to depend on data precision. - Perhaps they really meant 0..N+1 for N-bit precision. - Here we allow 0..10 for 8-bit data; Al larger than 10 results in - out-of-range reconstructed DC values during the first DC scan, - which might cause problems for some decoders. } -{$ifdef BITS_IN_JSAMPLE_IS_8} -const - MAX_AH_AL = 10; -{$else} -const - MAX_AH_AL = 13; -{$endif} -{$endif} -begin - - if (cinfo^.num_scans <= 0) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, 0); - - { For sequential JPEG, all scans must have Ss=0, Se=DCTSIZE2-1; - for progressive JPEG, no scan can have this. } - - scanptr := cinfo^.scan_info; - if (scanptr^.Ss <> 0) or (scanptr^.Se <> DCTSIZE2-1) then - begin -{$ifdef C_PROGRESSIVE_SUPPORTED} - cinfo^.progressive_mode := TRUE; - last_bitpos_int_ptr := @(last_bitpos[0][0]); - for ci := 0 to pred(cinfo^.num_components) do - for coefi := 0 to pred(DCTSIZE2) do - begin - last_bitpos_int_ptr^ := -1; - Inc(last_bitpos_int_ptr); - end; -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} - end - else - begin - cinfo^.progressive_mode := FALSE; - for ci := 0 to pred(cinfo^.num_components) do - component_sent[ci] := FALSE; - end; - - for scanno := 1 to cinfo^.num_scans do - begin - { Validate component indexes } - ncomps := scanptr^.comps_in_scan; - if (ncomps <= 0) or (ncomps > MAX_COMPS_IN_SCAN) then - ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, ncomps, MAX_COMPS_IN_SCAN); - for ci := 0 to pred(ncomps) do - begin - thisi := scanptr^.component_index[ci]; - if (thisi < 0) or (thisi >= cinfo^.num_components) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, scanno); - { Components must appear in SOF order within each scan } - if (ci > 0) and (thisi <= scanptr^.component_index[ci-1]) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, scanno); - end; - { Validate progression parameters } - Ss := scanptr^.Ss; - Se := scanptr^.Se; - Ah := scanptr^.Ah; - Al := scanptr^.Al; - if (cinfo^.progressive_mode) then - begin -{$ifdef C_PROGRESSIVE_SUPPORTED} - if (Ss < 0) or (Ss >= DCTSIZE2) or (Se < Ss) or (Se >= DCTSIZE2) or - (Ah < 0) or (Ah > MAX_AH_AL) or (Al < 0) or (Al > MAX_AH_AL) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); - - if (Ss < 0) or (Ss >= DCTSIZE2) or (Se < Ss) or (Se >= DCTSIZE2) - or (Ah < 0) or (Ah > MAX_AH_AL) or (Al < 0) or (Al > MAX_AH_AL) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); - if (Ss = 0) then - begin - if (Se <> 0) then { DC and AC together not OK } - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); - end - else - begin - if (ncomps <> 1) then { AC scans must be for only one component } - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); - end; - for ci := 0 to pred(ncomps) do - begin - last_bitpos_ptr := @( last_bitpos[scanptr^.component_index[ci]]); - if (Ss <> 0) and (last_bitpos_ptr^[0] < 0) then { AC without prior DC scan } - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); - for coefi := Ss to Se do - begin - if (last_bitpos_ptr^[coefi] < 0) then - begin - { first scan of this coefficient } - if (Ah <> 0) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); - end - else - begin - { not first scan } - if (Ah <> last_bitpos_ptr^[coefi]) or (Al <> Ah-1) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); - end; - last_bitpos_ptr^[coefi] := Al; - end; - end; -{$endif} - end - else - begin - { For sequential JPEG, all progression parameters must be these: } - if (Ss <> 0) or (Se <> DCTSIZE2-1) or (Ah <> 0) or (Al <> 0) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); - { Make sure components are not sent twice } - for ci := 0 to pred(ncomps) do - begin - thisi := scanptr^.component_index[ci]; - if (component_sent[thisi]) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, scanno); - component_sent[thisi] := TRUE; - end; - end; - Inc(scanptr); - end; - - { Now verify that everything got sent. } - if (cinfo^.progressive_mode) then - begin -{$ifdef C_PROGRESSIVE_SUPPORTED} - { For progressive mode, we only check that at least some DC data - got sent for each component; the spec does not require that all bits - of all coefficients be transmitted. Would it be wiser to enforce - transmission of all coefficient bits?? } - - for ci := 0 to pred(cinfo^.num_components) do - begin - if (last_bitpos[ci][0] < 0) then - ERREXIT(j_common_ptr(cinfo), JERR_MISSING_DATA); - end; -{$endif} - end - else - begin - for ci := 0 to pred(cinfo^.num_components) do - begin - if (not component_sent[ci]) then - ERREXIT(j_common_ptr(cinfo), JERR_MISSING_DATA); - end; - end; -end; - -{$endif} { C_MULTISCAN_FILES_SUPPORTED } - - -{LOCAL} -procedure select_scan_parameters (cinfo : j_compress_ptr); -{ Set up the scan parameters for the current scan } -var - master : my_master_ptr; - {const} scanptr : jpeg_scan_info_ptr; - ci : int; -var - comp_infos : jpeg_component_info_list_ptr; -begin -{$ifdef C_MULTISCAN_FILES_SUPPORTED} - if (cinfo^.scan_info <> NIL) then - begin - { Prepare for current scan --- the script is already validated } - master := my_master_ptr (cinfo^.master); - scanptr := cinfo^.scan_info; - Inc(scanptr, master^.scan_number); - - cinfo^.comps_in_scan := scanptr^.comps_in_scan; - comp_infos := cinfo^.comp_info; - for ci := 0 to pred(scanptr^.comps_in_scan) do - begin - cinfo^.cur_comp_info[ci] := - @(comp_infos^[scanptr^.component_index[ci]]); - end; - cinfo^.Ss := scanptr^.Ss; - cinfo^.Se := scanptr^.Se; - cinfo^.Ah := scanptr^.Ah; - cinfo^.Al := scanptr^.Al; - end - else -{$endif} - begin - { Prepare for single sequential-JPEG scan containing all components } - if (cinfo^.num_components > MAX_COMPS_IN_SCAN) then - ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components, - MAX_COMPS_IN_SCAN); - cinfo^.comps_in_scan := cinfo^.num_components; - comp_infos := cinfo^.comp_info; - for ci := 0 to pred(cinfo^.num_components) do - begin - cinfo^.cur_comp_info[ci] := @(comp_infos^[ci]); - end; - cinfo^.Ss := 0; - cinfo^.Se := DCTSIZE2-1; - cinfo^.Ah := 0; - cinfo^.Al := 0; - end; -end; - - -{LOCAL} -procedure per_scan_setup (cinfo : j_compress_ptr); -{ Do computations that are needed before processing a JPEG scan } -{ cinfo^.comps_in_scan and cinfo^.cur_comp_info[] are already set } -var - ci, mcublks, tmp : int; - compptr : jpeg_component_info_ptr; - nominal : long; -begin - if (cinfo^.comps_in_scan = 1) then - begin - - { Noninterleaved (single-component) scan } - compptr := cinfo^.cur_comp_info[0]; - - { Overall image size in MCUs } - cinfo^.MCUs_per_row := compptr^.width_in_blocks; - cinfo^.MCU_rows_in_scan := compptr^.height_in_blocks; - - { For noninterleaved scan, always one block per MCU } - compptr^.MCU_width := 1; - compptr^.MCU_height := 1; - compptr^.MCU_blocks := 1; - compptr^.MCU_sample_width := DCTSIZE; - compptr^.last_col_width := 1; - { For noninterleaved scans, it is convenient to define last_row_height - as the number of block rows present in the last iMCU row. } - - tmp := int (compptr^.height_in_blocks) mod compptr^.v_samp_factor; - if (tmp = 0) then - tmp := compptr^.v_samp_factor; - compptr^.last_row_height := tmp; - - { Prepare array describing MCU composition } - cinfo^.blocks_in_MCU := 1; - cinfo^.MCU_membership[0] := 0; - - end - else - begin - - { Interleaved (multi-component) scan } - if (cinfo^.comps_in_scan <= 0) or - (cinfo^.comps_in_scan > MAX_COMPS_IN_SCAN) then - ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, - cinfo^.comps_in_scan, MAX_COMPS_IN_SCAN); - - { Overall image size in MCUs } - cinfo^.MCUs_per_row := JDIMENSION ( - jdiv_round_up( long (cinfo^.image_width), - long (cinfo^.max_h_samp_factor*DCTSIZE)) ); - cinfo^.MCU_rows_in_scan := JDIMENSION ( - jdiv_round_up( long (cinfo^.image_height), - long (cinfo^.max_v_samp_factor*DCTSIZE)) ); - - cinfo^.blocks_in_MCU := 0; - - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - { Sampling factors give # of blocks of component in each MCU } - compptr^.MCU_width := compptr^.h_samp_factor; - compptr^.MCU_height := compptr^.v_samp_factor; - compptr^.MCU_blocks := compptr^.MCU_width * compptr^.MCU_height; - compptr^.MCU_sample_width := compptr^.MCU_width * DCTSIZE; - { Figure number of non-dummy blocks in last MCU column & row } - tmp := int (compptr^.width_in_blocks) mod compptr^.MCU_width; - if (tmp = 0) then - tmp := compptr^.MCU_width; - compptr^.last_col_width := tmp; - tmp := int (compptr^.height_in_blocks) mod compptr^.MCU_height; - if (tmp = 0) then - tmp := compptr^.MCU_height; - compptr^.last_row_height := tmp; - { Prepare array describing MCU composition } - mcublks := compptr^.MCU_blocks; - if (cinfo^.blocks_in_MCU + mcublks > C_MAX_BLOCKS_IN_MCU) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_MCU_SIZE); - while (mcublks > 0) do - begin - Dec(mcublks); - cinfo^.MCU_membership[cinfo^.blocks_in_MCU] := ci; - Inc(cinfo^.blocks_in_MCU); - end; - end; - - end; - - { Convert restart specified in rows to actual MCU count. } - { Note that count must fit in 16 bits, so we provide limiting. } - if (cinfo^.restart_in_rows > 0) then - begin - nominal := long(cinfo^.restart_in_rows) * long(cinfo^.MCUs_per_row); - if nominal < long(65535) then - cinfo^.restart_interval := uInt (nominal) - else - cinfo^.restart_interval := long(65535); - end; -end; - - -{ Per-pass setup. - This is called at the beginning of each pass. We determine which modules - will be active during this pass and give them appropriate start_pass calls. - We also set is_last_pass to indicate whether any more passes will be - required. } - -{METHODDEF} -procedure prepare_for_pass (cinfo : j_compress_ptr); -var - master : my_master_ptr; -var - fallthrough : boolean; -begin - master := my_master_ptr (cinfo^.master); - fallthrough := true; - - case (master^.pass_type) of - main_pass: - begin - { Initial pass: will collect input data, and do either Huffman - optimization or data output for the first scan. } - select_scan_parameters(cinfo); - per_scan_setup(cinfo); - if (not cinfo^.raw_data_in) then - begin - cinfo^.cconvert^.start_pass (cinfo); - cinfo^.downsample^.start_pass (cinfo); - cinfo^.prep^.start_pass (cinfo, JBUF_PASS_THRU); - end; - cinfo^.fdct^.start_pass (cinfo); - cinfo^.entropy^.start_pass (cinfo, cinfo^.optimize_coding); - if master^.total_passes > 1 then - cinfo^.coef^.start_pass (cinfo, JBUF_SAVE_AND_PASS) - else - cinfo^.coef^.start_pass (cinfo, JBUF_PASS_THRU); - cinfo^.main^.start_pass (cinfo, JBUF_PASS_THRU); - if (cinfo^.optimize_coding) then - begin - { No immediate data output; postpone writing frame/scan headers } - master^.pub.call_pass_startup := FALSE; - end - else - begin - { Will write frame/scan headers at first jpeg_write_scanlines call } - master^.pub.call_pass_startup := TRUE; - end; - end; -{$ifdef ENTROPY_OPT_SUPPORTED} - huff_opt_pass, - output_pass: - begin - if (master^.pass_type = huff_opt_pass) then - begin - { Do Huffman optimization for a scan after the first one. } - select_scan_parameters(cinfo); - per_scan_setup(cinfo); - if (cinfo^.Ss <> 0) or (cinfo^.Ah = 0) or (cinfo^.arith_code) then - begin - cinfo^.entropy^.start_pass (cinfo, TRUE); - cinfo^.coef^.start_pass (cinfo, JBUF_CRANK_DEST); - master^.pub.call_pass_startup := FALSE; - fallthrough := false; - end; - { Special case: Huffman DC refinement scans need no Huffman table - and therefore we can skip the optimization pass for them. } - if fallthrough then - begin - master^.pass_type := output_pass; - Inc(master^.pass_number); - {FALLTHROUGH} - end; - end; -{$else} - output_pass: - begin -{$endif} - if fallthrough then - begin - { Do a data-output pass. } - { We need not repeat per-scan setup if prior optimization pass did it. } - if (not cinfo^.optimize_coding) then - begin - select_scan_parameters(cinfo); - per_scan_setup(cinfo); - end; - cinfo^.entropy^.start_pass (cinfo, FALSE); - cinfo^.coef^.start_pass (cinfo, JBUF_CRANK_DEST); - { We emit frame/scan headers now } - if (master^.scan_number = 0) then - cinfo^.marker^.write_frame_header (cinfo); - cinfo^.marker^.write_scan_header (cinfo); - master^.pub.call_pass_startup := FALSE; - end; - end; - else - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); - end; - - master^.pub.is_last_pass := (master^.pass_number = master^.total_passes-1); - - { Set up progress monitor's pass info if present } - if (cinfo^.progress <> NIL) then - begin - cinfo^.progress^.completed_passes := master^.pass_number; - cinfo^.progress^.total_passes := master^.total_passes; - end; -end; - - -{ Special start-of-pass hook. - This is called by jpeg_write_scanlines if call_pass_startup is TRUE. - In single-pass processing, we need this hook because we don't want to - write frame/scan headers during jpeg_start_compress; we want to let the - application write COM markers etc. between jpeg_start_compress and the - jpeg_write_scanlines loop. - In multi-pass processing, this routine is not used. } - -{METHODDEF} -procedure pass_startup (cinfo : j_compress_ptr); -begin - cinfo^.master^.call_pass_startup := FALSE; { reset flag so call only once } - - cinfo^.marker^.write_frame_header (cinfo); - cinfo^.marker^.write_scan_header (cinfo); -end; - - -{ Finish up at end of pass. } - -{METHODDEF} -procedure finish_pass_master (cinfo : j_compress_ptr); -var - master : my_master_ptr; -begin - master := my_master_ptr (cinfo^.master); - - { The entropy coder always needs an end-of-pass call, - either to analyze statistics or to flush its output buffer. } - cinfo^.entropy^.finish_pass (cinfo); - - { Update state for next pass } - case (master^.pass_type) of - main_pass: - begin - { next pass is either output of scan 0 (after optimization) - or output of scan 1 (if no optimization). } - - master^.pass_type := output_pass; - if (not cinfo^.optimize_coding) then - Inc(master^.scan_number); - end; - huff_opt_pass: - { next pass is always output of current scan } - master^.pass_type := output_pass; - output_pass: - begin - { next pass is either optimization or output of next scan } - if (cinfo^.optimize_coding) then - master^.pass_type := huff_opt_pass; - Inc(master^.scan_number); - end; - end; - - Inc(master^.pass_number); -end; - - -{ Initialize master compression control. } - -{GLOBAL} -procedure jinit_c_master_control (cinfo : j_compress_ptr; - transcode_only : boolean); -var - master : my_master_ptr; -begin - master := my_master_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_comp_master)) ); - cinfo^.master := jpeg_comp_master_ptr(master); - master^.pub.prepare_for_pass := prepare_for_pass; - master^.pub.pass_startup := pass_startup; - master^.pub.finish_pass := finish_pass_master; - master^.pub.is_last_pass := FALSE; - - { Validate parameters, determine derived values } - initial_setup(cinfo); - - if (cinfo^.scan_info <> NIL) then - begin -{$ifdef C_MULTISCAN_FILES_SUPPORTED} - validate_script(cinfo); -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} - end - else - begin - cinfo^.progressive_mode := FALSE; - cinfo^.num_scans := 1; - end; - - if (cinfo^.progressive_mode) then { TEMPORARY HACK ??? } - cinfo^.optimize_coding := TRUE; { assume default tables no good for progressive mode } - - { Initialize my private state } - if (transcode_only) then - begin - { no main pass in transcoding } - if (cinfo^.optimize_coding) then - master^.pass_type := huff_opt_pass - else - master^.pass_type := output_pass; - end - else - begin - { for normal compression, first pass is always this type: } - master^.pass_type := main_pass; - end; - master^.scan_number := 0; - master^.pass_number := 0; - if (cinfo^.optimize_coding) then - master^.total_passes := cinfo^.num_scans * 2 - else - master^.total_passes := cinfo^.num_scans; -end; - -end. +unit imjcmaster; + +{ This file contains master control logic for the JPEG compressor. + These routines are concerned with parameter validation, initial setup, + and inter-pass control (determining the number of passes and the work + to be done in each pass). } + +{ Original: jcmaster.c ; Copyright (C) 1991-1997, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjutils, + imjpeglib; + +{ Initialize master compression control. } + +{GLOBAL} +procedure jinit_c_master_control (cinfo : j_compress_ptr; + transcode_only : boolean); + +implementation + +{ Private state } + +type + c_pass_type = ( + main_pass, { input data, also do first output step } + huff_opt_pass, { Huffman code optimization pass } + output_pass { data output pass } + ); + +type + my_master_ptr = ^my_comp_master; + my_comp_master = record + pub : jpeg_comp_master; { public fields } + + pass_type : c_pass_type; { the type of the current pass } + + pass_number : int; { # of passes completed } + total_passes : int; { total # of passes needed } + + scan_number : int; { current index in scan_info[] } + end; + + +{ Support routines that do various essential calculations. } + +{LOCAL} +procedure initial_setup (cinfo : j_compress_ptr); +{ Do computations that are needed before master selection phase } +var + ci : int; + compptr : jpeg_component_info_ptr; + samplesperrow : long; + jd_samplesperrow : JDIMENSION; +begin + + { Sanity check on image dimensions } + if (cinfo^.image_height <= 0) or (cinfo^.image_width <= 0) or + (cinfo^.num_components <= 0) or (cinfo^.input_components <= 0) then + ERREXIT(j_common_ptr(cinfo), JERR_EMPTY_IMAGE); + + { Make sure image isn't bigger than I can handle } + if ( long(cinfo^.image_height) > long(JPEG_MAX_DIMENSION)) or + ( long(cinfo^.image_width) > long(JPEG_MAX_DIMENSION)) then + ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, + uInt(JPEG_MAX_DIMENSION)); + + { Width of an input scanline must be representable as JDIMENSION. } + samplesperrow := long (cinfo^.image_width) * long (cinfo^.input_components); + jd_samplesperrow := JDIMENSION (samplesperrow); + if ( long(jd_samplesperrow) <> samplesperrow) then + ERREXIT(j_common_ptr(cinfo), JERR_WIDTH_OVERFLOW); + + { For now, precision must match compiled-in value... } + if (cinfo^.data_precision <> BITS_IN_JSAMPLE) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PRECISION, cinfo^.data_precision); + + { Check that number of components won't exceed internal array sizes } + if (cinfo^.num_components > MAX_COMPONENTS) then + ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components, + MAX_COMPONENTS); + + { Compute maximum sampling factors; check factor validity } + cinfo^.max_h_samp_factor := 1; + cinfo^.max_v_samp_factor := 1; + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + if (compptr^.h_samp_factor<=0) or (compptr^.h_samp_factor>MAX_SAMP_FACTOR) + or (compptr^.v_samp_factor<=0) or (compptr^.v_samp_factor>MAX_SAMP_FACTOR) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_SAMPLING); + { MAX } + if cinfo^.max_h_samp_factor > compptr^.h_samp_factor then + cinfo^.max_h_samp_factor := cinfo^.max_h_samp_factor + else + cinfo^.max_h_samp_factor := compptr^.h_samp_factor; + { MAX } + if cinfo^.max_v_samp_factor > compptr^.v_samp_factor then + cinfo^.max_v_samp_factor := cinfo^.max_v_samp_factor + else + cinfo^.max_v_samp_factor := compptr^.v_samp_factor; + Inc(compptr); + end; + + { Compute dimensions of components } + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + { Fill in the correct component_index value; don't rely on application } + compptr^.component_index := ci; + { For compression, we never do DCT scaling. } + compptr^.DCT_scaled_size := DCTSIZE; + { Size in DCT blocks } + compptr^.width_in_blocks := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_width) * long (compptr^.h_samp_factor), + long (cinfo^.max_h_samp_factor * DCTSIZE)) ); + compptr^.height_in_blocks := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_height) * long (compptr^.v_samp_factor), + long (cinfo^.max_v_samp_factor * DCTSIZE)) ); + { Size in samples } + compptr^.downsampled_width := JDIMENSION ( + jdiv_round_up(long(cinfo^.image_width) * long(compptr^.h_samp_factor), + long(cinfo^.max_h_samp_factor)) ); + compptr^.downsampled_height := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor), + long (cinfo^.max_v_samp_factor)) ); + { Mark component needed (this flag isn't actually used for compression) } + compptr^.component_needed := TRUE; + Inc(compptr); + end; + + { Compute number of fully interleaved MCU rows (number of times that + main controller will call coefficient controller). } + + cinfo^.total_iMCU_rows := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_height), + long (cinfo^.max_v_samp_factor*DCTSIZE)) ); +end; + + +{$ifdef C_MULTISCAN_FILES_SUPPORTED} + +{LOCAL} +procedure validate_script (cinfo : j_compress_ptr); +{ Verify that the scan script in cinfo^.scan_info[] is valid; also + determine whether it uses progressive JPEG, and set cinfo^.progressive_mode. } +type + IntRow = array[0..DCTSIZE2-1] of int; + introw_ptr = ^IntRow; +var + {const}scanptr : jpeg_scan_info_ptr; + scanno, ncomps, ci, coefi, thisi : int; + Ss, Se, Ah, Al : int; + component_sent : array[0..MAX_COMPONENTS-1] of boolean; +{$ifdef C_PROGRESSIVE_SUPPORTED} + last_bitpos_int_ptr : int_ptr; + last_bitpos_ptr : introw_ptr; + last_bitpos : array[0..MAX_COMPONENTS-1] of IntRow; + { -1 until that coefficient has been seen; then last Al for it } + { The JPEG spec simply gives the ranges 0..13 for Ah and Al, but that + seems wrong: the upper bound ought to depend on data precision. + Perhaps they really meant 0..N+1 for N-bit precision. + Here we allow 0..10 for 8-bit data; Al larger than 10 results in + out-of-range reconstructed DC values during the first DC scan, + which might cause problems for some decoders. } +{$ifdef BITS_IN_JSAMPLE_IS_8} +const + MAX_AH_AL = 10; +{$else} +const + MAX_AH_AL = 13; +{$endif} +{$endif} +begin + + if (cinfo^.num_scans <= 0) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, 0); + + { For sequential JPEG, all scans must have Ss=0, Se=DCTSIZE2-1; + for progressive JPEG, no scan can have this. } + + scanptr := cinfo^.scan_info; + if (scanptr^.Ss <> 0) or (scanptr^.Se <> DCTSIZE2-1) then + begin +{$ifdef C_PROGRESSIVE_SUPPORTED} + cinfo^.progressive_mode := TRUE; + last_bitpos_int_ptr := @(last_bitpos[0][0]); + for ci := 0 to pred(cinfo^.num_components) do + for coefi := 0 to pred(DCTSIZE2) do + begin + last_bitpos_int_ptr^ := -1; + Inc(last_bitpos_int_ptr); + end; +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} + end + else + begin + cinfo^.progressive_mode := FALSE; + for ci := 0 to pred(cinfo^.num_components) do + component_sent[ci] := FALSE; + end; + + for scanno := 1 to cinfo^.num_scans do + begin + { Validate component indexes } + ncomps := scanptr^.comps_in_scan; + if (ncomps <= 0) or (ncomps > MAX_COMPS_IN_SCAN) then + ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, ncomps, MAX_COMPS_IN_SCAN); + for ci := 0 to pred(ncomps) do + begin + thisi := scanptr^.component_index[ci]; + if (thisi < 0) or (thisi >= cinfo^.num_components) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, scanno); + { Components must appear in SOF order within each scan } + if (ci > 0) and (thisi <= scanptr^.component_index[ci-1]) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, scanno); + end; + { Validate progression parameters } + Ss := scanptr^.Ss; + Se := scanptr^.Se; + Ah := scanptr^.Ah; + Al := scanptr^.Al; + if (cinfo^.progressive_mode) then + begin +{$ifdef C_PROGRESSIVE_SUPPORTED} + if (Ss < 0) or (Ss >= DCTSIZE2) or (Se < Ss) or (Se >= DCTSIZE2) or + (Ah < 0) or (Ah > MAX_AH_AL) or (Al < 0) or (Al > MAX_AH_AL) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); + + if (Ss < 0) or (Ss >= DCTSIZE2) or (Se < Ss) or (Se >= DCTSIZE2) + or (Ah < 0) or (Ah > MAX_AH_AL) or (Al < 0) or (Al > MAX_AH_AL) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); + if (Ss = 0) then + begin + if (Se <> 0) then { DC and AC together not OK } + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); + end + else + begin + if (ncomps <> 1) then { AC scans must be for only one component } + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); + end; + for ci := 0 to pred(ncomps) do + begin + last_bitpos_ptr := @( last_bitpos[scanptr^.component_index[ci]]); + if (Ss <> 0) and (last_bitpos_ptr^[0] < 0) then { AC without prior DC scan } + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); + for coefi := Ss to Se do + begin + if (last_bitpos_ptr^[coefi] < 0) then + begin + { first scan of this coefficient } + if (Ah <> 0) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); + end + else + begin + { not first scan } + if (Ah <> last_bitpos_ptr^[coefi]) or (Al <> Ah-1) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); + end; + last_bitpos_ptr^[coefi] := Al; + end; + end; +{$endif} + end + else + begin + { For sequential JPEG, all progression parameters must be these: } + if (Ss <> 0) or (Se <> DCTSIZE2-1) or (Ah <> 0) or (Al <> 0) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PROG_SCRIPT, scanno); + { Make sure components are not sent twice } + for ci := 0 to pred(ncomps) do + begin + thisi := scanptr^.component_index[ci]; + if (component_sent[thisi]) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_SCAN_SCRIPT, scanno); + component_sent[thisi] := TRUE; + end; + end; + Inc(scanptr); + end; + + { Now verify that everything got sent. } + if (cinfo^.progressive_mode) then + begin +{$ifdef C_PROGRESSIVE_SUPPORTED} + { For progressive mode, we only check that at least some DC data + got sent for each component; the spec does not require that all bits + of all coefficients be transmitted. Would it be wiser to enforce + transmission of all coefficient bits?? } + + for ci := 0 to pred(cinfo^.num_components) do + begin + if (last_bitpos[ci][0] < 0) then + ERREXIT(j_common_ptr(cinfo), JERR_MISSING_DATA); + end; +{$endif} + end + else + begin + for ci := 0 to pred(cinfo^.num_components) do + begin + if (not component_sent[ci]) then + ERREXIT(j_common_ptr(cinfo), JERR_MISSING_DATA); + end; + end; +end; + +{$endif} { C_MULTISCAN_FILES_SUPPORTED } + + +{LOCAL} +procedure select_scan_parameters (cinfo : j_compress_ptr); +{ Set up the scan parameters for the current scan } +var + master : my_master_ptr; + {const} scanptr : jpeg_scan_info_ptr; + ci : int; +var + comp_infos : jpeg_component_info_list_ptr; +begin +{$ifdef C_MULTISCAN_FILES_SUPPORTED} + if (cinfo^.scan_info <> NIL) then + begin + { Prepare for current scan --- the script is already validated } + master := my_master_ptr (cinfo^.master); + scanptr := cinfo^.scan_info; + Inc(scanptr, master^.scan_number); + + cinfo^.comps_in_scan := scanptr^.comps_in_scan; + comp_infos := cinfo^.comp_info; + for ci := 0 to pred(scanptr^.comps_in_scan) do + begin + cinfo^.cur_comp_info[ci] := + @(comp_infos^[scanptr^.component_index[ci]]); + end; + cinfo^.Ss := scanptr^.Ss; + cinfo^.Se := scanptr^.Se; + cinfo^.Ah := scanptr^.Ah; + cinfo^.Al := scanptr^.Al; + end + else +{$endif} + begin + { Prepare for single sequential-JPEG scan containing all components } + if (cinfo^.num_components > MAX_COMPS_IN_SCAN) then + ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components, + MAX_COMPS_IN_SCAN); + cinfo^.comps_in_scan := cinfo^.num_components; + comp_infos := cinfo^.comp_info; + for ci := 0 to pred(cinfo^.num_components) do + begin + cinfo^.cur_comp_info[ci] := @(comp_infos^[ci]); + end; + cinfo^.Ss := 0; + cinfo^.Se := DCTSIZE2-1; + cinfo^.Ah := 0; + cinfo^.Al := 0; + end; +end; + + +{LOCAL} +procedure per_scan_setup (cinfo : j_compress_ptr); +{ Do computations that are needed before processing a JPEG scan } +{ cinfo^.comps_in_scan and cinfo^.cur_comp_info[] are already set } +var + ci, mcublks, tmp : int; + compptr : jpeg_component_info_ptr; + nominal : long; +begin + if (cinfo^.comps_in_scan = 1) then + begin + + { Noninterleaved (single-component) scan } + compptr := cinfo^.cur_comp_info[0]; + + { Overall image size in MCUs } + cinfo^.MCUs_per_row := compptr^.width_in_blocks; + cinfo^.MCU_rows_in_scan := compptr^.height_in_blocks; + + { For noninterleaved scan, always one block per MCU } + compptr^.MCU_width := 1; + compptr^.MCU_height := 1; + compptr^.MCU_blocks := 1; + compptr^.MCU_sample_width := DCTSIZE; + compptr^.last_col_width := 1; + { For noninterleaved scans, it is convenient to define last_row_height + as the number of block rows present in the last iMCU row. } + + tmp := int (compptr^.height_in_blocks) mod compptr^.v_samp_factor; + if (tmp = 0) then + tmp := compptr^.v_samp_factor; + compptr^.last_row_height := tmp; + + { Prepare array describing MCU composition } + cinfo^.blocks_in_MCU := 1; + cinfo^.MCU_membership[0] := 0; + + end + else + begin + + { Interleaved (multi-component) scan } + if (cinfo^.comps_in_scan <= 0) or + (cinfo^.comps_in_scan > MAX_COMPS_IN_SCAN) then + ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, + cinfo^.comps_in_scan, MAX_COMPS_IN_SCAN); + + { Overall image size in MCUs } + cinfo^.MCUs_per_row := JDIMENSION ( + jdiv_round_up( long (cinfo^.image_width), + long (cinfo^.max_h_samp_factor*DCTSIZE)) ); + cinfo^.MCU_rows_in_scan := JDIMENSION ( + jdiv_round_up( long (cinfo^.image_height), + long (cinfo^.max_v_samp_factor*DCTSIZE)) ); + + cinfo^.blocks_in_MCU := 0; + + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + { Sampling factors give # of blocks of component in each MCU } + compptr^.MCU_width := compptr^.h_samp_factor; + compptr^.MCU_height := compptr^.v_samp_factor; + compptr^.MCU_blocks := compptr^.MCU_width * compptr^.MCU_height; + compptr^.MCU_sample_width := compptr^.MCU_width * DCTSIZE; + { Figure number of non-dummy blocks in last MCU column & row } + tmp := int (compptr^.width_in_blocks) mod compptr^.MCU_width; + if (tmp = 0) then + tmp := compptr^.MCU_width; + compptr^.last_col_width := tmp; + tmp := int (compptr^.height_in_blocks) mod compptr^.MCU_height; + if (tmp = 0) then + tmp := compptr^.MCU_height; + compptr^.last_row_height := tmp; + { Prepare array describing MCU composition } + mcublks := compptr^.MCU_blocks; + if (cinfo^.blocks_in_MCU + mcublks > C_MAX_BLOCKS_IN_MCU) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_MCU_SIZE); + while (mcublks > 0) do + begin + Dec(mcublks); + cinfo^.MCU_membership[cinfo^.blocks_in_MCU] := ci; + Inc(cinfo^.blocks_in_MCU); + end; + end; + + end; + + { Convert restart specified in rows to actual MCU count. } + { Note that count must fit in 16 bits, so we provide limiting. } + if (cinfo^.restart_in_rows > 0) then + begin + nominal := long(cinfo^.restart_in_rows) * long(cinfo^.MCUs_per_row); + if nominal < long(65535) then + cinfo^.restart_interval := uInt (nominal) + else + cinfo^.restart_interval := long(65535); + end; +end; + + +{ Per-pass setup. + This is called at the beginning of each pass. We determine which modules + will be active during this pass and give them appropriate start_pass calls. + We also set is_last_pass to indicate whether any more passes will be + required. } + +{METHODDEF} +procedure prepare_for_pass (cinfo : j_compress_ptr); +var + master : my_master_ptr; +var + fallthrough : boolean; +begin + master := my_master_ptr (cinfo^.master); + fallthrough := true; + + case (master^.pass_type) of + main_pass: + begin + { Initial pass: will collect input data, and do either Huffman + optimization or data output for the first scan. } + select_scan_parameters(cinfo); + per_scan_setup(cinfo); + if (not cinfo^.raw_data_in) then + begin + cinfo^.cconvert^.start_pass (cinfo); + cinfo^.downsample^.start_pass (cinfo); + cinfo^.prep^.start_pass (cinfo, JBUF_PASS_THRU); + end; + cinfo^.fdct^.start_pass (cinfo); + cinfo^.entropy^.start_pass (cinfo, cinfo^.optimize_coding); + if master^.total_passes > 1 then + cinfo^.coef^.start_pass (cinfo, JBUF_SAVE_AND_PASS) + else + cinfo^.coef^.start_pass (cinfo, JBUF_PASS_THRU); + cinfo^.main^.start_pass (cinfo, JBUF_PASS_THRU); + if (cinfo^.optimize_coding) then + begin + { No immediate data output; postpone writing frame/scan headers } + master^.pub.call_pass_startup := FALSE; + end + else + begin + { Will write frame/scan headers at first jpeg_write_scanlines call } + master^.pub.call_pass_startup := TRUE; + end; + end; +{$ifdef ENTROPY_OPT_SUPPORTED} + huff_opt_pass, + output_pass: + begin + if (master^.pass_type = huff_opt_pass) then + begin + { Do Huffman optimization for a scan after the first one. } + select_scan_parameters(cinfo); + per_scan_setup(cinfo); + if (cinfo^.Ss <> 0) or (cinfo^.Ah = 0) or (cinfo^.arith_code) then + begin + cinfo^.entropy^.start_pass (cinfo, TRUE); + cinfo^.coef^.start_pass (cinfo, JBUF_CRANK_DEST); + master^.pub.call_pass_startup := FALSE; + fallthrough := false; + end; + { Special case: Huffman DC refinement scans need no Huffman table + and therefore we can skip the optimization pass for them. } + if fallthrough then + begin + master^.pass_type := output_pass; + Inc(master^.pass_number); + {FALLTHROUGH} + end; + end; +{$else} + output_pass: + begin +{$endif} + if fallthrough then + begin + { Do a data-output pass. } + { We need not repeat per-scan setup if prior optimization pass did it. } + if (not cinfo^.optimize_coding) then + begin + select_scan_parameters(cinfo); + per_scan_setup(cinfo); + end; + cinfo^.entropy^.start_pass (cinfo, FALSE); + cinfo^.coef^.start_pass (cinfo, JBUF_CRANK_DEST); + { We emit frame/scan headers now } + if (master^.scan_number = 0) then + cinfo^.marker^.write_frame_header (cinfo); + cinfo^.marker^.write_scan_header (cinfo); + master^.pub.call_pass_startup := FALSE; + end; + end; + else + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); + end; + + master^.pub.is_last_pass := (master^.pass_number = master^.total_passes-1); + + { Set up progress monitor's pass info if present } + if (cinfo^.progress <> NIL) then + begin + cinfo^.progress^.completed_passes := master^.pass_number; + cinfo^.progress^.total_passes := master^.total_passes; + end; +end; + + +{ Special start-of-pass hook. + This is called by jpeg_write_scanlines if call_pass_startup is TRUE. + In single-pass processing, we need this hook because we don't want to + write frame/scan headers during jpeg_start_compress; we want to let the + application write COM markers etc. between jpeg_start_compress and the + jpeg_write_scanlines loop. + In multi-pass processing, this routine is not used. } + +{METHODDEF} +procedure pass_startup (cinfo : j_compress_ptr); +begin + cinfo^.master^.call_pass_startup := FALSE; { reset flag so call only once } + + cinfo^.marker^.write_frame_header (cinfo); + cinfo^.marker^.write_scan_header (cinfo); +end; + + +{ Finish up at end of pass. } + +{METHODDEF} +procedure finish_pass_master (cinfo : j_compress_ptr); +var + master : my_master_ptr; +begin + master := my_master_ptr (cinfo^.master); + + { The entropy coder always needs an end-of-pass call, + either to analyze statistics or to flush its output buffer. } + cinfo^.entropy^.finish_pass (cinfo); + + { Update state for next pass } + case (master^.pass_type) of + main_pass: + begin + { next pass is either output of scan 0 (after optimization) + or output of scan 1 (if no optimization). } + + master^.pass_type := output_pass; + if (not cinfo^.optimize_coding) then + Inc(master^.scan_number); + end; + huff_opt_pass: + { next pass is always output of current scan } + master^.pass_type := output_pass; + output_pass: + begin + { next pass is either optimization or output of next scan } + if (cinfo^.optimize_coding) then + master^.pass_type := huff_opt_pass; + Inc(master^.scan_number); + end; + end; + + Inc(master^.pass_number); +end; + + +{ Initialize master compression control. } + +{GLOBAL} +procedure jinit_c_master_control (cinfo : j_compress_ptr; + transcode_only : boolean); +var + master : my_master_ptr; +begin + master := my_master_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_comp_master)) ); + cinfo^.master := jpeg_comp_master_ptr(master); + master^.pub.prepare_for_pass := prepare_for_pass; + master^.pub.pass_startup := pass_startup; + master^.pub.finish_pass := finish_pass_master; + master^.pub.is_last_pass := FALSE; + + { Validate parameters, determine derived values } + initial_setup(cinfo); + + if (cinfo^.scan_info <> NIL) then + begin +{$ifdef C_MULTISCAN_FILES_SUPPORTED} + validate_script(cinfo); +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} + end + else + begin + cinfo^.progressive_mode := FALSE; + cinfo^.num_scans := 1; + end; + + if (cinfo^.progressive_mode) then { TEMPORARY HACK ??? } + cinfo^.optimize_coding := TRUE; { assume default tables no good for progressive mode } + + { Initialize my private state } + if (transcode_only) then + begin + { no main pass in transcoding } + if (cinfo^.optimize_coding) then + master^.pass_type := huff_opt_pass + else + master^.pass_type := output_pass; + end + else + begin + { for normal compression, first pass is always this type: } + master^.pass_type := main_pass; + end; + master^.scan_number := 0; + master^.pass_number := 0; + if (cinfo^.optimize_coding) then + master^.total_passes := cinfo^.num_scans * 2 + else + master^.total_passes := cinfo^.num_scans; +end; + +end. diff --git a/Imaging/JpegLib/imjcomapi.pas b/Imaging/JpegLib/imjcomapi.pas index c58a7ae..3242ed0 100644 --- a/Imaging/JpegLib/imjcomapi.pas +++ b/Imaging/JpegLib/imjcomapi.pas @@ -1,130 +1,130 @@ -unit imjcomapi; - -{ This file contains application interface routines that are used for both - compression and decompression. } - -{ Original: jcomapi.c; Copyright (C) 1994-1997, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib; - -{ Abort processing of a JPEG compression or decompression operation, - but don't destroy the object itself. } - -{GLOBAL} -procedure jpeg_abort (cinfo : j_common_ptr); - - -{ Destruction of a JPEG object. } - -{GLOBAL} -procedure jpeg_destroy (cinfo : j_common_ptr); - -{GLOBAL} -function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR; - -{GLOBAL} -function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR; - -implementation - -{ Abort processing of a JPEG compression or decompression operation, - but don't destroy the object itself. - - For this, we merely clean up all the nonpermanent memory pools. - Note that temp files (virtual arrays) are not allowed to belong to - the permanent pool, so we will be able to close all temp files here. - Closing a data source or destination, if necessary, is the application's - responsibility. } - - -{GLOBAL} -procedure jpeg_abort (cinfo : j_common_ptr); -var - pool : int; -begin - { Do nothing if called on a not-initialized or destroyed JPEG object. } - if (cinfo^.mem = NIL) then - exit; - - { Releasing pools in reverse order might help avoid fragmentation - with some (brain-damaged) malloc libraries. } - - for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT+1 do - begin - cinfo^.mem^.free_pool (cinfo, pool); - end; - - { Reset overall state for possible reuse of object } - if (cinfo^.is_decompressor) then - begin - cinfo^.global_state := DSTATE_START; - { Try to keep application from accessing now-deleted marker list. - A bit kludgy to do it here, but this is the most central place. } - j_decompress_ptr(cinfo)^.marker_list := NIL; - end - else - begin - cinfo^.global_state := CSTATE_START; - end; -end; - - -{ Destruction of a JPEG object. - - Everything gets deallocated except the master jpeg_compress_struct itself - and the error manager struct. Both of these are supplied by the application - and must be freed, if necessary, by the application. (Often they are on - the stack and so don't need to be freed anyway.) - Closing a data source or destination, if necessary, is the application's - responsibility. } - - -{GLOBAL} -procedure jpeg_destroy (cinfo : j_common_ptr); -begin - { We need only tell the memory manager to release everything. } - { NB: mem pointer is NIL if memory mgr failed to initialize. } - if (cinfo^.mem <> NIL) then - cinfo^.mem^.self_destruct (cinfo); - cinfo^.mem := NIL; { be safe if jpeg_destroy is called twice } - cinfo^.global_state := 0; { mark it destroyed } -end; - - -{ Convenience routines for allocating quantization and Huffman tables. - (Would jutils.c be a more reasonable place to put these?) } - - -{GLOBAL} -function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR; -var - tbl : JQUANT_TBL_PTR; -begin - tbl := JQUANT_TBL_PTR( - cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JQUANT_TBL)) - ); - tbl^.sent_table := FALSE; { make sure this is false in any new table } - jpeg_alloc_quant_table := tbl; -end; - - -{GLOBAL} -function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR; -var - tbl : JHUFF_TBL_PTR; -begin - tbl := JHUFF_TBL_PTR( - cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JHUFF_TBL)) - ); - tbl^.sent_table := FALSE; { make sure this is false in any new table } - jpeg_alloc_huff_table := tbl; -end; - -end. +unit imjcomapi; + +{ This file contains application interface routines that are used for both + compression and decompression. } + +{ Original: jcomapi.c; Copyright (C) 1994-1997, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib; + +{ Abort processing of a JPEG compression or decompression operation, + but don't destroy the object itself. } + +{GLOBAL} +procedure jpeg_abort (cinfo : j_common_ptr); + + +{ Destruction of a JPEG object. } + +{GLOBAL} +procedure jpeg_destroy (cinfo : j_common_ptr); + +{GLOBAL} +function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR; + +{GLOBAL} +function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR; + +implementation + +{ Abort processing of a JPEG compression or decompression operation, + but don't destroy the object itself. + + For this, we merely clean up all the nonpermanent memory pools. + Note that temp files (virtual arrays) are not allowed to belong to + the permanent pool, so we will be able to close all temp files here. + Closing a data source or destination, if necessary, is the application's + responsibility. } + + +{GLOBAL} +procedure jpeg_abort (cinfo : j_common_ptr); +var + pool : int; +begin + { Do nothing if called on a not-initialized or destroyed JPEG object. } + if (cinfo^.mem = NIL) then + exit; + + { Releasing pools in reverse order might help avoid fragmentation + with some (brain-damaged) malloc libraries. } + + for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT+1 do + begin + cinfo^.mem^.free_pool (cinfo, pool); + end; + + { Reset overall state for possible reuse of object } + if (cinfo^.is_decompressor) then + begin + cinfo^.global_state := DSTATE_START; + { Try to keep application from accessing now-deleted marker list. + A bit kludgy to do it here, but this is the most central place. } + j_decompress_ptr(cinfo)^.marker_list := NIL; + end + else + begin + cinfo^.global_state := CSTATE_START; + end; +end; + + +{ Destruction of a JPEG object. + + Everything gets deallocated except the master jpeg_compress_struct itself + and the error manager struct. Both of these are supplied by the application + and must be freed, if necessary, by the application. (Often they are on + the stack and so don't need to be freed anyway.) + Closing a data source or destination, if necessary, is the application's + responsibility. } + + +{GLOBAL} +procedure jpeg_destroy (cinfo : j_common_ptr); +begin + { We need only tell the memory manager to release everything. } + { NB: mem pointer is NIL if memory mgr failed to initialize. } + if (cinfo^.mem <> NIL) then + cinfo^.mem^.self_destruct (cinfo); + cinfo^.mem := NIL; { be safe if jpeg_destroy is called twice } + cinfo^.global_state := 0; { mark it destroyed } +end; + + +{ Convenience routines for allocating quantization and Huffman tables. + (Would jutils.c be a more reasonable place to put these?) } + + +{GLOBAL} +function jpeg_alloc_quant_table (cinfo : j_common_ptr) : JQUANT_TBL_PTR; +var + tbl : JQUANT_TBL_PTR; +begin + tbl := JQUANT_TBL_PTR( + cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JQUANT_TBL)) + ); + tbl^.sent_table := FALSE; { make sure this is false in any new table } + jpeg_alloc_quant_table := tbl; +end; + + +{GLOBAL} +function jpeg_alloc_huff_table (cinfo : j_common_ptr) : JHUFF_TBL_PTR; +var + tbl : JHUFF_TBL_PTR; +begin + tbl := JHUFF_TBL_PTR( + cinfo^.mem^.alloc_small (cinfo, JPOOL_PERMANENT, SIZEOF(JHUFF_TBL)) + ); + tbl^.sent_table := FALSE; { make sure this is false in any new table } + jpeg_alloc_huff_table := tbl; +end; + +end. diff --git a/Imaging/JpegLib/imjconfig.inc b/Imaging/JpegLib/imjconfig.inc index 91b3521..bf5a0cf 100644 --- a/Imaging/JpegLib/imjconfig.inc +++ b/Imaging/JpegLib/imjconfig.inc @@ -1,124 +1,126 @@ -{ ----------------------- JPEG_INTERNAL_OPTIONS ---------------------- } - - -{ These defines indicate whether to include various optional functions. - Undefining some of these symbols will produce a smaller but less capable - library. Note that you can leave certain source files out of the - compilation/linking process if you've #undef'd the corresponding symbols. - (You may HAVE to do that if your compiler doesn't like null source files.)} - - -{ Arithmetic coding is unsupported for legal reasons. Complaints to IBM. } - -{ Capability options common to encoder and decoder: } - -{$define DCT_ISLOW_SUPPORTED} { slow but accurate integer algorithm } -{$define DCT_IFAST_SUPPORTED} { faster, less accurate integer method } -{$define DCT_FLOAT_SUPPORTED} { floating-point: accurate, fast on fast HW } - -{ Encoder capability options: } - -{$undef C_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? } -{$define C_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? } -{$define C_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)} -{$define ENTROPY_OPT_SUPPORTED} { Optimization of entropy coding parms? } -{ Note: if you selected 12-bit data precision, it is dangerous to turn off - ENTROPY_OPT_SUPPORTED. The standard Huffman tables are only good for 8-bit - precision, so jchuff.c normally uses entropy optimization to compute - usable tables for higher precision. If you don't want to do optimization, - you'll have to supply different default Huffman tables. - The exact same statements apply for progressive JPEG: the default tables - don't work for progressive mode. (This may get fixed, however.) } - -{$define INPUT_SMOOTHING_SUPPORTED} { Input image smoothing option? } - -{ Decoder capability options: } - -{$undef D_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? } -{$define D_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? } -{$define D_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)} -{$define SAVE_MARKERS_SUPPORTED} { jpeg_save_markers() needed? } -{$define BLOCK_SMOOTHING_SUPPORTED} { Block smoothing? (Progressive only) } -{$define IDCT_SCALING_SUPPORTED} { Output rescaling via IDCT? } -{$undef UPSAMPLE_SCALING_SUPPORTED} { Output rescaling at upsample stage? } -{$define UPSAMPLE_MERGING_SUPPORTED} { Fast path for sloppy upsampling? } -{$define QUANT_1PASS_SUPPORTED} { 1-pass color quantization? } -{$define QUANT_2PASS_SUPPORTED} { 2-pass color quantization? } - -{ If you happen not to want the image transform support, disable it here } -{$define TRANSFORMS_SUPPORTED} - -{ more capability options later, no doubt } - -{$ifopt I+} {$define IOcheck} {$endif} - -{ ------------------------------------------------------------------------ } - -{$define USE_FMEM} { Borland has _fmemcpy() and _fmemset() } - -{$define FMEMCOPY} -{$define FMEMZERO} - -{$define DCTSIZE_IS_8} { e.g. unroll the inner loop } -{$define RIGHT_SHIFT_IS_UNSIGNED} -{$undef AVOID_TABLES} -{$undef FAST_DIVIDE} - -{$define BITS_IN_JSAMPLE_IS_8} - -{----------------------------------------------------------------} -{ for test of 12 bit JPEG code only. !! } -{-- $undef BITS_IN_JSAMPLE_IS_8} -{----------------------------------------------------------------} - -//{$define RGB_RED_IS_0} -{ !CHANGE: This must be defined for Delphi/Kylix/FPC } -{$define RGB_RED_IS_2} { RGB byte order } - - -{$define RGB_PIXELSIZE_IS_3} -{$define SLOW_SHIFT_32} -{$undef NO_ZERO_ROW_TEST} - -{$define USE_MSDOS_MEMMGR} { Define this if you use jmemdos.c } -{$define XMS_SUPPORTED} -{$define EMS_SUPPORTED} - -{$undef MEM_STATS} { Write out memory usage } -{$define AM_MEMORY_MANAGER} { we define jvirt_Xarray_control structs } - -{$undef FULL_MAIN_BUFFER_SUPPORTED} - -{$define PROGRESS_REPORT} -{$define TWO_FILE_COMMANDLINE} -{$undef BMP_SUPPORTED} -{$undef PPM_SUPPORTED} -{$undef GIF_SUPPORTED} -{$undef RLE_SUPPORTED} -{$undef TARGA_SUPPORTED} -{$define EXT_SWITCH} - -{$ifndef BITS_IN_JSAMPLE_IS_8} { for 12 bit samples } -{$undef BMP_SUPPORTED} -{$undef RLE_SUPPORTED} -{$undef TARGA_SUPPORTED} -{$endif} - - -{!CHANGE: Allowed only for Delphi} -{$undef BASM16} { for TP7 - use BASM for fast multiply } -{$ifdef Win32} - {$ifndef FPC} - {$define BASM} { jidctint with BASM for Delphi 2/3 } - {$undef RGB_RED_IS_0} { BGR byte order in JQUANT2 } - {$endif} -{$endif} - -{$ifdef FPC} - {$MODE DELPHI} -{$endif} - -{!CHANGE: Added this} -{$define Delphi_Stream} -{$Q-} - +{ ----------------------- JPEG_INTERNAL_OPTIONS ---------------------- } + + +{ These defines indicate whether to include various optional functions. + Undefining some of these symbols will produce a smaller but less capable + library. Note that you can leave certain source files out of the + compilation/linking process if you've #undef'd the corresponding symbols. + (You may HAVE to do that if your compiler doesn't like null source files.)} + + +{ Arithmetic coding is unsupported for legal reasons. Complaints to IBM. } + +{ Capability options common to encoder and decoder: } + +{$define DCT_ISLOW_SUPPORTED} { slow but accurate integer algorithm } +{$define DCT_IFAST_SUPPORTED} { faster, less accurate integer method } +{$define DCT_FLOAT_SUPPORTED} { floating-point: accurate, fast on fast HW } + +{ Encoder capability options: } + +{$undef C_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? } +{$define C_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? } +{$define C_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)} +{$define ENTROPY_OPT_SUPPORTED} { Optimization of entropy coding parms? } +{ Note: if you selected 12-bit data precision, it is dangerous to turn off + ENTROPY_OPT_SUPPORTED. The standard Huffman tables are only good for 8-bit + precision, so jchuff.c normally uses entropy optimization to compute + usable tables for higher precision. If you don't want to do optimization, + you'll have to supply different default Huffman tables. + The exact same statements apply for progressive JPEG: the default tables + don't work for progressive mode. (This may get fixed, however.) } + +{$define INPUT_SMOOTHING_SUPPORTED} { Input image smoothing option? } + +{ Decoder capability options: } + +{$undef D_ARITH_CODING_SUPPORTED} { Arithmetic coding back end? } +{$define D_MULTISCAN_FILES_SUPPORTED} { Multiple-scan JPEG files? } +{$define D_PROGRESSIVE_SUPPORTED} { Progressive JPEG? (Requires MULTISCAN)} +{$define SAVE_MARKERS_SUPPORTED} { jpeg_save_markers() needed? } +{$define BLOCK_SMOOTHING_SUPPORTED} { Block smoothing? (Progressive only) } +{$define IDCT_SCALING_SUPPORTED} { Output rescaling via IDCT? } +{$undef UPSAMPLE_SCALING_SUPPORTED} { Output rescaling at upsample stage? } +{$define UPSAMPLE_MERGING_SUPPORTED} { Fast path for sloppy upsampling? } +{$define QUANT_1PASS_SUPPORTED} { 1-pass color quantization? } +{$define QUANT_2PASS_SUPPORTED} { 2-pass color quantization? } + +{ If you happen not to want the image transform support, disable it here } +{$define TRANSFORMS_SUPPORTED} + +{ more capability options later, no doubt } + +{$ifopt I+} {$define IOcheck} {$endif} + +{ ------------------------------------------------------------------------ } + +{$define USE_FMEM} { Borland has _fmemcpy() and _fmemset() } + +{$define FMEMCOPY} +{$define FMEMZERO} + +{$define DCTSIZE_IS_8} { e.g. unroll the inner loop } +{$define RIGHT_SHIFT_IS_UNSIGNED} +{$undef AVOID_TABLES} +{$undef FAST_DIVIDE} + +{$define BITS_IN_JSAMPLE_IS_8} + +{----------------------------------------------------------------} +{ for test of 12 bit JPEG code only. !! } +{-- $undef BITS_IN_JSAMPLE_IS_8} +{----------------------------------------------------------------} + +//{$define RGB_RED_IS_0} +{ !CHANGE: This must be defined for Delphi/Kylix/FPC } +{$define RGB_RED_IS_2} { RGB byte order } + + +{$define RGB_PIXELSIZE_IS_3} +{$define SLOW_SHIFT_32} +{$undef NO_ZERO_ROW_TEST} + +{$define USE_MSDOS_MEMMGR} { Define this if you use jmemdos.c } +{$define XMS_SUPPORTED} +{$define EMS_SUPPORTED} + +{$undef MEM_STATS} { Write out memory usage } +{$define AM_MEMORY_MANAGER} { we define jvirt_Xarray_control structs } + +{$undef FULL_MAIN_BUFFER_SUPPORTED} + +{$define PROGRESS_REPORT} +{$define TWO_FILE_COMMANDLINE} +{$undef BMP_SUPPORTED} +{$undef PPM_SUPPORTED} +{$undef GIF_SUPPORTED} +{$undef RLE_SUPPORTED} +{$undef TARGA_SUPPORTED} +{$define EXT_SWITCH} + +{$ifndef BITS_IN_JSAMPLE_IS_8} { for 12 bit samples } +{$undef BMP_SUPPORTED} +{$undef RLE_SUPPORTED} +{$undef TARGA_SUPPORTED} +{$endif} + + +{!CHANGE: Allowed only for Delphi} +{$undef BASM16} { for TP7 - use BASM for fast multiply } +{$ifdef Win32} + {$ifndef FPC} + {$define BASM} { jidctint with BASM for Delphi 2/3 } + {$undef RGB_RED_IS_0} { BGR byte order in JQUANT2 } + {$endif} +{$endif} + +{$ifdef FPC} + {$MODE DELPHI} +{$endif} + +{!CHANGE: Added this} +{$define Delphi_Stream} +{$Q-} +{$MINENUMSIZE 4} +{$ALIGN 8} + diff --git a/Imaging/JpegLib/imjcparam.pas b/Imaging/JpegLib/imjcparam.pas index 345fc32..c971e99 100644 --- a/Imaging/JpegLib/imjcparam.pas +++ b/Imaging/JpegLib/imjcparam.pas @@ -1,701 +1,701 @@ -unit imjcparam; - -{ This file contains optional default-setting code for the JPEG compressor. - Applications do not have to use this file, but those that don't use it - must know a lot more about the innards of the JPEG code. } - -{ Original: jcparam.c ; Copyright (C) 1991-1998, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjcomapi, - imjpeglib; - -{ Quantization table setup routines } - -{GLOBAL} -procedure jpeg_add_quant_table (cinfo : j_compress_ptr; - which_tbl : int; - const basic_table : array of uInt; - scale_factor : int; - force_baseline : boolean); - -{GLOBAL} -procedure jpeg_set_linear_quality (cinfo : j_compress_ptr; - scale_factor : int; - force_baseline : boolean); -{ Set or change the 'quality' (quantization) setting, using default tables - and a straight percentage-scaling quality scale. In most cases it's better - to use jpeg_set_quality (below); this entry point is provided for - applications that insist on a linear percentage scaling. } - -{GLOBAL} -function jpeg_quality_scaling (quality : int) : int; -{ Convert a user-specified quality rating to a percentage scaling factor - for an underlying quantization table, using our recommended scaling curve. - The input 'quality' factor should be 0 (terrible) to 100 (very good). } - -{GLOBAL} -procedure jpeg_set_quality (cinfo : j_compress_ptr; - quality : int; - force_baseline : boolean); -{ Set or change the 'quality' (quantization) setting, using default tables. - This is the standard quality-adjusting entry point for typical user - interfaces; only those who want detailed control over quantization tables - would use the preceding three routines directly. } - -{GLOBAL} -procedure jpeg_set_defaults (cinfo : j_compress_ptr); - -{ Create a recommended progressive-JPEG script. - cinfo^.num_components and cinfo^.jpeg_color_space must be correct. } - -{ Set the JPEG colorspace, and choose colorspace-dependent default values. } - -{GLOBAL} -procedure jpeg_set_colorspace (cinfo : j_compress_ptr; - colorspace : J_COLOR_SPACE); - -{ Select an appropriate JPEG colorspace for in_color_space. } - -{GLOBAL} -procedure jpeg_default_colorspace (cinfo : j_compress_ptr); - -{GLOBAL} -procedure jpeg_simple_progression (cinfo : j_compress_ptr); - - -implementation - -{ Quantization table setup routines } - -{GLOBAL} -procedure jpeg_add_quant_table (cinfo : j_compress_ptr; - which_tbl : int; - const basic_table : array of uInt; - scale_factor : int; - force_baseline : boolean); -{ Define a quantization table equal to the basic_table times - a scale factor (given as a percentage). - If force_baseline is TRUE, the computed quantization table entries - are limited to 1..255 for JPEG baseline compatibility. } -var - qtblptr :^JQUANT_TBL_PTR; - i : int; - temp : long; -begin - { Safety check to ensure start_compress not called yet. } - if (cinfo^.global_state <> CSTATE_START) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - - if (which_tbl < 0) or (which_tbl >= NUM_QUANT_TBLS) then - ERREXIT1(j_common_ptr(cinfo), JERR_DQT_INDEX, which_tbl); - - qtblptr := @(cinfo^.quant_tbl_ptrs[which_tbl]); - - if (qtblptr^ = NIL) then - qtblptr^ := jpeg_alloc_quant_table(j_common_ptr(cinfo)); - - for i := 0 to pred(DCTSIZE2) do - begin - temp := (long(basic_table[i]) * scale_factor + long(50)) div long(100); - { limit the values to the valid range } - if (temp <= long(0)) then - temp := long(1); - if (temp > long(32767)) then - temp := long(32767); { max quantizer needed for 12 bits } - if (force_baseline) and (temp > long(255)) then - temp := long(255); { limit to baseline range if requested } - (qtblptr^)^.quantval[i] := UINT16 (temp); - end; - - { Initialize sent_table FALSE so table will be written to JPEG file. } - (qtblptr^)^.sent_table := FALSE; -end; - - -{GLOBAL} -procedure jpeg_set_linear_quality (cinfo : j_compress_ptr; - scale_factor : int; - force_baseline : boolean); -{ Set or change the 'quality' (quantization) setting, using default tables - and a straight percentage-scaling quality scale. In most cases it's better - to use jpeg_set_quality (below); this entry point is provided for - applications that insist on a linear percentage scaling. } - -{ These are the sample quantization tables given in JPEG spec section K.1. - The spec says that the values given produce "good" quality, and - when divided by 2, "very good" quality. } - -const - std_luminance_quant_tbl : array[0..DCTSIZE2-1] of uInt = - (16, 11, 10, 16, 24, 40, 51, 61, - 12, 12, 14, 19, 26, 58, 60, 55, - 14, 13, 16, 24, 40, 57, 69, 56, - 14, 17, 22, 29, 51, 87, 80, 62, - 18, 22, 37, 56, 68, 109, 103, 77, - 24, 35, 55, 64, 81, 104, 113, 92, - 49, 64, 78, 87, 103, 121, 120, 101, - 72, 92, 95, 98, 112, 100, 103, 99); - -const - std_chrominance_quant_tbl : array[0..DCTSIZE2-1] of uInt = - (17, 18, 24, 47, 99, 99, 99, 99, - 18, 21, 26, 66, 99, 99, 99, 99, - 24, 26, 56, 99, 99, 99, 99, 99, - 47, 66, 99, 99, 99, 99, 99, 99, - 99, 99, 99, 99, 99, 99, 99, 99, - 99, 99, 99, 99, 99, 99, 99, 99, - 99, 99, 99, 99, 99, 99, 99, 99, - 99, 99, 99, 99, 99, 99, 99, 99); -begin - { Set up two quantization tables using the specified scaling } - jpeg_add_quant_table(cinfo, 0, std_luminance_quant_tbl, - scale_factor, force_baseline); - jpeg_add_quant_table(cinfo, 1, std_chrominance_quant_tbl, - scale_factor, force_baseline); -end; - - -{GLOBAL} -function jpeg_quality_scaling (quality : int) : int; -{ Convert a user-specified quality rating to a percentage scaling factor - for an underlying quantization table, using our recommended scaling curve. - The input 'quality' factor should be 0 (terrible) to 100 (very good). } -begin - { Safety limit on quality factor. Convert 0 to 1 to avoid zero divide. } - if (quality <= 0) then - quality := 1; - if (quality > 100) then - quality := 100; - - { The basic table is used as-is (scaling 100) for a quality of 50. - Qualities 50..100 are converted to scaling percentage 200 - 2*Q; - note that at Q=100 the scaling is 0, which will cause jpeg_add_quant_table - to make all the table entries 1 (hence, minimum quantization loss). - Qualities 1..50 are converted to scaling percentage 5000/Q. } - if (quality < 50) then - quality := 5000 div quality - else - quality := 200 - quality*2; - - jpeg_quality_scaling := quality; -end; - - -{GLOBAL} -procedure jpeg_set_quality (cinfo : j_compress_ptr; - quality : int; - force_baseline : boolean); -{ Set or change the 'quality' (quantization) setting, using default tables. - This is the standard quality-adjusting entry point for typical user - interfaces; only those who want detailed control over quantization tables - would use the preceding three routines directly. } -begin - { Convert user 0-100 rating to percentage scaling } - quality := jpeg_quality_scaling(quality); - - { Set up standard quality tables } - jpeg_set_linear_quality(cinfo, quality, force_baseline); -end; - - -{ Huffman table setup routines } - -{LOCAL} -procedure add_huff_table (cinfo : j_compress_ptr; - var htblptr : JHUFF_TBL_PTR; - var bits : array of UINT8; - var val : array of UINT8); -{ Define a Huffman table } -var - nsymbols, len : int; -begin - if (htblptr = NIL) then - htblptr := jpeg_alloc_huff_table(j_common_ptr(cinfo)); - - { Copy the number-of-symbols-of-each-code-length counts } - MEMCOPY(@htblptr^.bits, @bits, SIZEOF(htblptr^.bits)); - - - { Validate the counts. We do this here mainly so we can copy the right - number of symbols from the val[] array, without risking marching off - the end of memory. jchuff.c will do a more thorough test later. } - - nsymbols := 0; - for len := 1 to 16 do - Inc(nsymbols, bits[len]); - if (nsymbols < 1) or (nsymbols > 256) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); - - MEMCOPY(@htblptr^.huffval, @val, nsymbols * SIZEOF(UINT8)); - - { Initialize sent_table FALSE so table will be written to JPEG file. } - (htblptr)^.sent_table := FALSE; -end; - - -{$J+} -{LOCAL} -procedure std_huff_tables (cinfo : j_compress_ptr); -{ Set up the standard Huffman tables (cf. JPEG standard section K.3) } -{ IMPORTANT: these are only valid for 8-bit data precision! } - const bits_dc_luminance : array[0..17-1] of UINT8 = - ({ 0-base } 0, 0, 1, 5, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0); - const val_dc_luminance : array[0..11] of UINT8 = - (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11); - - const bits_dc_chrominance : array[0..17-1] of UINT8 = - ( { 0-base } 0, 0, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 ); - const val_dc_chrominance : array[0..11] of UINT8 = - ( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11 ); - - const bits_ac_luminance : array[0..17-1] of UINT8 = - ( { 0-base } 0, 0, 2, 1, 3, 3, 2, 4, 3, 5, 5, 4, 4, 0, 0, 1, $7d ); - const val_ac_luminance : array[0..161] of UINT8 = - ( $01, $02, $03, $00, $04, $11, $05, $12, - $21, $31, $41, $06, $13, $51, $61, $07, - $22, $71, $14, $32, $81, $91, $a1, $08, - $23, $42, $b1, $c1, $15, $52, $d1, $f0, - $24, $33, $62, $72, $82, $09, $0a, $16, - $17, $18, $19, $1a, $25, $26, $27, $28, - $29, $2a, $34, $35, $36, $37, $38, $39, - $3a, $43, $44, $45, $46, $47, $48, $49, - $4a, $53, $54, $55, $56, $57, $58, $59, - $5a, $63, $64, $65, $66, $67, $68, $69, - $6a, $73, $74, $75, $76, $77, $78, $79, - $7a, $83, $84, $85, $86, $87, $88, $89, - $8a, $92, $93, $94, $95, $96, $97, $98, - $99, $9a, $a2, $a3, $a4, $a5, $a6, $a7, - $a8, $a9, $aa, $b2, $b3, $b4, $b5, $b6, - $b7, $b8, $b9, $ba, $c2, $c3, $c4, $c5, - $c6, $c7, $c8, $c9, $ca, $d2, $d3, $d4, - $d5, $d6, $d7, $d8, $d9, $da, $e1, $e2, - $e3, $e4, $e5, $e6, $e7, $e8, $e9, $ea, - $f1, $f2, $f3, $f4, $f5, $f6, $f7, $f8, - $f9, $fa ); - - const bits_ac_chrominance : array[0..17-1] of UINT8 = - ( { 0-base } 0, 0, 2, 1, 2, 4, 4, 3, 4, 7, 5, 4, 4, 0, 1, 2, $77 ); - const val_ac_chrominance : array[0..161] of UINT8 = - ( $00, $01, $02, $03, $11, $04, $05, $21, - $31, $06, $12, $41, $51, $07, $61, $71, - $13, $22, $32, $81, $08, $14, $42, $91, - $a1, $b1, $c1, $09, $23, $33, $52, $f0, - $15, $62, $72, $d1, $0a, $16, $24, $34, - $e1, $25, $f1, $17, $18, $19, $1a, $26, - $27, $28, $29, $2a, $35, $36, $37, $38, - $39, $3a, $43, $44, $45, $46, $47, $48, - $49, $4a, $53, $54, $55, $56, $57, $58, - $59, $5a, $63, $64, $65, $66, $67, $68, - $69, $6a, $73, $74, $75, $76, $77, $78, - $79, $7a, $82, $83, $84, $85, $86, $87, - $88, $89, $8a, $92, $93, $94, $95, $96, - $97, $98, $99, $9a, $a2, $a3, $a4, $a5, - $a6, $a7, $a8, $a9, $aa, $b2, $b3, $b4, - $b5, $b6, $b7, $b8, $b9, $ba, $c2, $c3, - $c4, $c5, $c6, $c7, $c8, $c9, $ca, $d2, - $d3, $d4, $d5, $d6, $d7, $d8, $d9, $da, - $e2, $e3, $e4, $e5, $e6, $e7, $e8, $e9, - $ea, $f2, $f3, $f4, $f5, $f6, $f7, $f8, - $f9, $fa ); -begin - add_huff_table(cinfo, cinfo^.dc_huff_tbl_ptrs[0], - bits_dc_luminance, val_dc_luminance); - add_huff_table(cinfo, cinfo^.ac_huff_tbl_ptrs[0], - bits_ac_luminance, val_ac_luminance); - add_huff_table(cinfo, cinfo^.dc_huff_tbl_ptrs[1], - bits_dc_chrominance, val_dc_chrominance); - add_huff_table(cinfo, cinfo^.ac_huff_tbl_ptrs[1], - bits_ac_chrominance, val_ac_chrominance); -end; - - -{ Default parameter setup for compression. - - Applications that don't choose to use this routine must do their - own setup of all these parameters. Alternately, you can call this - to establish defaults and then alter parameters selectively. This - is the recommended approach since, if we add any new parameters, - your code will still work (they'll be set to reasonable defaults). } - -{GLOBAL} -procedure jpeg_set_defaults (cinfo : j_compress_ptr); -var - i : int; -begin - { Safety check to ensure start_compress not called yet. } - if (cinfo^.global_state <> CSTATE_START) then - ERREXIT1(J_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - - { Allocate comp_info array large enough for maximum component count. - Array is made permanent in case application wants to compress - multiple images at same param settings. } - - if (cinfo^.comp_info = NIL) then - cinfo^.comp_info := jpeg_component_info_list_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT, - MAX_COMPONENTS * SIZEOF(jpeg_component_info)) ); - - { Initialize everything not dependent on the color space } - - cinfo^.data_precision := BITS_IN_JSAMPLE; - { Set up two quantization tables using default quality of 75 } - jpeg_set_quality(cinfo, 75, TRUE); - { Set up two Huffman tables } - std_huff_tables(cinfo); - - { Initialize default arithmetic coding conditioning } - for i := 0 to pred(NUM_ARITH_TBLS) do - begin - cinfo^.arith_dc_L[i] := 0; - cinfo^.arith_dc_U[i] := 1; - cinfo^.arith_ac_K[i] := 5; - end; - - { Default is no multiple-scan output } - cinfo^.scan_info := NIL; - cinfo^.num_scans := 0; - - { Expect normal source image, not raw downsampled data } - cinfo^.raw_data_in := FALSE; - - { Use Huffman coding, not arithmetic coding, by default } - cinfo^.arith_code := FALSE; - - { By default, don't do extra passes to optimize entropy coding } - cinfo^.optimize_coding := FALSE; - { The standard Huffman tables are only valid for 8-bit data precision. - If the precision is higher, force optimization on so that usable - tables will be computed. This test can be removed if default tables - are supplied that are valid for the desired precision. } - - if (cinfo^.data_precision > 8) then - cinfo^.optimize_coding := TRUE; - - { By default, use the simpler non-cosited sampling alignment } - cinfo^.CCIR601_sampling := FALSE; - - { No input smoothing } - cinfo^.smoothing_factor := 0; - - { DCT algorithm preference } - cinfo^.dct_method := JDCT_DEFAULT; - - { No restart markers } - cinfo^.restart_interval := 0; - cinfo^.restart_in_rows := 0; - - { Fill in default JFIF marker parameters. Note that whether the marker - will actually be written is determined by jpeg_set_colorspace. - - By default, the library emits JFIF version code 1.01. - An application that wants to emit JFIF 1.02 extension markers should set - JFIF_minor_version to 2. We could probably get away with just defaulting - to 1.02, but there may still be some decoders in use that will complain - about that; saying 1.01 should minimize compatibility problems. } - - cinfo^.JFIF_major_version := 1; { Default JFIF version = 1.01 } - cinfo^.JFIF_minor_version := 1; - cinfo^.density_unit := 0; { Pixel size is unknown by default } - cinfo^.X_density := 1; { Pixel aspect ratio is square by default } - cinfo^.Y_density := 1; - - { Choose JPEG colorspace based on input space, set defaults accordingly } - - jpeg_default_colorspace(cinfo); -end; - - -{ Select an appropriate JPEG colorspace for in_color_space. } - -{GLOBAL} -procedure jpeg_default_colorspace (cinfo : j_compress_ptr); -begin - case (cinfo^.in_color_space) of - JCS_GRAYSCALE: - jpeg_set_colorspace(cinfo, JCS_GRAYSCALE); - JCS_RGB: - jpeg_set_colorspace(cinfo, JCS_YCbCr); - JCS_YCbCr: - jpeg_set_colorspace(cinfo, JCS_YCbCr); - JCS_CMYK: - jpeg_set_colorspace(cinfo, JCS_CMYK); { By default, no translation } - JCS_YCCK: - jpeg_set_colorspace(cinfo, JCS_YCCK); - JCS_UNKNOWN: - jpeg_set_colorspace(cinfo, JCS_UNKNOWN); - else - ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); - end; -end; - - -{ Set the JPEG colorspace, and choose colorspace-dependent default values. } - -{GLOBAL} -procedure jpeg_set_colorspace (cinfo : j_compress_ptr; - colorspace : J_COLOR_SPACE); - { macro } - procedure SET_COMP(index,id,hsamp,vsamp,quant,dctbl,actbl : int); - begin - with cinfo^.comp_info^[index] do - begin - component_id := (id); - h_samp_factor := (hsamp); - v_samp_factor := (vsamp); - quant_tbl_no := (quant); - dc_tbl_no := (dctbl); - ac_tbl_no := (actbl); - end; - end; - -var - ci : int; -begin - { Safety check to ensure start_compress not called yet. } - if (cinfo^.global_state <> CSTATE_START) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - - { For all colorspaces, we use Q and Huff tables 0 for luminance components, - tables 1 for chrominance components. } - - cinfo^.jpeg_color_space := colorspace; - - cinfo^.write_JFIF_header := FALSE; { No marker for non-JFIF colorspaces } - cinfo^.write_Adobe_marker := FALSE; { write no Adobe marker by default } - - case (colorspace) of - JCS_GRAYSCALE: - begin - cinfo^.write_JFIF_header := TRUE; { Write a JFIF marker } - cinfo^.num_components := 1; - { JFIF specifies component ID 1 } - SET_COMP(0, 1, 1,1, 0, 0,0); - end; - JCS_RGB: - begin - cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag RGB } - cinfo^.num_components := 3; - SET_COMP(0, $52 { 'R' }, 1,1, 0, 0,0); - SET_COMP(1, $47 { 'G' }, 1,1, 0, 0,0); - SET_COMP(2, $42 { 'B' }, 1,1, 0, 0,0); - end; - JCS_YCbCr: - begin - cinfo^.write_JFIF_header := TRUE; { Write a JFIF marker } - cinfo^.num_components := 3; - { JFIF specifies component IDs 1,2,3 } - { We default to 2x2 subsamples of chrominance } - SET_COMP(0, 1, 2,2, 0, 0,0); - SET_COMP(1, 2, 1,1, 1, 1,1); - SET_COMP(2, 3, 1,1, 1, 1,1); - end; - JCS_CMYK: - begin - cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag CMYK } - cinfo^.num_components := 4; - SET_COMP(0, $43 { 'C' }, 1,1, 0, 0,0); - SET_COMP(1, $4D { 'M' }, 1,1, 0, 0,0); - SET_COMP(2, $59 { 'Y' }, 1,1, 0, 0,0); - SET_COMP(3, $4B { 'K' }, 1,1, 0, 0,0); - end; - JCS_YCCK: - begin - cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag YCCK } - cinfo^.num_components := 4; - SET_COMP(0, 1, 2,2, 0, 0,0); - SET_COMP(1, 2, 1,1, 1, 1,1); - SET_COMP(2, 3, 1,1, 1, 1,1); - SET_COMP(3, 4, 2,2, 0, 0,0); - end; - JCS_UNKNOWN: - begin - cinfo^.num_components := cinfo^.input_components; - if (cinfo^.num_components < 1) - or (cinfo^.num_components > MAX_COMPONENTS) then - ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, - cinfo^.num_components, MAX_COMPONENTS); - for ci := 0 to pred(cinfo^.num_components) do - begin - SET_COMP(ci, ci, 1,1, 0, 0,0); - end; - end; - else - ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); - end; -end; - - -{$ifdef C_PROGRESSIVE_SUPPORTED} - -{LOCAL} -function fill_a_scan (scanptr : jpeg_scan_info_ptr; - ci : int; Ss : int; - Se : int; Ah : int; - Al : int) : jpeg_scan_info_ptr; -{ Support routine: generate one scan for specified component } -begin - scanptr^.comps_in_scan := 1; - scanptr^.component_index[0] := ci; - scanptr^.Ss := Ss; - scanptr^.Se := Se; - scanptr^.Ah := Ah; - scanptr^.Al := Al; - Inc(scanptr); - fill_a_scan := scanptr; -end; - -{LOCAL} -function fill_scans (scanptr : jpeg_scan_info_ptr; - ncomps : int; - Ss : int; Se : int; - Ah : int; Al : int) : jpeg_scan_info_ptr; -{ Support routine: generate one scan for each component } -var - ci : int; -begin - - for ci := 0 to pred(ncomps) do - begin - scanptr^.comps_in_scan := 1; - scanptr^.component_index[0] := ci; - scanptr^.Ss := Ss; - scanptr^.Se := Se; - scanptr^.Ah := Ah; - scanptr^.Al := Al; - Inc(scanptr); - end; - fill_scans := scanptr; -end; - -{LOCAL} -function fill_dc_scans (scanptr : jpeg_scan_info_ptr; - ncomps : int; - Ah : int; Al : int) : jpeg_scan_info_ptr; -{ Support routine: generate interleaved DC scan if possible, else N scans } -var - ci : int; -begin - - if (ncomps <= MAX_COMPS_IN_SCAN) then - begin - { Single interleaved DC scan } - scanptr^.comps_in_scan := ncomps; - for ci := 0 to pred(ncomps) do - scanptr^.component_index[ci] := ci; - scanptr^.Ss := 0; - scanptr^.Se := 0; - scanptr^.Ah := Ah; - scanptr^.Al := Al; - Inc(scanptr); - end - else - begin - { Noninterleaved DC scan for each component } - scanptr := fill_scans(scanptr, ncomps, 0, 0, Ah, Al); - end; - fill_dc_scans := scanptr; -end; - - -{ Create a recommended progressive-JPEG script. - cinfo^.num_components and cinfo^.jpeg_color_space must be correct. } - -{GLOBAL} -procedure jpeg_simple_progression (cinfo : j_compress_ptr); -var - ncomps : int; - nscans : int; - scanptr : jpeg_scan_info_ptr; -begin - ncomps := cinfo^.num_components; - - { Safety check to ensure start_compress not called yet. } - if (cinfo^.global_state <> CSTATE_START) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - - { Figure space needed for script. Calculation must match code below! } - if (ncomps = 3) and (cinfo^.jpeg_color_space = JCS_YCbCr) then - begin - { Custom script for YCbCr color images. } - nscans := 10; - end - else - begin - { All-purpose script for other color spaces. } - if (ncomps > MAX_COMPS_IN_SCAN) then - nscans := 6 * ncomps { 2 DC + 4 AC scans per component } - else - nscans := 2 + 4 * ncomps; { 2 DC scans; 4 AC scans per component } - end; - - { Allocate space for script. - We need to put it in the permanent pool in case the application performs - multiple compressions without changing the settings. To avoid a memory - leak if jpeg_simple_progression is called repeatedly for the same JPEG - object, we try to re-use previously allocated space, and we allocate - enough space to handle YCbCr even if initially asked for grayscale. } - - if (cinfo^.script_space = NIL) or (cinfo^.script_space_size < nscans) then - begin - if nscans > 10 then - cinfo^.script_space_size := nscans - else - cinfo^.script_space_size := 10; - - cinfo^.script_space := jpeg_scan_info_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT, - cinfo^.script_space_size * SIZEOF(jpeg_scan_info)) ); - end; - scanptr := cinfo^.script_space; - - cinfo^.scan_info := scanptr; - cinfo^.num_scans := nscans; - - if (ncomps = 3) and (cinfo^.jpeg_color_space = JCS_YCbCr) then - begin - { Custom script for YCbCr color images. } - { Initial DC scan } - scanptr := fill_dc_scans(scanptr, ncomps, 0, 1); - { Initial AC scan: get some luma data out in a hurry } - scanptr := fill_a_scan(scanptr, 0, 1, 5, 0, 2); - { Chroma data is too small to be worth expending many scans on } - scanptr := fill_a_scan(scanptr, 2, 1, 63, 0, 1); - scanptr := fill_a_scan(scanptr, 1, 1, 63, 0, 1); - { Complete spectral selection for luma AC } - scanptr := fill_a_scan(scanptr, 0, 6, 63, 0, 2); - { Refine next bit of luma AC } - scanptr := fill_a_scan(scanptr, 0, 1, 63, 2, 1); - { Finish DC successive approximation } - scanptr := fill_dc_scans(scanptr, ncomps, 1, 0); - { Finish AC successive approximation } - scanptr := fill_a_scan(scanptr, 2, 1, 63, 1, 0); - scanptr := fill_a_scan(scanptr, 1, 1, 63, 1, 0); - { Luma bottom bit comes last since it's usually largest scan } - scanptr := fill_a_scan(scanptr, 0, 1, 63, 1, 0); - end - else - begin - { All-purpose script for other color spaces. } - { Successive approximation first pass } - scanptr := fill_dc_scans(scanptr, ncomps, 0, 1); - scanptr := fill_scans(scanptr, ncomps, 1, 5, 0, 2); - scanptr := fill_scans(scanptr, ncomps, 6, 63, 0, 2); - { Successive approximation second pass } - scanptr := fill_scans(scanptr, ncomps, 1, 63, 2, 1); - { Successive approximation final pass } - scanptr := fill_dc_scans(scanptr, ncomps, 1, 0); - scanptr := fill_scans(scanptr, ncomps, 1, 63, 1, 0); - end; -end; - -{$endif} -end. +unit imjcparam; + +{ This file contains optional default-setting code for the JPEG compressor. + Applications do not have to use this file, but those that don't use it + must know a lot more about the innards of the JPEG code. } + +{ Original: jcparam.c ; Copyright (C) 1991-1998, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjcomapi, + imjpeglib; + +{ Quantization table setup routines } + +{GLOBAL} +procedure jpeg_add_quant_table (cinfo : j_compress_ptr; + which_tbl : int; + const basic_table : array of uInt; + scale_factor : int; + force_baseline : boolean); + +{GLOBAL} +procedure jpeg_set_linear_quality (cinfo : j_compress_ptr; + scale_factor : int; + force_baseline : boolean); +{ Set or change the 'quality' (quantization) setting, using default tables + and a straight percentage-scaling quality scale. In most cases it's better + to use jpeg_set_quality (below); this entry point is provided for + applications that insist on a linear percentage scaling. } + +{GLOBAL} +function jpeg_quality_scaling (quality : int) : int; +{ Convert a user-specified quality rating to a percentage scaling factor + for an underlying quantization table, using our recommended scaling curve. + The input 'quality' factor should be 0 (terrible) to 100 (very good). } + +{GLOBAL} +procedure jpeg_set_quality (cinfo : j_compress_ptr; + quality : int; + force_baseline : boolean); +{ Set or change the 'quality' (quantization) setting, using default tables. + This is the standard quality-adjusting entry point for typical user + interfaces; only those who want detailed control over quantization tables + would use the preceding three routines directly. } + +{GLOBAL} +procedure jpeg_set_defaults (cinfo : j_compress_ptr); + +{ Create a recommended progressive-JPEG script. + cinfo^.num_components and cinfo^.jpeg_color_space must be correct. } + +{ Set the JPEG colorspace, and choose colorspace-dependent default values. } + +{GLOBAL} +procedure jpeg_set_colorspace (cinfo : j_compress_ptr; + colorspace : J_COLOR_SPACE); + +{ Select an appropriate JPEG colorspace for in_color_space. } + +{GLOBAL} +procedure jpeg_default_colorspace (cinfo : j_compress_ptr); + +{GLOBAL} +procedure jpeg_simple_progression (cinfo : j_compress_ptr); + + +implementation + +{ Quantization table setup routines } + +{GLOBAL} +procedure jpeg_add_quant_table (cinfo : j_compress_ptr; + which_tbl : int; + const basic_table : array of uInt; + scale_factor : int; + force_baseline : boolean); +{ Define a quantization table equal to the basic_table times + a scale factor (given as a percentage). + If force_baseline is TRUE, the computed quantization table entries + are limited to 1..255 for JPEG baseline compatibility. } +var + qtblptr :^JQUANT_TBL_PTR; + i : int; + temp : long; +begin + { Safety check to ensure start_compress not called yet. } + if (cinfo^.global_state <> CSTATE_START) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + + if (which_tbl < 0) or (which_tbl >= NUM_QUANT_TBLS) then + ERREXIT1(j_common_ptr(cinfo), JERR_DQT_INDEX, which_tbl); + + qtblptr := @(cinfo^.quant_tbl_ptrs[which_tbl]); + + if (qtblptr^ = NIL) then + qtblptr^ := jpeg_alloc_quant_table(j_common_ptr(cinfo)); + + for i := 0 to pred(DCTSIZE2) do + begin + temp := (long(basic_table[i]) * scale_factor + long(50)) div long(100); + { limit the values to the valid range } + if (temp <= long(0)) then + temp := long(1); + if (temp > long(32767)) then + temp := long(32767); { max quantizer needed for 12 bits } + if (force_baseline) and (temp > long(255)) then + temp := long(255); { limit to baseline range if requested } + (qtblptr^)^.quantval[i] := UINT16 (temp); + end; + + { Initialize sent_table FALSE so table will be written to JPEG file. } + (qtblptr^)^.sent_table := FALSE; +end; + + +{GLOBAL} +procedure jpeg_set_linear_quality (cinfo : j_compress_ptr; + scale_factor : int; + force_baseline : boolean); +{ Set or change the 'quality' (quantization) setting, using default tables + and a straight percentage-scaling quality scale. In most cases it's better + to use jpeg_set_quality (below); this entry point is provided for + applications that insist on a linear percentage scaling. } + +{ These are the sample quantization tables given in JPEG spec section K.1. + The spec says that the values given produce "good" quality, and + when divided by 2, "very good" quality. } + +const + std_luminance_quant_tbl : array[0..DCTSIZE2-1] of uInt = + (16, 11, 10, 16, 24, 40, 51, 61, + 12, 12, 14, 19, 26, 58, 60, 55, + 14, 13, 16, 24, 40, 57, 69, 56, + 14, 17, 22, 29, 51, 87, 80, 62, + 18, 22, 37, 56, 68, 109, 103, 77, + 24, 35, 55, 64, 81, 104, 113, 92, + 49, 64, 78, 87, 103, 121, 120, 101, + 72, 92, 95, 98, 112, 100, 103, 99); + +const + std_chrominance_quant_tbl : array[0..DCTSIZE2-1] of uInt = + (17, 18, 24, 47, 99, 99, 99, 99, + 18, 21, 26, 66, 99, 99, 99, 99, + 24, 26, 56, 99, 99, 99, 99, 99, + 47, 66, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99, + 99, 99, 99, 99, 99, 99, 99, 99); +begin + { Set up two quantization tables using the specified scaling } + jpeg_add_quant_table(cinfo, 0, std_luminance_quant_tbl, + scale_factor, force_baseline); + jpeg_add_quant_table(cinfo, 1, std_chrominance_quant_tbl, + scale_factor, force_baseline); +end; + + +{GLOBAL} +function jpeg_quality_scaling (quality : int) : int; +{ Convert a user-specified quality rating to a percentage scaling factor + for an underlying quantization table, using our recommended scaling curve. + The input 'quality' factor should be 0 (terrible) to 100 (very good). } +begin + { Safety limit on quality factor. Convert 0 to 1 to avoid zero divide. } + if (quality <= 0) then + quality := 1; + if (quality > 100) then + quality := 100; + + { The basic table is used as-is (scaling 100) for a quality of 50. + Qualities 50..100 are converted to scaling percentage 200 - 2*Q; + note that at Q=100 the scaling is 0, which will cause jpeg_add_quant_table + to make all the table entries 1 (hence, minimum quantization loss). + Qualities 1..50 are converted to scaling percentage 5000/Q. } + if (quality < 50) then + quality := 5000 div quality + else + quality := 200 - quality*2; + + jpeg_quality_scaling := quality; +end; + + +{GLOBAL} +procedure jpeg_set_quality (cinfo : j_compress_ptr; + quality : int; + force_baseline : boolean); +{ Set or change the 'quality' (quantization) setting, using default tables. + This is the standard quality-adjusting entry point for typical user + interfaces; only those who want detailed control over quantization tables + would use the preceding three routines directly. } +begin + { Convert user 0-100 rating to percentage scaling } + quality := jpeg_quality_scaling(quality); + + { Set up standard quality tables } + jpeg_set_linear_quality(cinfo, quality, force_baseline); +end; + + +{ Huffman table setup routines } + +{LOCAL} +procedure add_huff_table (cinfo : j_compress_ptr; + var htblptr : JHUFF_TBL_PTR; + var bits : array of UINT8; + var val : array of UINT8); +{ Define a Huffman table } +var + nsymbols, len : int; +begin + if (htblptr = NIL) then + htblptr := jpeg_alloc_huff_table(j_common_ptr(cinfo)); + + { Copy the number-of-symbols-of-each-code-length counts } + MEMCOPY(@htblptr^.bits, @bits, SIZEOF(htblptr^.bits)); + + + { Validate the counts. We do this here mainly so we can copy the right + number of symbols from the val[] array, without risking marching off + the end of memory. jchuff.c will do a more thorough test later. } + + nsymbols := 0; + for len := 1 to 16 do + Inc(nsymbols, bits[len]); + if (nsymbols < 1) or (nsymbols > 256) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); + + MEMCOPY(@htblptr^.huffval, @val, nsymbols * SIZEOF(UINT8)); + + { Initialize sent_table FALSE so table will be written to JPEG file. } + (htblptr)^.sent_table := FALSE; +end; + + +{$J+} +{LOCAL} +procedure std_huff_tables (cinfo : j_compress_ptr); +{ Set up the standard Huffman tables (cf. JPEG standard section K.3) } +{ IMPORTANT: these are only valid for 8-bit data precision! } + const bits_dc_luminance : array[0..17-1] of UINT8 = + ({ 0-base } 0, 0, 1, 5, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0); + const val_dc_luminance : array[0..11] of UINT8 = + (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11); + + const bits_dc_chrominance : array[0..17-1] of UINT8 = + ( { 0-base } 0, 0, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 ); + const val_dc_chrominance : array[0..11] of UINT8 = + ( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11 ); + + const bits_ac_luminance : array[0..17-1] of UINT8 = + ( { 0-base } 0, 0, 2, 1, 3, 3, 2, 4, 3, 5, 5, 4, 4, 0, 0, 1, $7d ); + const val_ac_luminance : array[0..161] of UINT8 = + ( $01, $02, $03, $00, $04, $11, $05, $12, + $21, $31, $41, $06, $13, $51, $61, $07, + $22, $71, $14, $32, $81, $91, $a1, $08, + $23, $42, $b1, $c1, $15, $52, $d1, $f0, + $24, $33, $62, $72, $82, $09, $0a, $16, + $17, $18, $19, $1a, $25, $26, $27, $28, + $29, $2a, $34, $35, $36, $37, $38, $39, + $3a, $43, $44, $45, $46, $47, $48, $49, + $4a, $53, $54, $55, $56, $57, $58, $59, + $5a, $63, $64, $65, $66, $67, $68, $69, + $6a, $73, $74, $75, $76, $77, $78, $79, + $7a, $83, $84, $85, $86, $87, $88, $89, + $8a, $92, $93, $94, $95, $96, $97, $98, + $99, $9a, $a2, $a3, $a4, $a5, $a6, $a7, + $a8, $a9, $aa, $b2, $b3, $b4, $b5, $b6, + $b7, $b8, $b9, $ba, $c2, $c3, $c4, $c5, + $c6, $c7, $c8, $c9, $ca, $d2, $d3, $d4, + $d5, $d6, $d7, $d8, $d9, $da, $e1, $e2, + $e3, $e4, $e5, $e6, $e7, $e8, $e9, $ea, + $f1, $f2, $f3, $f4, $f5, $f6, $f7, $f8, + $f9, $fa ); + + const bits_ac_chrominance : array[0..17-1] of UINT8 = + ( { 0-base } 0, 0, 2, 1, 2, 4, 4, 3, 4, 7, 5, 4, 4, 0, 1, 2, $77 ); + const val_ac_chrominance : array[0..161] of UINT8 = + ( $00, $01, $02, $03, $11, $04, $05, $21, + $31, $06, $12, $41, $51, $07, $61, $71, + $13, $22, $32, $81, $08, $14, $42, $91, + $a1, $b1, $c1, $09, $23, $33, $52, $f0, + $15, $62, $72, $d1, $0a, $16, $24, $34, + $e1, $25, $f1, $17, $18, $19, $1a, $26, + $27, $28, $29, $2a, $35, $36, $37, $38, + $39, $3a, $43, $44, $45, $46, $47, $48, + $49, $4a, $53, $54, $55, $56, $57, $58, + $59, $5a, $63, $64, $65, $66, $67, $68, + $69, $6a, $73, $74, $75, $76, $77, $78, + $79, $7a, $82, $83, $84, $85, $86, $87, + $88, $89, $8a, $92, $93, $94, $95, $96, + $97, $98, $99, $9a, $a2, $a3, $a4, $a5, + $a6, $a7, $a8, $a9, $aa, $b2, $b3, $b4, + $b5, $b6, $b7, $b8, $b9, $ba, $c2, $c3, + $c4, $c5, $c6, $c7, $c8, $c9, $ca, $d2, + $d3, $d4, $d5, $d6, $d7, $d8, $d9, $da, + $e2, $e3, $e4, $e5, $e6, $e7, $e8, $e9, + $ea, $f2, $f3, $f4, $f5, $f6, $f7, $f8, + $f9, $fa ); +begin + add_huff_table(cinfo, cinfo^.dc_huff_tbl_ptrs[0], + bits_dc_luminance, val_dc_luminance); + add_huff_table(cinfo, cinfo^.ac_huff_tbl_ptrs[0], + bits_ac_luminance, val_ac_luminance); + add_huff_table(cinfo, cinfo^.dc_huff_tbl_ptrs[1], + bits_dc_chrominance, val_dc_chrominance); + add_huff_table(cinfo, cinfo^.ac_huff_tbl_ptrs[1], + bits_ac_chrominance, val_ac_chrominance); +end; + + +{ Default parameter setup for compression. + + Applications that don't choose to use this routine must do their + own setup of all these parameters. Alternately, you can call this + to establish defaults and then alter parameters selectively. This + is the recommended approach since, if we add any new parameters, + your code will still work (they'll be set to reasonable defaults). } + +{GLOBAL} +procedure jpeg_set_defaults (cinfo : j_compress_ptr); +var + i : int; +begin + { Safety check to ensure start_compress not called yet. } + if (cinfo^.global_state <> CSTATE_START) then + ERREXIT1(J_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + + { Allocate comp_info array large enough for maximum component count. + Array is made permanent in case application wants to compress + multiple images at same param settings. } + + if (cinfo^.comp_info = NIL) then + cinfo^.comp_info := jpeg_component_info_list_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT, + MAX_COMPONENTS * SIZEOF(jpeg_component_info)) ); + + { Initialize everything not dependent on the color space } + + cinfo^.data_precision := BITS_IN_JSAMPLE; + { Set up two quantization tables using default quality of 75 } + jpeg_set_quality(cinfo, 75, TRUE); + { Set up two Huffman tables } + std_huff_tables(cinfo); + + { Initialize default arithmetic coding conditioning } + for i := 0 to pred(NUM_ARITH_TBLS) do + begin + cinfo^.arith_dc_L[i] := 0; + cinfo^.arith_dc_U[i] := 1; + cinfo^.arith_ac_K[i] := 5; + end; + + { Default is no multiple-scan output } + cinfo^.scan_info := NIL; + cinfo^.num_scans := 0; + + { Expect normal source image, not raw downsampled data } + cinfo^.raw_data_in := FALSE; + + { Use Huffman coding, not arithmetic coding, by default } + cinfo^.arith_code := FALSE; + + { By default, don't do extra passes to optimize entropy coding } + cinfo^.optimize_coding := FALSE; + { The standard Huffman tables are only valid for 8-bit data precision. + If the precision is higher, force optimization on so that usable + tables will be computed. This test can be removed if default tables + are supplied that are valid for the desired precision. } + + if (cinfo^.data_precision > 8) then + cinfo^.optimize_coding := TRUE; + + { By default, use the simpler non-cosited sampling alignment } + cinfo^.CCIR601_sampling := FALSE; + + { No input smoothing } + cinfo^.smoothing_factor := 0; + + { DCT algorithm preference } + cinfo^.dct_method := JDCT_DEFAULT; + + { No restart markers } + cinfo^.restart_interval := 0; + cinfo^.restart_in_rows := 0; + + { Fill in default JFIF marker parameters. Note that whether the marker + will actually be written is determined by jpeg_set_colorspace. + + By default, the library emits JFIF version code 1.01. + An application that wants to emit JFIF 1.02 extension markers should set + JFIF_minor_version to 2. We could probably get away with just defaulting + to 1.02, but there may still be some decoders in use that will complain + about that; saying 1.01 should minimize compatibility problems. } + + cinfo^.JFIF_major_version := 1; { Default JFIF version = 1.01 } + cinfo^.JFIF_minor_version := 1; + cinfo^.density_unit := 0; { Pixel size is unknown by default } + cinfo^.X_density := 1; { Pixel aspect ratio is square by default } + cinfo^.Y_density := 1; + + { Choose JPEG colorspace based on input space, set defaults accordingly } + + jpeg_default_colorspace(cinfo); +end; + + +{ Select an appropriate JPEG colorspace for in_color_space. } + +{GLOBAL} +procedure jpeg_default_colorspace (cinfo : j_compress_ptr); +begin + case (cinfo^.in_color_space) of + JCS_GRAYSCALE: + jpeg_set_colorspace(cinfo, JCS_GRAYSCALE); + JCS_RGB: + jpeg_set_colorspace(cinfo, JCS_YCbCr); + JCS_YCbCr: + jpeg_set_colorspace(cinfo, JCS_YCbCr); + JCS_CMYK: + jpeg_set_colorspace(cinfo, JCS_CMYK); { By default, no translation } + JCS_YCCK: + jpeg_set_colorspace(cinfo, JCS_YCCK); + JCS_UNKNOWN: + jpeg_set_colorspace(cinfo, JCS_UNKNOWN); + else + ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE); + end; +end; + + +{ Set the JPEG colorspace, and choose colorspace-dependent default values. } + +{GLOBAL} +procedure jpeg_set_colorspace (cinfo : j_compress_ptr; + colorspace : J_COLOR_SPACE); + { macro } + procedure SET_COMP(index,id,hsamp,vsamp,quant,dctbl,actbl : int); + begin + with cinfo^.comp_info^[index] do + begin + component_id := (id); + h_samp_factor := (hsamp); + v_samp_factor := (vsamp); + quant_tbl_no := (quant); + dc_tbl_no := (dctbl); + ac_tbl_no := (actbl); + end; + end; + +var + ci : int; +begin + { Safety check to ensure start_compress not called yet. } + if (cinfo^.global_state <> CSTATE_START) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + + { For all colorspaces, we use Q and Huff tables 0 for luminance components, + tables 1 for chrominance components. } + + cinfo^.jpeg_color_space := colorspace; + + cinfo^.write_JFIF_header := FALSE; { No marker for non-JFIF colorspaces } + cinfo^.write_Adobe_marker := FALSE; { write no Adobe marker by default } + + case (colorspace) of + JCS_GRAYSCALE: + begin + cinfo^.write_JFIF_header := TRUE; { Write a JFIF marker } + cinfo^.num_components := 1; + { JFIF specifies component ID 1 } + SET_COMP(0, 1, 1,1, 0, 0,0); + end; + JCS_RGB: + begin + cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag RGB } + cinfo^.num_components := 3; + SET_COMP(0, $52 { 'R' }, 1,1, 0, 0,0); + SET_COMP(1, $47 { 'G' }, 1,1, 0, 0,0); + SET_COMP(2, $42 { 'B' }, 1,1, 0, 0,0); + end; + JCS_YCbCr: + begin + cinfo^.write_JFIF_header := TRUE; { Write a JFIF marker } + cinfo^.num_components := 3; + { JFIF specifies component IDs 1,2,3 } + { We default to 2x2 subsamples of chrominance } + SET_COMP(0, 1, 2,2, 0, 0,0); + SET_COMP(1, 2, 1,1, 1, 1,1); + SET_COMP(2, 3, 1,1, 1, 1,1); + end; + JCS_CMYK: + begin + cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag CMYK } + cinfo^.num_components := 4; + SET_COMP(0, $43 { 'C' }, 1,1, 0, 0,0); + SET_COMP(1, $4D { 'M' }, 1,1, 0, 0,0); + SET_COMP(2, $59 { 'Y' }, 1,1, 0, 0,0); + SET_COMP(3, $4B { 'K' }, 1,1, 0, 0,0); + end; + JCS_YCCK: + begin + cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag YCCK } + cinfo^.num_components := 4; + SET_COMP(0, 1, 2,2, 0, 0,0); + SET_COMP(1, 2, 1,1, 1, 1,1); + SET_COMP(2, 3, 1,1, 1, 1,1); + SET_COMP(3, 4, 2,2, 0, 0,0); + end; + JCS_UNKNOWN: + begin + cinfo^.num_components := cinfo^.input_components; + if (cinfo^.num_components < 1) + or (cinfo^.num_components > MAX_COMPONENTS) then + ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, + cinfo^.num_components, MAX_COMPONENTS); + for ci := 0 to pred(cinfo^.num_components) do + begin + SET_COMP(ci, ci, 1,1, 0, 0,0); + end; + end; + else + ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); + end; +end; + + +{$ifdef C_PROGRESSIVE_SUPPORTED} + +{LOCAL} +function fill_a_scan (scanptr : jpeg_scan_info_ptr; + ci : int; Ss : int; + Se : int; Ah : int; + Al : int) : jpeg_scan_info_ptr; +{ Support routine: generate one scan for specified component } +begin + scanptr^.comps_in_scan := 1; + scanptr^.component_index[0] := ci; + scanptr^.Ss := Ss; + scanptr^.Se := Se; + scanptr^.Ah := Ah; + scanptr^.Al := Al; + Inc(scanptr); + fill_a_scan := scanptr; +end; + +{LOCAL} +function fill_scans (scanptr : jpeg_scan_info_ptr; + ncomps : int; + Ss : int; Se : int; + Ah : int; Al : int) : jpeg_scan_info_ptr; +{ Support routine: generate one scan for each component } +var + ci : int; +begin + + for ci := 0 to pred(ncomps) do + begin + scanptr^.comps_in_scan := 1; + scanptr^.component_index[0] := ci; + scanptr^.Ss := Ss; + scanptr^.Se := Se; + scanptr^.Ah := Ah; + scanptr^.Al := Al; + Inc(scanptr); + end; + fill_scans := scanptr; +end; + +{LOCAL} +function fill_dc_scans (scanptr : jpeg_scan_info_ptr; + ncomps : int; + Ah : int; Al : int) : jpeg_scan_info_ptr; +{ Support routine: generate interleaved DC scan if possible, else N scans } +var + ci : int; +begin + + if (ncomps <= MAX_COMPS_IN_SCAN) then + begin + { Single interleaved DC scan } + scanptr^.comps_in_scan := ncomps; + for ci := 0 to pred(ncomps) do + scanptr^.component_index[ci] := ci; + scanptr^.Ss := 0; + scanptr^.Se := 0; + scanptr^.Ah := Ah; + scanptr^.Al := Al; + Inc(scanptr); + end + else + begin + { Noninterleaved DC scan for each component } + scanptr := fill_scans(scanptr, ncomps, 0, 0, Ah, Al); + end; + fill_dc_scans := scanptr; +end; + + +{ Create a recommended progressive-JPEG script. + cinfo^.num_components and cinfo^.jpeg_color_space must be correct. } + +{GLOBAL} +procedure jpeg_simple_progression (cinfo : j_compress_ptr); +var + ncomps : int; + nscans : int; + scanptr : jpeg_scan_info_ptr; +begin + ncomps := cinfo^.num_components; + + { Safety check to ensure start_compress not called yet. } + if (cinfo^.global_state <> CSTATE_START) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + + { Figure space needed for script. Calculation must match code below! } + if (ncomps = 3) and (cinfo^.jpeg_color_space = JCS_YCbCr) then + begin + { Custom script for YCbCr color images. } + nscans := 10; + end + else + begin + { All-purpose script for other color spaces. } + if (ncomps > MAX_COMPS_IN_SCAN) then + nscans := 6 * ncomps { 2 DC + 4 AC scans per component } + else + nscans := 2 + 4 * ncomps; { 2 DC scans; 4 AC scans per component } + end; + + { Allocate space for script. + We need to put it in the permanent pool in case the application performs + multiple compressions without changing the settings. To avoid a memory + leak if jpeg_simple_progression is called repeatedly for the same JPEG + object, we try to re-use previously allocated space, and we allocate + enough space to handle YCbCr even if initially asked for grayscale. } + + if (cinfo^.script_space = NIL) or (cinfo^.script_space_size < nscans) then + begin + if nscans > 10 then + cinfo^.script_space_size := nscans + else + cinfo^.script_space_size := 10; + + cinfo^.script_space := jpeg_scan_info_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT, + cinfo^.script_space_size * SIZEOF(jpeg_scan_info)) ); + end; + scanptr := cinfo^.script_space; + + cinfo^.scan_info := scanptr; + cinfo^.num_scans := nscans; + + if (ncomps = 3) and (cinfo^.jpeg_color_space = JCS_YCbCr) then + begin + { Custom script for YCbCr color images. } + { Initial DC scan } + scanptr := fill_dc_scans(scanptr, ncomps, 0, 1); + { Initial AC scan: get some luma data out in a hurry } + scanptr := fill_a_scan(scanptr, 0, 1, 5, 0, 2); + { Chroma data is too small to be worth expending many scans on } + scanptr := fill_a_scan(scanptr, 2, 1, 63, 0, 1); + scanptr := fill_a_scan(scanptr, 1, 1, 63, 0, 1); + { Complete spectral selection for luma AC } + scanptr := fill_a_scan(scanptr, 0, 6, 63, 0, 2); + { Refine next bit of luma AC } + scanptr := fill_a_scan(scanptr, 0, 1, 63, 2, 1); + { Finish DC successive approximation } + scanptr := fill_dc_scans(scanptr, ncomps, 1, 0); + { Finish AC successive approximation } + scanptr := fill_a_scan(scanptr, 2, 1, 63, 1, 0); + scanptr := fill_a_scan(scanptr, 1, 1, 63, 1, 0); + { Luma bottom bit comes last since it's usually largest scan } + scanptr := fill_a_scan(scanptr, 0, 1, 63, 1, 0); + end + else + begin + { All-purpose script for other color spaces. } + { Successive approximation first pass } + scanptr := fill_dc_scans(scanptr, ncomps, 0, 1); + scanptr := fill_scans(scanptr, ncomps, 1, 5, 0, 2); + scanptr := fill_scans(scanptr, ncomps, 6, 63, 0, 2); + { Successive approximation second pass } + scanptr := fill_scans(scanptr, ncomps, 1, 63, 2, 1); + { Successive approximation final pass } + scanptr := fill_dc_scans(scanptr, ncomps, 1, 0); + scanptr := fill_scans(scanptr, ncomps, 1, 63, 1, 0); + end; +end; + +{$endif} +end. diff --git a/Imaging/JpegLib/imjcphuff.pas b/Imaging/JpegLib/imjcphuff.pas index 2b779ef..bd294a6 100644 --- a/Imaging/JpegLib/imjcphuff.pas +++ b/Imaging/JpegLib/imjcphuff.pas @@ -1,962 +1,962 @@ -unit imjcphuff; - -{ This file contains Huffman entropy encoding routines for progressive JPEG. - - We do not support output suspension in this module, since the library - currently does not allow multiple-scan files to be written with output - suspension. } - -{ Original: jcphuff.c; Copyright (C) 1995-1997, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib, - imjdeferr, - imjerror, - imjutils, - imjcomapi, - imjchuff; { Declarations shared with jchuff.c } - -{ Module initialization routine for progressive Huffman entropy encoding. } - -{GLOBAL} -procedure jinit_phuff_encoder (cinfo : j_compress_ptr); - -implementation - -{ Expanded entropy encoder object for progressive Huffman encoding. } -type - phuff_entropy_ptr = ^phuff_entropy_encoder; - phuff_entropy_encoder = record - pub : jpeg_entropy_encoder; { public fields } - - { Mode flag: TRUE for optimization, FALSE for actual data output } - gather_statistics : boolean; - - { Bit-level coding status. - next_output_byte/free_in_buffer are local copies of cinfo^.dest fields.} - - next_output_byte : JOCTETptr; { => next byte to write in buffer } - free_in_buffer : size_t; { # of byte spaces remaining in buffer } - put_buffer : INT32; { current bit-accumulation buffer } - put_bits : int; { # of bits now in it } - cinfo : j_compress_ptr; { link to cinfo (needed for dump_buffer) } - - { Coding status for DC components } - last_dc_val : array[0..MAX_COMPS_IN_SCAN-1] of int; - { last DC coef for each component } - - { Coding status for AC components } - ac_tbl_no : int; { the table number of the single component } - EOBRUN : uInt; { run length of EOBs } - BE : uInt; { # of buffered correction bits before MCU } - bit_buffer : JBytePtr; { buffer for correction bits (1 per char) } - { packing correction bits tightly would save some space but cost time... } - - restarts_to_go : uInt; { MCUs left in this restart interval } - next_restart_num : int; { next restart number to write (0-7) } - - { Pointers to derived tables (these workspaces have image lifespan). - Since any one scan codes only DC or only AC, we only need one set - of tables, not one for DC and one for AC. } - - derived_tbls : array[0..NUM_HUFF_TBLS-1] of c_derived_tbl_ptr; - - { Statistics tables for optimization; again, one set is enough } - count_ptrs : array[0..NUM_HUFF_TBLS-1] of TLongTablePtr; - end; - - -{ MAX_CORR_BITS is the number of bits the AC refinement correction-bit - buffer can hold. Larger sizes may slightly improve compression, but - 1000 is already well into the realm of overkill. - The minimum safe size is 64 bits. } - -const - MAX_CORR_BITS = 1000; { Max # of correction bits I can buffer } - - -{ Forward declarations } -{METHODDEF} -function encode_mcu_DC_first (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; - forward; -{METHODDEF} -function encode_mcu_AC_first (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; - forward; -{METHODDEF} -function encode_mcu_DC_refine (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; - forward; -{METHODDEF} -function encode_mcu_AC_refine (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; - forward; - -{METHODDEF} -procedure finish_pass_phuff (cinfo : j_compress_ptr); forward; - -{METHODDEF} -procedure finish_pass_gather_phuff (cinfo : j_compress_ptr); forward; - - -{ Initialize for a Huffman-compressed scan using progressive JPEG. } - -{METHODDEF} -procedure start_pass_phuff (cinfo : j_compress_ptr; - gather_statistics : boolean); -var - entropy : phuff_entropy_ptr; - is_DC_band : boolean; - ci, tbl : int; - compptr : jpeg_component_info_ptr; -begin - tbl := 0; - entropy := phuff_entropy_ptr (cinfo^.entropy); - - entropy^.cinfo := cinfo; - entropy^.gather_statistics := gather_statistics; - - is_DC_band := (cinfo^.Ss = 0); - - { We assume jcmaster.c already validated the scan parameters. } - - { Select execution routines } - if (cinfo^.Ah = 0) then - begin - if (is_DC_band) then - entropy^.pub.encode_mcu := encode_mcu_DC_first - else - entropy^.pub.encode_mcu := encode_mcu_AC_first; - end - else - begin - if (is_DC_band) then - entropy^.pub.encode_mcu := encode_mcu_DC_refine - else - begin - entropy^.pub.encode_mcu := encode_mcu_AC_refine; - { AC refinement needs a correction bit buffer } - if (entropy^.bit_buffer = NIL) then - entropy^.bit_buffer := JBytePtr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - MAX_CORR_BITS * SIZEOF(byte)) ); - end; - end; - if (gather_statistics) then - entropy^.pub.finish_pass := finish_pass_gather_phuff - else - entropy^.pub.finish_pass := finish_pass_phuff; - - { Only DC coefficients may be interleaved, so cinfo^.comps_in_scan = 1 - for AC coefficients. } - - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - { Initialize DC predictions to 0 } - entropy^.last_dc_val[ci] := 0; - { Get table index } - if (is_DC_band) then - begin - if (cinfo^.Ah <> 0) then { DC refinement needs no table } - continue; - tbl := compptr^.dc_tbl_no; - end - else - begin - tbl := compptr^.ac_tbl_no; - entropy^.ac_tbl_no := tbl; - end; - if (gather_statistics) then - begin - { Check for invalid table index } - { (make_c_derived_tbl does this in the other path) } - if (tbl < 0) or (tbl >= NUM_HUFF_TBLS) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tbl); - { Allocate and zero the statistics tables } - { Note that jpeg_gen_optimal_table expects 257 entries in each table! } - if (entropy^.count_ptrs[tbl] = NIL) then - entropy^.count_ptrs[tbl] := TLongTablePtr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - 257 * SIZEOF(long)) ); - MEMZERO(entropy^.count_ptrs[tbl], 257 * SIZEOF(long)); - end else - begin - { Compute derived values for Huffman table } - { We may do this more than once for a table, but it's not expensive } - jpeg_make_c_derived_tbl(cinfo, is_DC_band, tbl, - entropy^.derived_tbls[tbl]); - end; - end; - - { Initialize AC stuff } - entropy^.EOBRUN := 0; - entropy^.BE := 0; - - { Initialize bit buffer to empty } - entropy^.put_buffer := 0; - entropy^.put_bits := 0; - - { Initialize restart stuff } - entropy^.restarts_to_go := cinfo^.restart_interval; - entropy^.next_restart_num := 0; -end; - - - - -{LOCAL} -procedure dump_buffer (entropy : phuff_entropy_ptr); -{ Empty the output buffer; we do not support suspension in this module. } -var - dest : jpeg_destination_mgr_ptr; -begin - dest := entropy^.cinfo^.dest; - - if (not dest^.empty_output_buffer (entropy^.cinfo)) then - ERREXIT(j_common_ptr(entropy^.cinfo), JERR_CANT_SUSPEND); - { After a successful buffer dump, must reset buffer pointers } - entropy^.next_output_byte := dest^.next_output_byte; - entropy^.free_in_buffer := dest^.free_in_buffer; -end; - - -{ Outputting bits to the file } - -{ Only the right 24 bits of put_buffer are used; the valid bits are - left-justified in this part. At most 16 bits can be passed to emit_bits - in one call, and we never retain more than 7 bits in put_buffer - between calls, so 24 bits are sufficient. } - - -{LOCAL} -procedure emit_bits (entropy : phuff_entropy_ptr; - code : uInt; - size : int); {INLINE} -{ Emit some bits, unless we are in gather mode } -var - {register} put_buffer : INT32; - {register} put_bits : int; -var - c : int; -begin - { This routine is heavily used, so it's worth coding tightly. } - put_buffer := INT32 (code); - put_bits := entropy^.put_bits; - - { if size is 0, caller used an invalid Huffman table entry } - if (size = 0) then - ERREXIT(j_common_ptr(entropy^.cinfo), JERR_HUFF_MISSING_CODE); - - if (entropy^.gather_statistics) then - exit; { do nothing if we're only getting stats } - - put_buffer := put_buffer and ((INT32(1) shl size) - 1); - { mask off any extra bits in code } - - Inc(put_bits, size); { new number of bits in buffer } - - put_buffer := put_buffer shl (24 - put_bits); { align incoming bits } - - put_buffer := put_buffer or entropy^.put_buffer; - { and merge with old buffer contents } - - while (put_bits >= 8) do - begin - c := int ((put_buffer shr 16) and $FF); - - {emit_byte(entropy, c);} - { Outputting bytes to the file. - NB: these must be called only when actually outputting, - that is, entropy^.gather_statistics = FALSE. } - { Emit a byte } - entropy^.next_output_byte^ := JOCTET(c); - Inc(entropy^.next_output_byte); - Dec(entropy^.free_in_buffer); - if (entropy^.free_in_buffer = 0) then - dump_buffer(entropy); - - if (c = $FF) then - begin { need to stuff a zero byte? } - {emit_byte(entropy, 0);} - entropy^.next_output_byte^ := JOCTET(0); - Inc(entropy^.next_output_byte); - Dec(entropy^.free_in_buffer); - if (entropy^.free_in_buffer = 0) then - dump_buffer(entropy); - end; - put_buffer := put_buffer shl 8; - Dec(put_bits, 8); - end; - - entropy^.put_buffer := put_buffer; { update variables } - entropy^.put_bits := put_bits; -end; - - -{LOCAL} -procedure flush_bits (entropy : phuff_entropy_ptr); -begin - emit_bits(entropy, $7F, 7); { fill any partial byte with ones } - entropy^.put_buffer := 0; { and reset bit-buffer to empty } - entropy^.put_bits := 0; -end; - -{ Emit (or just count) a Huffman symbol. } - - -{LOCAL} -procedure emit_symbol (entropy : phuff_entropy_ptr; - tbl_no : int; - symbol : int); {INLINE} -var - tbl : c_derived_tbl_ptr; -begin - if (entropy^.gather_statistics) then - Inc(entropy^.count_ptrs[tbl_no]^[symbol]) - else - begin - tbl := entropy^.derived_tbls[tbl_no]; - emit_bits(entropy, tbl^.ehufco[symbol], tbl^.ehufsi[symbol]); - end; -end; - - -{ Emit bits from a correction bit buffer. } - -{LOCAL} -procedure emit_buffered_bits (entropy : phuff_entropy_ptr; - bufstart : JBytePtr; - nbits : uInt); -var - bufptr : byteptr; -begin - if (entropy^.gather_statistics) then - exit; { no real work } - - bufptr := byteptr(bufstart); - while (nbits > 0) do - begin - emit_bits(entropy, uInt(bufptr^), 1); - Inc(bufptr); - Dec(nbits); - end; -end; - - -{ Emit any pending EOBRUN symbol. } - -{LOCAL} -procedure emit_eobrun (entropy : phuff_entropy_ptr); -var - {register} temp, nbits : int; -begin - if (entropy^.EOBRUN > 0) then - begin { if there is any pending EOBRUN } - temp := entropy^.EOBRUN; - nbits := 0; - temp := temp shr 1; - while (temp <> 0) do - begin - Inc(nbits); - temp := temp shr 1; - end; - - { safety check: shouldn't happen given limited correction-bit buffer } - if (nbits > 14) then - ERREXIT(j_common_ptr(entropy^.cinfo), JERR_HUFF_MISSING_CODE); - - emit_symbol(entropy, entropy^.ac_tbl_no, nbits shl 4); - if (nbits <> 0) then - emit_bits(entropy, entropy^.EOBRUN, nbits); - - entropy^.EOBRUN := 0; - - { Emit any buffered correction bits } - emit_buffered_bits(entropy, entropy^.bit_buffer, entropy^.BE); - entropy^.BE := 0; - end; -end; - - -{ Emit a restart marker & resynchronize predictions. } - -{LOCAL} -procedure emit_restart (entropy : phuff_entropy_ptr; - restart_num : int); -var - ci : int; -begin - emit_eobrun(entropy); - - if (not entropy^.gather_statistics) then - begin - flush_bits(entropy); - {emit_byte(entropy, $FF);} - { Outputting bytes to the file. - NB: these must be called only when actually outputting, - that is, entropy^.gather_statistics = FALSE. } - - entropy^.next_output_byte^ := JOCTET($FF); - Inc(entropy^.next_output_byte); - Dec(entropy^.free_in_buffer); - if (entropy^.free_in_buffer = 0) then - dump_buffer(entropy); - - {emit_byte(entropy, JPEG_RST0 + restart_num);} - entropy^.next_output_byte^ := JOCTET(JPEG_RST0 + restart_num); - Inc(entropy^.next_output_byte); - Dec(entropy^.free_in_buffer); - if (entropy^.free_in_buffer = 0) then - dump_buffer(entropy); - end; - - if (entropy^.cinfo^.Ss = 0) then - begin - { Re-initialize DC predictions to 0 } - for ci := 0 to pred(entropy^.cinfo^.comps_in_scan) do - entropy^.last_dc_val[ci] := 0; - end - else - begin - { Re-initialize all AC-related fields to 0 } - entropy^.EOBRUN := 0; - entropy^.BE := 0; - end; -end; - - -{ MCU encoding for DC initial scan (either spectral selection, - or first pass of successive approximation). } - -{METHODDEF} -function encode_mcu_DC_first (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; -var - entropy : phuff_entropy_ptr; - {register} temp, temp2 : int; - {register} nbits : int; - blkn, ci : int; - Al : int; - block : JBLOCK_PTR; - compptr : jpeg_component_info_ptr; - ishift_temp : int; -begin - entropy := phuff_entropy_ptr (cinfo^.entropy); - Al := cinfo^.Al; - - entropy^.next_output_byte := cinfo^.dest^.next_output_byte; - entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer; - - { Emit restart marker if needed } - if (cinfo^.restart_interval <> 0) then - if (entropy^.restarts_to_go = 0) then - emit_restart(entropy, entropy^.next_restart_num); - - { Encode the MCU data blocks } - for blkn := 0 to pred(cinfo^.blocks_in_MCU) do - begin - block := JBLOCK_PTR(MCU_data[blkn]); - ci := cinfo^.MCU_membership[blkn]; - compptr := cinfo^.cur_comp_info[ci]; - - { Compute the DC value after the required point transform by Al. - This is simply an arithmetic right shift. } - - {temp2 := IRIGHT_SHIFT( int(block^[0]), Al);} - {IRIGHT_SHIFT_IS_UNSIGNED} - ishift_temp := int(block^[0]); - if ishift_temp < 0 then - temp2 := (ishift_temp shr Al) or ((not 0) shl (16-Al)) - else - temp2 := ishift_temp shr Al; - - - { DC differences are figured on the point-transformed values. } - temp := temp2 - entropy^.last_dc_val[ci]; - entropy^.last_dc_val[ci] := temp2; - - { Encode the DC coefficient difference per section G.1.2.1 } - temp2 := temp; - if (temp < 0) then - begin - temp := -temp; { temp is abs value of input } - { For a negative input, want temp2 := bitwise complement of abs(input) } - { This code assumes we are on a two's complement machine } - Dec(temp2); - end; - - { Find the number of bits needed for the magnitude of the coefficient } - nbits := 0; - while (temp <> 0) do - begin - Inc(nbits); - temp := temp shr 1; - end; - - { Check for out-of-range coefficient values. - Since we're encoding a difference, the range limit is twice as much. } - - if (nbits > MAX_COEF_BITS+1) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_DCT_COEF); - - { Count/emit the Huffman-coded symbol for the number of bits } - emit_symbol(entropy, compptr^.dc_tbl_no, nbits); - - { Emit that number of bits of the value, if positive, } - { or the complement of its magnitude, if negative. } - if (nbits <> 0) then { emit_bits rejects calls with size 0 } - emit_bits(entropy, uInt(temp2), nbits); - end; - - cinfo^.dest^.next_output_byte := entropy^.next_output_byte; - cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer; - - { Update restart-interval state too } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - begin - entropy^.restarts_to_go := cinfo^.restart_interval; - Inc(entropy^.next_restart_num); - with entropy^ do - next_restart_num := next_restart_num and 7; - end; - Dec(entropy^.restarts_to_go); - end; - - encode_mcu_DC_first := TRUE; -end; - - -{ MCU encoding for AC initial scan (either spectral selection, - or first pass of successive approximation). } - -{METHODDEF} -function encode_mcu_AC_first (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; -var - entropy : phuff_entropy_ptr; - {register} temp, temp2 : int; - {register} nbits : int; - {register} r, k : int; - Se : int; - Al : int; - block : JBLOCK_PTR; -begin - entropy := phuff_entropy_ptr (cinfo^.entropy); - Se := cinfo^.Se; - Al := cinfo^.Al; - - entropy^.next_output_byte := cinfo^.dest^.next_output_byte; - entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer; - - { Emit restart marker if needed } - if (cinfo^.restart_interval <> 0) then - if (entropy^.restarts_to_go = 0) then - emit_restart(entropy, entropy^.next_restart_num); - - { Encode the MCU data block } - block := JBLOCK_PTR(MCU_data[0]); - - { Encode the AC coefficients per section G.1.2.2, fig. G.3 } - - r := 0; { r := run length of zeros } - - for k := cinfo^.Ss to Se do - begin - temp := (block^[jpeg_natural_order[k]]); - if (temp = 0) then - begin - Inc(r); - continue; - end; - { We must apply the point transform by Al. For AC coefficients this - is an integer division with rounding towards 0. To do this portably - in C, we shift after obtaining the absolute value; so the code is - interwoven with finding the abs value (temp) and output bits (temp2). } - - if (temp < 0) then - begin - temp := -temp; { temp is abs value of input } - temp := temp shr Al; { apply the point transform } - { For a negative coef, want temp2 := bitwise complement of abs(coef) } - temp2 := not temp; - end - else - begin - temp := temp shr Al; { apply the point transform } - temp2 := temp; - end; - { Watch out for case that nonzero coef is zero after point transform } - if (temp = 0) then - begin - Inc(r); - continue; - end; - - { Emit any pending EOBRUN } - if (entropy^.EOBRUN > 0) then - emit_eobrun(entropy); - { if run length > 15, must emit special run-length-16 codes ($F0) } - while (r > 15) do - begin - emit_symbol(entropy, entropy^.ac_tbl_no, $F0); - Dec(r, 16); - end; - - { Find the number of bits needed for the magnitude of the coefficient } - nbits := 0; { there must be at least one 1 bit } - repeat - Inc(nbits); - temp := temp shr 1; - until (temp = 0); - - { Check for out-of-range coefficient values } - if (nbits > MAX_COEF_BITS) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_DCT_COEF); - - { Count/emit Huffman symbol for run length / number of bits } - emit_symbol(entropy, entropy^.ac_tbl_no, (r shl 4) + nbits); - - { Emit that number of bits of the value, if positive, } - { or the complement of its magnitude, if negative. } - emit_bits(entropy, uInt(temp2), nbits); - - r := 0; { reset zero run length } - end; - - if (r > 0) then - begin { If there are trailing zeroes, } - Inc(entropy^.EOBRUN); { count an EOB } - if (entropy^.EOBRUN = $7FFF) then - emit_eobrun(entropy); { force it out to avoid overflow } - end; - - cinfo^.dest^.next_output_byte := entropy^.next_output_byte; - cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer; - - { Update restart-interval state too } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - begin - entropy^.restarts_to_go := cinfo^.restart_interval; - Inc(entropy^.next_restart_num); - with entropy^ do - next_restart_num := next_restart_num and 7; - end; - Dec(entropy^.restarts_to_go); - end; - - encode_mcu_AC_first := TRUE; -end; - - -{ MCU encoding for DC successive approximation refinement scan. - Note: we assume such scans can be multi-component, although the spec - is not very clear on the point. } - -{METHODDEF} -function encode_mcu_DC_refine (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; -var - entropy : phuff_entropy_ptr; - {register} temp : int; - blkn : int; - Al : int; - block : JBLOCK_PTR; -begin - entropy := phuff_entropy_ptr (cinfo^.entropy); - Al := cinfo^.Al; - - entropy^.next_output_byte := cinfo^.dest^.next_output_byte; - entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer; - - { Emit restart marker if needed } - if (cinfo^.restart_interval <> 0) then - if (entropy^.restarts_to_go = 0) then - emit_restart(entropy, entropy^.next_restart_num); - - { Encode the MCU data blocks } - for blkn := 0 to pred(cinfo^.blocks_in_MCU) do - begin - block := JBLOCK_PTR(MCU_data[blkn]); - - { We simply emit the Al'th bit of the DC coefficient value. } - temp := block^[0]; - emit_bits(entropy, uInt(temp shr Al), 1); - end; - - cinfo^.dest^.next_output_byte := entropy^.next_output_byte; - cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer; - - { Update restart-interval state too } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - begin - entropy^.restarts_to_go := cinfo^.restart_interval; - Inc(entropy^.next_restart_num); - with entropy^ do - next_restart_num := next_restart_num and 7; - end; - Dec(entropy^.restarts_to_go); - end; - - encode_mcu_DC_refine := TRUE; -end; - - -{ MCU encoding for AC successive approximation refinement scan. } - -{METHODDEF} -function encode_mcu_AC_refine (cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; - -var - entropy : phuff_entropy_ptr; - {register} temp : int; - {register} r, k : int; - EOB : int; - BR_buffer : JBytePtr; - BR : uInt; - Se : int; - Al : int; - block : JBLOCK_PTR; - absvalues : array[0..DCTSIZE2-1] of int; -begin - entropy := phuff_entropy_ptr(cinfo^.entropy); - Se := cinfo^.Se; - Al := cinfo^.Al; - - entropy^.next_output_byte := cinfo^.dest^.next_output_byte; - entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer; - - { Emit restart marker if needed } - if (cinfo^.restart_interval <> 0) then - if (entropy^.restarts_to_go = 0) then - emit_restart(entropy, entropy^.next_restart_num); - - { Encode the MCU data block } - block := JBLOCK_PTR(MCU_data[0]); - - { It is convenient to make a pre-pass to determine the transformed - coefficients' absolute values and the EOB position. } - - EOB := 0; - for k := cinfo^.Ss to Se do - begin - temp := block^[jpeg_natural_order[k]]; - { We must apply the point transform by Al. For AC coefficients this - is an integer division with rounding towards 0. To do this portably - in C, we shift after obtaining the absolute value. } - - if (temp < 0) then - temp := -temp; { temp is abs value of input } - temp := temp shr Al; { apply the point transform } - absvalues[k] := temp; { save abs value for main pass } - if (temp = 1) then - EOB := k; { EOB := index of last newly-nonzero coef } - end; - - { Encode the AC coefficients per section G.1.2.3, fig. G.7 } - - r := 0; { r := run length of zeros } - BR := 0; { BR := count of buffered bits added now } - BR_buffer := JBytePtr(@(entropy^.bit_buffer^[entropy^.BE])); - { Append bits to buffer } - - for k := cinfo^.Ss to Se do - begin - temp := absvalues[k]; - if (temp = 0) then - begin - Inc(r); - continue; - end; - - { Emit any required ZRLs, but not if they can be folded into EOB } - while (r > 15) and (k <= EOB) do - begin - { emit any pending EOBRUN and the BE correction bits } - emit_eobrun(entropy); - { Emit ZRL } - emit_symbol(entropy, entropy^.ac_tbl_no, $F0); - Dec(r, 16); - { Emit buffered correction bits that must be associated with ZRL } - emit_buffered_bits(entropy, BR_buffer, BR); - BR_buffer := entropy^.bit_buffer; { BE bits are gone now } - BR := 0; - end; - - { If the coef was previously nonzero, it only needs a correction bit. - NOTE: a straight translation of the spec's figure G.7 would suggest - that we also need to test r > 15. But if r > 15, we can only get here - if k > EOB, which implies that this coefficient is not 1. } - if (temp > 1) then - begin - { The correction bit is the next bit of the absolute value. } - BR_buffer^[BR] := byte (temp and 1); - Inc(BR); - continue; - end; - - { Emit any pending EOBRUN and the BE correction bits } - emit_eobrun(entropy); - - { Count/emit Huffman symbol for run length / number of bits } - emit_symbol(entropy, entropy^.ac_tbl_no, (r shl 4) + 1); - - { Emit output bit for newly-nonzero coef } - if (block^[jpeg_natural_order[k]] < 0) then - temp := 0 - else - temp := 1; - emit_bits(entropy, uInt(temp), 1); - - { Emit buffered correction bits that must be associated with this code } - emit_buffered_bits(entropy, BR_buffer, BR); - BR_buffer := entropy^.bit_buffer; { BE bits are gone now } - BR := 0; - r := 0; { reset zero run length } - end; - - if (r > 0) or (BR > 0) then - begin { If there are trailing zeroes, } - Inc(entropy^.EOBRUN); { count an EOB } - Inc(entropy^.BE, BR); { concat my correction bits to older ones } - { We force out the EOB if we risk either: - 1. overflow of the EOB counter; - 2. overflow of the correction bit buffer during the next MCU. } - - if (entropy^.EOBRUN = $7FFF) or - (entropy^.BE > (MAX_CORR_BITS-DCTSIZE2+1)) then - emit_eobrun(entropy); - end; - - cinfo^.dest^.next_output_byte := entropy^.next_output_byte; - cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer; - - { Update restart-interval state too } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - begin - entropy^.restarts_to_go := cinfo^.restart_interval; - Inc(entropy^.next_restart_num); - with entropy^ do - next_restart_num := next_restart_num and 7; - end; - Dec(entropy^.restarts_to_go); - end; - - encode_mcu_AC_refine := TRUE; -end; - - -{ Finish up at the end of a Huffman-compressed progressive scan. } - -{METHODDEF} -procedure finish_pass_phuff (cinfo : j_compress_ptr); -var - entropy : phuff_entropy_ptr; -begin - entropy := phuff_entropy_ptr (cinfo^.entropy); - - entropy^.next_output_byte := cinfo^.dest^.next_output_byte; - entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer; - - { Flush out any buffered data } - emit_eobrun(entropy); - flush_bits(entropy); - - cinfo^.dest^.next_output_byte := entropy^.next_output_byte; - cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer; -end; - - -{ Finish up a statistics-gathering pass and create the new Huffman tables. } - -{METHODDEF} -procedure finish_pass_gather_phuff (cinfo : j_compress_ptr); -var - entropy : phuff_entropy_ptr; - is_DC_band : boolean; - ci, tbl : int; - compptr : jpeg_component_info_ptr; - htblptr : ^JHUFF_TBL_PTR; - did : array[0..NUM_HUFF_TBLS-1] of boolean; -begin - tbl := 0; - entropy := phuff_entropy_ptr (cinfo^.entropy); - - { Flush out buffered data (all we care about is counting the EOB symbol) } - emit_eobrun(entropy); - - is_DC_band := (cinfo^.Ss = 0); - - { It's important not to apply jpeg_gen_optimal_table more than once - per table, because it clobbers the input frequency counts! } - - MEMZERO(@did, SIZEOF(did)); - - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - if (is_DC_band) then - begin - if (cinfo^.Ah <> 0) then { DC refinement needs no table } - continue; - tbl := compptr^.dc_tbl_no; - end - else - begin - tbl := compptr^.ac_tbl_no; - end; - if (not did[tbl]) then - begin - if (is_DC_band) then - htblptr := @(cinfo^.dc_huff_tbl_ptrs[tbl]) - else - htblptr := @(cinfo^.ac_huff_tbl_ptrs[tbl]); - if (htblptr^ = NIL) then - htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo)); - jpeg_gen_optimal_table(cinfo, htblptr^, entropy^.count_ptrs[tbl]^); - did[tbl] := TRUE; - end; - end; -end; - - -{ Module initialization routine for progressive Huffman entropy encoding. } - -{GLOBAL} -procedure jinit_phuff_encoder (cinfo : j_compress_ptr); -var - entropy : phuff_entropy_ptr; - i : int; -begin - entropy := phuff_entropy_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(phuff_entropy_encoder)) ); - cinfo^.entropy := jpeg_entropy_encoder_ptr(entropy); - entropy^.pub.start_pass := start_pass_phuff; - - { Mark tables unallocated } - for i := 0 to pred(NUM_HUFF_TBLS) do - begin - entropy^.derived_tbls[i] := NIL; - entropy^.count_ptrs[i] := NIL; - end; - entropy^.bit_buffer := NIL; { needed only in AC refinement scan } -end; - -end. +unit imjcphuff; + +{ This file contains Huffman entropy encoding routines for progressive JPEG. + + We do not support output suspension in this module, since the library + currently does not allow multiple-scan files to be written with output + suspension. } + +{ Original: jcphuff.c; Copyright (C) 1995-1997, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib, + imjdeferr, + imjerror, + imjutils, + imjcomapi, + imjchuff; { Declarations shared with jchuff.c } + +{ Module initialization routine for progressive Huffman entropy encoding. } + +{GLOBAL} +procedure jinit_phuff_encoder (cinfo : j_compress_ptr); + +implementation + +{ Expanded entropy encoder object for progressive Huffman encoding. } +type + phuff_entropy_ptr = ^phuff_entropy_encoder; + phuff_entropy_encoder = record + pub : jpeg_entropy_encoder; { public fields } + + { Mode flag: TRUE for optimization, FALSE for actual data output } + gather_statistics : boolean; + + { Bit-level coding status. + next_output_byte/free_in_buffer are local copies of cinfo^.dest fields.} + + next_output_byte : JOCTETptr; { => next byte to write in buffer } + free_in_buffer : size_t; { # of byte spaces remaining in buffer } + put_buffer : INT32; { current bit-accumulation buffer } + put_bits : int; { # of bits now in it } + cinfo : j_compress_ptr; { link to cinfo (needed for dump_buffer) } + + { Coding status for DC components } + last_dc_val : array[0..MAX_COMPS_IN_SCAN-1] of int; + { last DC coef for each component } + + { Coding status for AC components } + ac_tbl_no : int; { the table number of the single component } + EOBRUN : uInt; { run length of EOBs } + BE : uInt; { # of buffered correction bits before MCU } + bit_buffer : JBytePtr; { buffer for correction bits (1 per char) } + { packing correction bits tightly would save some space but cost time... } + + restarts_to_go : uInt; { MCUs left in this restart interval } + next_restart_num : int; { next restart number to write (0-7) } + + { Pointers to derived tables (these workspaces have image lifespan). + Since any one scan codes only DC or only AC, we only need one set + of tables, not one for DC and one for AC. } + + derived_tbls : array[0..NUM_HUFF_TBLS-1] of c_derived_tbl_ptr; + + { Statistics tables for optimization; again, one set is enough } + count_ptrs : array[0..NUM_HUFF_TBLS-1] of TLongTablePtr; + end; + + +{ MAX_CORR_BITS is the number of bits the AC refinement correction-bit + buffer can hold. Larger sizes may slightly improve compression, but + 1000 is already well into the realm of overkill. + The minimum safe size is 64 bits. } + +const + MAX_CORR_BITS = 1000; { Max # of correction bits I can buffer } + + +{ Forward declarations } +{METHODDEF} +function encode_mcu_DC_first (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; + forward; +{METHODDEF} +function encode_mcu_AC_first (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; + forward; +{METHODDEF} +function encode_mcu_DC_refine (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; + forward; +{METHODDEF} +function encode_mcu_AC_refine (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; + forward; + +{METHODDEF} +procedure finish_pass_phuff (cinfo : j_compress_ptr); forward; + +{METHODDEF} +procedure finish_pass_gather_phuff (cinfo : j_compress_ptr); forward; + + +{ Initialize for a Huffman-compressed scan using progressive JPEG. } + +{METHODDEF} +procedure start_pass_phuff (cinfo : j_compress_ptr; + gather_statistics : boolean); +var + entropy : phuff_entropy_ptr; + is_DC_band : boolean; + ci, tbl : int; + compptr : jpeg_component_info_ptr; +begin + tbl := 0; + entropy := phuff_entropy_ptr (cinfo^.entropy); + + entropy^.cinfo := cinfo; + entropy^.gather_statistics := gather_statistics; + + is_DC_band := (cinfo^.Ss = 0); + + { We assume jcmaster.c already validated the scan parameters. } + + { Select execution routines } + if (cinfo^.Ah = 0) then + begin + if (is_DC_band) then + entropy^.pub.encode_mcu := encode_mcu_DC_first + else + entropy^.pub.encode_mcu := encode_mcu_AC_first; + end + else + begin + if (is_DC_band) then + entropy^.pub.encode_mcu := encode_mcu_DC_refine + else + begin + entropy^.pub.encode_mcu := encode_mcu_AC_refine; + { AC refinement needs a correction bit buffer } + if (entropy^.bit_buffer = NIL) then + entropy^.bit_buffer := JBytePtr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + MAX_CORR_BITS * SIZEOF(byte)) ); + end; + end; + if (gather_statistics) then + entropy^.pub.finish_pass := finish_pass_gather_phuff + else + entropy^.pub.finish_pass := finish_pass_phuff; + + { Only DC coefficients may be interleaved, so cinfo^.comps_in_scan = 1 + for AC coefficients. } + + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + { Initialize DC predictions to 0 } + entropy^.last_dc_val[ci] := 0; + { Get table index } + if (is_DC_band) then + begin + if (cinfo^.Ah <> 0) then { DC refinement needs no table } + continue; + tbl := compptr^.dc_tbl_no; + end + else + begin + tbl := compptr^.ac_tbl_no; + entropy^.ac_tbl_no := tbl; + end; + if (gather_statistics) then + begin + { Check for invalid table index } + { (make_c_derived_tbl does this in the other path) } + if (tbl < 0) or (tbl >= NUM_HUFF_TBLS) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tbl); + { Allocate and zero the statistics tables } + { Note that jpeg_gen_optimal_table expects 257 entries in each table! } + if (entropy^.count_ptrs[tbl] = NIL) then + entropy^.count_ptrs[tbl] := TLongTablePtr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + 257 * SIZEOF(long)) ); + MEMZERO(entropy^.count_ptrs[tbl], 257 * SIZEOF(long)); + end else + begin + { Compute derived values for Huffman table } + { We may do this more than once for a table, but it's not expensive } + jpeg_make_c_derived_tbl(cinfo, is_DC_band, tbl, + entropy^.derived_tbls[tbl]); + end; + end; + + { Initialize AC stuff } + entropy^.EOBRUN := 0; + entropy^.BE := 0; + + { Initialize bit buffer to empty } + entropy^.put_buffer := 0; + entropy^.put_bits := 0; + + { Initialize restart stuff } + entropy^.restarts_to_go := cinfo^.restart_interval; + entropy^.next_restart_num := 0; +end; + + + + +{LOCAL} +procedure dump_buffer (entropy : phuff_entropy_ptr); +{ Empty the output buffer; we do not support suspension in this module. } +var + dest : jpeg_destination_mgr_ptr; +begin + dest := entropy^.cinfo^.dest; + + if (not dest^.empty_output_buffer (entropy^.cinfo)) then + ERREXIT(j_common_ptr(entropy^.cinfo), JERR_CANT_SUSPEND); + { After a successful buffer dump, must reset buffer pointers } + entropy^.next_output_byte := dest^.next_output_byte; + entropy^.free_in_buffer := dest^.free_in_buffer; +end; + + +{ Outputting bits to the file } + +{ Only the right 24 bits of put_buffer are used; the valid bits are + left-justified in this part. At most 16 bits can be passed to emit_bits + in one call, and we never retain more than 7 bits in put_buffer + between calls, so 24 bits are sufficient. } + + +{LOCAL} +procedure emit_bits (entropy : phuff_entropy_ptr; + code : uInt; + size : int); {INLINE} +{ Emit some bits, unless we are in gather mode } +var + {register} put_buffer : INT32; + {register} put_bits : int; +var + c : int; +begin + { This routine is heavily used, so it's worth coding tightly. } + put_buffer := INT32 (code); + put_bits := entropy^.put_bits; + + { if size is 0, caller used an invalid Huffman table entry } + if (size = 0) then + ERREXIT(j_common_ptr(entropy^.cinfo), JERR_HUFF_MISSING_CODE); + + if (entropy^.gather_statistics) then + exit; { do nothing if we're only getting stats } + + put_buffer := put_buffer and ((INT32(1) shl size) - 1); + { mask off any extra bits in code } + + Inc(put_bits, size); { new number of bits in buffer } + + put_buffer := put_buffer shl (24 - put_bits); { align incoming bits } + + put_buffer := put_buffer or entropy^.put_buffer; + { and merge with old buffer contents } + + while (put_bits >= 8) do + begin + c := int ((put_buffer shr 16) and $FF); + + {emit_byte(entropy, c);} + { Outputting bytes to the file. + NB: these must be called only when actually outputting, + that is, entropy^.gather_statistics = FALSE. } + { Emit a byte } + entropy^.next_output_byte^ := JOCTET(c); + Inc(entropy^.next_output_byte); + Dec(entropy^.free_in_buffer); + if (entropy^.free_in_buffer = 0) then + dump_buffer(entropy); + + if (c = $FF) then + begin { need to stuff a zero byte? } + {emit_byte(entropy, 0);} + entropy^.next_output_byte^ := JOCTET(0); + Inc(entropy^.next_output_byte); + Dec(entropy^.free_in_buffer); + if (entropy^.free_in_buffer = 0) then + dump_buffer(entropy); + end; + put_buffer := put_buffer shl 8; + Dec(put_bits, 8); + end; + + entropy^.put_buffer := put_buffer; { update variables } + entropy^.put_bits := put_bits; +end; + + +{LOCAL} +procedure flush_bits (entropy : phuff_entropy_ptr); +begin + emit_bits(entropy, $7F, 7); { fill any partial byte with ones } + entropy^.put_buffer := 0; { and reset bit-buffer to empty } + entropy^.put_bits := 0; +end; + +{ Emit (or just count) a Huffman symbol. } + + +{LOCAL} +procedure emit_symbol (entropy : phuff_entropy_ptr; + tbl_no : int; + symbol : int); {INLINE} +var + tbl : c_derived_tbl_ptr; +begin + if (entropy^.gather_statistics) then + Inc(entropy^.count_ptrs[tbl_no]^[symbol]) + else + begin + tbl := entropy^.derived_tbls[tbl_no]; + emit_bits(entropy, tbl^.ehufco[symbol], tbl^.ehufsi[symbol]); + end; +end; + + +{ Emit bits from a correction bit buffer. } + +{LOCAL} +procedure emit_buffered_bits (entropy : phuff_entropy_ptr; + bufstart : JBytePtr; + nbits : uInt); +var + bufptr : byteptr; +begin + if (entropy^.gather_statistics) then + exit; { no real work } + + bufptr := byteptr(bufstart); + while (nbits > 0) do + begin + emit_bits(entropy, uInt(bufptr^), 1); + Inc(bufptr); + Dec(nbits); + end; +end; + + +{ Emit any pending EOBRUN symbol. } + +{LOCAL} +procedure emit_eobrun (entropy : phuff_entropy_ptr); +var + {register} temp, nbits : int; +begin + if (entropy^.EOBRUN > 0) then + begin { if there is any pending EOBRUN } + temp := entropy^.EOBRUN; + nbits := 0; + temp := temp shr 1; + while (temp <> 0) do + begin + Inc(nbits); + temp := temp shr 1; + end; + + { safety check: shouldn't happen given limited correction-bit buffer } + if (nbits > 14) then + ERREXIT(j_common_ptr(entropy^.cinfo), JERR_HUFF_MISSING_CODE); + + emit_symbol(entropy, entropy^.ac_tbl_no, nbits shl 4); + if (nbits <> 0) then + emit_bits(entropy, entropy^.EOBRUN, nbits); + + entropy^.EOBRUN := 0; + + { Emit any buffered correction bits } + emit_buffered_bits(entropy, entropy^.bit_buffer, entropy^.BE); + entropy^.BE := 0; + end; +end; + + +{ Emit a restart marker & resynchronize predictions. } + +{LOCAL} +procedure emit_restart (entropy : phuff_entropy_ptr; + restart_num : int); +var + ci : int; +begin + emit_eobrun(entropy); + + if (not entropy^.gather_statistics) then + begin + flush_bits(entropy); + {emit_byte(entropy, $FF);} + { Outputting bytes to the file. + NB: these must be called only when actually outputting, + that is, entropy^.gather_statistics = FALSE. } + + entropy^.next_output_byte^ := JOCTET($FF); + Inc(entropy^.next_output_byte); + Dec(entropy^.free_in_buffer); + if (entropy^.free_in_buffer = 0) then + dump_buffer(entropy); + + {emit_byte(entropy, JPEG_RST0 + restart_num);} + entropy^.next_output_byte^ := JOCTET(JPEG_RST0 + restart_num); + Inc(entropy^.next_output_byte); + Dec(entropy^.free_in_buffer); + if (entropy^.free_in_buffer = 0) then + dump_buffer(entropy); + end; + + if (entropy^.cinfo^.Ss = 0) then + begin + { Re-initialize DC predictions to 0 } + for ci := 0 to pred(entropy^.cinfo^.comps_in_scan) do + entropy^.last_dc_val[ci] := 0; + end + else + begin + { Re-initialize all AC-related fields to 0 } + entropy^.EOBRUN := 0; + entropy^.BE := 0; + end; +end; + + +{ MCU encoding for DC initial scan (either spectral selection, + or first pass of successive approximation). } + +{METHODDEF} +function encode_mcu_DC_first (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; +var + entropy : phuff_entropy_ptr; + {register} temp, temp2 : int; + {register} nbits : int; + blkn, ci : int; + Al : int; + block : JBLOCK_PTR; + compptr : jpeg_component_info_ptr; + ishift_temp : int; +begin + entropy := phuff_entropy_ptr (cinfo^.entropy); + Al := cinfo^.Al; + + entropy^.next_output_byte := cinfo^.dest^.next_output_byte; + entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer; + + { Emit restart marker if needed } + if (cinfo^.restart_interval <> 0) then + if (entropy^.restarts_to_go = 0) then + emit_restart(entropy, entropy^.next_restart_num); + + { Encode the MCU data blocks } + for blkn := 0 to pred(cinfo^.blocks_in_MCU) do + begin + block := JBLOCK_PTR(MCU_data[blkn]); + ci := cinfo^.MCU_membership[blkn]; + compptr := cinfo^.cur_comp_info[ci]; + + { Compute the DC value after the required point transform by Al. + This is simply an arithmetic right shift. } + + {temp2 := IRIGHT_SHIFT( int(block^[0]), Al);} + {IRIGHT_SHIFT_IS_UNSIGNED} + ishift_temp := int(block^[0]); + if ishift_temp < 0 then + temp2 := (ishift_temp shr Al) or ((not 0) shl (16-Al)) + else + temp2 := ishift_temp shr Al; + + + { DC differences are figured on the point-transformed values. } + temp := temp2 - entropy^.last_dc_val[ci]; + entropy^.last_dc_val[ci] := temp2; + + { Encode the DC coefficient difference per section G.1.2.1 } + temp2 := temp; + if (temp < 0) then + begin + temp := -temp; { temp is abs value of input } + { For a negative input, want temp2 := bitwise complement of abs(input) } + { This code assumes we are on a two's complement machine } + Dec(temp2); + end; + + { Find the number of bits needed for the magnitude of the coefficient } + nbits := 0; + while (temp <> 0) do + begin + Inc(nbits); + temp := temp shr 1; + end; + + { Check for out-of-range coefficient values. + Since we're encoding a difference, the range limit is twice as much. } + + if (nbits > MAX_COEF_BITS+1) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_DCT_COEF); + + { Count/emit the Huffman-coded symbol for the number of bits } + emit_symbol(entropy, compptr^.dc_tbl_no, nbits); + + { Emit that number of bits of the value, if positive, } + { or the complement of its magnitude, if negative. } + if (nbits <> 0) then { emit_bits rejects calls with size 0 } + emit_bits(entropy, uInt(temp2), nbits); + end; + + cinfo^.dest^.next_output_byte := entropy^.next_output_byte; + cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer; + + { Update restart-interval state too } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + begin + entropy^.restarts_to_go := cinfo^.restart_interval; + Inc(entropy^.next_restart_num); + with entropy^ do + next_restart_num := next_restart_num and 7; + end; + Dec(entropy^.restarts_to_go); + end; + + encode_mcu_DC_first := TRUE; +end; + + +{ MCU encoding for AC initial scan (either spectral selection, + or first pass of successive approximation). } + +{METHODDEF} +function encode_mcu_AC_first (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; +var + entropy : phuff_entropy_ptr; + {register} temp, temp2 : int; + {register} nbits : int; + {register} r, k : int; + Se : int; + Al : int; + block : JBLOCK_PTR; +begin + entropy := phuff_entropy_ptr (cinfo^.entropy); + Se := cinfo^.Se; + Al := cinfo^.Al; + + entropy^.next_output_byte := cinfo^.dest^.next_output_byte; + entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer; + + { Emit restart marker if needed } + if (cinfo^.restart_interval <> 0) then + if (entropy^.restarts_to_go = 0) then + emit_restart(entropy, entropy^.next_restart_num); + + { Encode the MCU data block } + block := JBLOCK_PTR(MCU_data[0]); + + { Encode the AC coefficients per section G.1.2.2, fig. G.3 } + + r := 0; { r := run length of zeros } + + for k := cinfo^.Ss to Se do + begin + temp := (block^[jpeg_natural_order[k]]); + if (temp = 0) then + begin + Inc(r); + continue; + end; + { We must apply the point transform by Al. For AC coefficients this + is an integer division with rounding towards 0. To do this portably + in C, we shift after obtaining the absolute value; so the code is + interwoven with finding the abs value (temp) and output bits (temp2). } + + if (temp < 0) then + begin + temp := -temp; { temp is abs value of input } + temp := temp shr Al; { apply the point transform } + { For a negative coef, want temp2 := bitwise complement of abs(coef) } + temp2 := not temp; + end + else + begin + temp := temp shr Al; { apply the point transform } + temp2 := temp; + end; + { Watch out for case that nonzero coef is zero after point transform } + if (temp = 0) then + begin + Inc(r); + continue; + end; + + { Emit any pending EOBRUN } + if (entropy^.EOBRUN > 0) then + emit_eobrun(entropy); + { if run length > 15, must emit special run-length-16 codes ($F0) } + while (r > 15) do + begin + emit_symbol(entropy, entropy^.ac_tbl_no, $F0); + Dec(r, 16); + end; + + { Find the number of bits needed for the magnitude of the coefficient } + nbits := 0; { there must be at least one 1 bit } + repeat + Inc(nbits); + temp := temp shr 1; + until (temp = 0); + + { Check for out-of-range coefficient values } + if (nbits > MAX_COEF_BITS) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_DCT_COEF); + + { Count/emit Huffman symbol for run length / number of bits } + emit_symbol(entropy, entropy^.ac_tbl_no, (r shl 4) + nbits); + + { Emit that number of bits of the value, if positive, } + { or the complement of its magnitude, if negative. } + emit_bits(entropy, uInt(temp2), nbits); + + r := 0; { reset zero run length } + end; + + if (r > 0) then + begin { If there are trailing zeroes, } + Inc(entropy^.EOBRUN); { count an EOB } + if (entropy^.EOBRUN = $7FFF) then + emit_eobrun(entropy); { force it out to avoid overflow } + end; + + cinfo^.dest^.next_output_byte := entropy^.next_output_byte; + cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer; + + { Update restart-interval state too } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + begin + entropy^.restarts_to_go := cinfo^.restart_interval; + Inc(entropy^.next_restart_num); + with entropy^ do + next_restart_num := next_restart_num and 7; + end; + Dec(entropy^.restarts_to_go); + end; + + encode_mcu_AC_first := TRUE; +end; + + +{ MCU encoding for DC successive approximation refinement scan. + Note: we assume such scans can be multi-component, although the spec + is not very clear on the point. } + +{METHODDEF} +function encode_mcu_DC_refine (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; +var + entropy : phuff_entropy_ptr; + {register} temp : int; + blkn : int; + Al : int; + block : JBLOCK_PTR; +begin + entropy := phuff_entropy_ptr (cinfo^.entropy); + Al := cinfo^.Al; + + entropy^.next_output_byte := cinfo^.dest^.next_output_byte; + entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer; + + { Emit restart marker if needed } + if (cinfo^.restart_interval <> 0) then + if (entropy^.restarts_to_go = 0) then + emit_restart(entropy, entropy^.next_restart_num); + + { Encode the MCU data blocks } + for blkn := 0 to pred(cinfo^.blocks_in_MCU) do + begin + block := JBLOCK_PTR(MCU_data[blkn]); + + { We simply emit the Al'th bit of the DC coefficient value. } + temp := block^[0]; + emit_bits(entropy, uInt(temp shr Al), 1); + end; + + cinfo^.dest^.next_output_byte := entropy^.next_output_byte; + cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer; + + { Update restart-interval state too } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + begin + entropy^.restarts_to_go := cinfo^.restart_interval; + Inc(entropy^.next_restart_num); + with entropy^ do + next_restart_num := next_restart_num and 7; + end; + Dec(entropy^.restarts_to_go); + end; + + encode_mcu_DC_refine := TRUE; +end; + + +{ MCU encoding for AC successive approximation refinement scan. } + +{METHODDEF} +function encode_mcu_AC_refine (cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; + +var + entropy : phuff_entropy_ptr; + {register} temp : int; + {register} r, k : int; + EOB : int; + BR_buffer : JBytePtr; + BR : uInt; + Se : int; + Al : int; + block : JBLOCK_PTR; + absvalues : array[0..DCTSIZE2-1] of int; +begin + entropy := phuff_entropy_ptr(cinfo^.entropy); + Se := cinfo^.Se; + Al := cinfo^.Al; + + entropy^.next_output_byte := cinfo^.dest^.next_output_byte; + entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer; + + { Emit restart marker if needed } + if (cinfo^.restart_interval <> 0) then + if (entropy^.restarts_to_go = 0) then + emit_restart(entropy, entropy^.next_restart_num); + + { Encode the MCU data block } + block := JBLOCK_PTR(MCU_data[0]); + + { It is convenient to make a pre-pass to determine the transformed + coefficients' absolute values and the EOB position. } + + EOB := 0; + for k := cinfo^.Ss to Se do + begin + temp := block^[jpeg_natural_order[k]]; + { We must apply the point transform by Al. For AC coefficients this + is an integer division with rounding towards 0. To do this portably + in C, we shift after obtaining the absolute value. } + + if (temp < 0) then + temp := -temp; { temp is abs value of input } + temp := temp shr Al; { apply the point transform } + absvalues[k] := temp; { save abs value for main pass } + if (temp = 1) then + EOB := k; { EOB := index of last newly-nonzero coef } + end; + + { Encode the AC coefficients per section G.1.2.3, fig. G.7 } + + r := 0; { r := run length of zeros } + BR := 0; { BR := count of buffered bits added now } + BR_buffer := JBytePtr(@(entropy^.bit_buffer^[entropy^.BE])); + { Append bits to buffer } + + for k := cinfo^.Ss to Se do + begin + temp := absvalues[k]; + if (temp = 0) then + begin + Inc(r); + continue; + end; + + { Emit any required ZRLs, but not if they can be folded into EOB } + while (r > 15) and (k <= EOB) do + begin + { emit any pending EOBRUN and the BE correction bits } + emit_eobrun(entropy); + { Emit ZRL } + emit_symbol(entropy, entropy^.ac_tbl_no, $F0); + Dec(r, 16); + { Emit buffered correction bits that must be associated with ZRL } + emit_buffered_bits(entropy, BR_buffer, BR); + BR_buffer := entropy^.bit_buffer; { BE bits are gone now } + BR := 0; + end; + + { If the coef was previously nonzero, it only needs a correction bit. + NOTE: a straight translation of the spec's figure G.7 would suggest + that we also need to test r > 15. But if r > 15, we can only get here + if k > EOB, which implies that this coefficient is not 1. } + if (temp > 1) then + begin + { The correction bit is the next bit of the absolute value. } + BR_buffer^[BR] := byte (temp and 1); + Inc(BR); + continue; + end; + + { Emit any pending EOBRUN and the BE correction bits } + emit_eobrun(entropy); + + { Count/emit Huffman symbol for run length / number of bits } + emit_symbol(entropy, entropy^.ac_tbl_no, (r shl 4) + 1); + + { Emit output bit for newly-nonzero coef } + if (block^[jpeg_natural_order[k]] < 0) then + temp := 0 + else + temp := 1; + emit_bits(entropy, uInt(temp), 1); + + { Emit buffered correction bits that must be associated with this code } + emit_buffered_bits(entropy, BR_buffer, BR); + BR_buffer := entropy^.bit_buffer; { BE bits are gone now } + BR := 0; + r := 0; { reset zero run length } + end; + + if (r > 0) or (BR > 0) then + begin { If there are trailing zeroes, } + Inc(entropy^.EOBRUN); { count an EOB } + Inc(entropy^.BE, BR); { concat my correction bits to older ones } + { We force out the EOB if we risk either: + 1. overflow of the EOB counter; + 2. overflow of the correction bit buffer during the next MCU. } + + if (entropy^.EOBRUN = $7FFF) or + (entropy^.BE > (MAX_CORR_BITS-DCTSIZE2+1)) then + emit_eobrun(entropy); + end; + + cinfo^.dest^.next_output_byte := entropy^.next_output_byte; + cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer; + + { Update restart-interval state too } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + begin + entropy^.restarts_to_go := cinfo^.restart_interval; + Inc(entropy^.next_restart_num); + with entropy^ do + next_restart_num := next_restart_num and 7; + end; + Dec(entropy^.restarts_to_go); + end; + + encode_mcu_AC_refine := TRUE; +end; + + +{ Finish up at the end of a Huffman-compressed progressive scan. } + +{METHODDEF} +procedure finish_pass_phuff (cinfo : j_compress_ptr); +var + entropy : phuff_entropy_ptr; +begin + entropy := phuff_entropy_ptr (cinfo^.entropy); + + entropy^.next_output_byte := cinfo^.dest^.next_output_byte; + entropy^.free_in_buffer := cinfo^.dest^.free_in_buffer; + + { Flush out any buffered data } + emit_eobrun(entropy); + flush_bits(entropy); + + cinfo^.dest^.next_output_byte := entropy^.next_output_byte; + cinfo^.dest^.free_in_buffer := entropy^.free_in_buffer; +end; + + +{ Finish up a statistics-gathering pass and create the new Huffman tables. } + +{METHODDEF} +procedure finish_pass_gather_phuff (cinfo : j_compress_ptr); +var + entropy : phuff_entropy_ptr; + is_DC_band : boolean; + ci, tbl : int; + compptr : jpeg_component_info_ptr; + htblptr : ^JHUFF_TBL_PTR; + did : array[0..NUM_HUFF_TBLS-1] of boolean; +begin + tbl := 0; + entropy := phuff_entropy_ptr (cinfo^.entropy); + + { Flush out buffered data (all we care about is counting the EOB symbol) } + emit_eobrun(entropy); + + is_DC_band := (cinfo^.Ss = 0); + + { It's important not to apply jpeg_gen_optimal_table more than once + per table, because it clobbers the input frequency counts! } + + MEMZERO(@did, SIZEOF(did)); + + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + if (is_DC_band) then + begin + if (cinfo^.Ah <> 0) then { DC refinement needs no table } + continue; + tbl := compptr^.dc_tbl_no; + end + else + begin + tbl := compptr^.ac_tbl_no; + end; + if (not did[tbl]) then + begin + if (is_DC_band) then + htblptr := @(cinfo^.dc_huff_tbl_ptrs[tbl]) + else + htblptr := @(cinfo^.ac_huff_tbl_ptrs[tbl]); + if (htblptr^ = NIL) then + htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo)); + jpeg_gen_optimal_table(cinfo, htblptr^, entropy^.count_ptrs[tbl]^); + did[tbl] := TRUE; + end; + end; +end; + + +{ Module initialization routine for progressive Huffman entropy encoding. } + +{GLOBAL} +procedure jinit_phuff_encoder (cinfo : j_compress_ptr); +var + entropy : phuff_entropy_ptr; + i : int; +begin + entropy := phuff_entropy_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(phuff_entropy_encoder)) ); + cinfo^.entropy := jpeg_entropy_encoder_ptr(entropy); + entropy^.pub.start_pass := start_pass_phuff; + + { Mark tables unallocated } + for i := 0 to pred(NUM_HUFF_TBLS) do + begin + entropy^.derived_tbls[i] := NIL; + entropy^.count_ptrs[i] := NIL; + end; + entropy^.bit_buffer := NIL; { needed only in AC refinement scan } +end; + +end. diff --git a/Imaging/JpegLib/imjcprepct.pas b/Imaging/JpegLib/imjcprepct.pas index 9750652..c05ac8b 100644 --- a/Imaging/JpegLib/imjcprepct.pas +++ b/Imaging/JpegLib/imjcprepct.pas @@ -1,406 +1,406 @@ -unit imjcprepct; - -{ Original : jcprepct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - -{ This file contains the compression preprocessing controller. - This controller manages the color conversion, downsampling, - and edge expansion steps. - - Most of the complexity here is associated with buffering input rows - as required by the downsampler. See the comments at the head of - jcsample.c for the downsampler's needs. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjpeglib, - imjdeferr, - imjerror, - imjinclude, - imjutils; - -{GLOBAL} -procedure jinit_c_prep_controller (cinfo : j_compress_ptr; - need_full_buffer : boolean); - -implementation - - -{ At present, jcsample.c can request context rows only for smoothing. - In the future, we might also need context rows for CCIR601 sampling - or other more-complex downsampling procedures. The code to support - context rows should be compiled only if needed. } - -{$ifdef INPUT_SMOOTHING_SUPPORTED} - {$define CONTEXT_ROWS_SUPPORTED} -{$endif} - - -{ For the simple (no-context-row) case, we just need to buffer one - row group's worth of pixels for the downsampling step. At the bottom of - the image, we pad to a full row group by replicating the last pixel row. - The downsampler's last output row is then replicated if needed to pad - out to a full iMCU row. - - When providing context rows, we must buffer three row groups' worth of - pixels. Three row groups are physically allocated, but the row pointer - arrays are made five row groups high, with the extra pointers above and - below "wrapping around" to point to the last and first real row groups. - This allows the downsampler to access the proper context rows. - At the top and bottom of the image, we create dummy context rows by - copying the first or last real pixel row. This copying could be avoided - by pointer hacking as is done in jdmainct.c, but it doesn't seem worth the - trouble on the compression side. } - - -{ Private buffer controller object } - -type - my_prep_ptr = ^my_prep_controller; - my_prep_controller = record - pub : jpeg_c_prep_controller; { public fields } - - { Downsampling input buffer. This buffer holds color-converted data - until we have enough to do a downsample step. } - - color_buf : array[0..MAX_COMPONENTS-1] of JSAMPARRAY; - - rows_to_go : JDIMENSION; { counts rows remaining in source image } - next_buf_row : int; { index of next row to store in color_buf } - - {$ifdef CONTEXT_ROWS_SUPPORTED} { only needed for context case } - this_row_group : int; { starting row index of group to process } - next_buf_stop : int; { downsample when we reach this index } - {$endif} - end; {my_prep_controller;} - - -{ Initialize for a processing pass. } - -{METHODDEF} -procedure start_pass_prep (cinfo : j_compress_ptr; - pass_mode : J_BUF_MODE ); -var - prep : my_prep_ptr; -begin - prep := my_prep_ptr (cinfo^.prep); - - if (pass_mode <> JBUF_PASS_THRU) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - - { Initialize total-height counter for detecting bottom of image } - prep^.rows_to_go := cinfo^.image_height; - { Mark the conversion buffer empty } - prep^.next_buf_row := 0; -{$ifdef CONTEXT_ROWS_SUPPORTED} - { Preset additional state variables for context mode. - These aren't used in non-context mode, so we needn't test which mode. } - prep^.this_row_group := 0; - { Set next_buf_stop to stop after two row groups have been read in. } - prep^.next_buf_stop := 2 * cinfo^.max_v_samp_factor; -{$endif} -end; - - -{ Expand an image vertically from height input_rows to height output_rows, - by duplicating the bottom row. } - -{LOCAL} -procedure expand_bottom_edge (image_data : JSAMPARRAY; - num_cols : JDIMENSION; - input_rows : int; - output_rows : int); -var - {register} row : int; -begin - for row := input_rows to pred(output_rows) do - begin - jcopy_sample_rows(image_data, input_rows-1, image_data, row, - 1, num_cols); - end; -end; - - -{ Process some data in the simple no-context case. - - Preprocessor output data is counted in "row groups". A row group - is defined to be v_samp_factor sample rows of each component. - Downsampling will produce this much data from each max_v_samp_factor - input rows. } - -{METHODDEF} -procedure pre_process_data (cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - var in_row_ctr : JDIMENSION; - in_rows_avail : JDIMENSION; - output_buf : JSAMPIMAGE; - var out_row_group_ctr : JDIMENSION; - out_row_groups_avail : JDIMENSION); -var - prep : my_prep_ptr; - numrows, ci : int; - inrows : JDIMENSION; - compptr : jpeg_component_info_ptr; -var - local_input_buf : JSAMPARRAY; -begin - prep := my_prep_ptr (cinfo^.prep); - - while (in_row_ctr < in_rows_avail) and - (out_row_group_ctr < out_row_groups_avail) do - begin - { Do color conversion to fill the conversion buffer. } - inrows := in_rows_avail - in_row_ctr; - numrows := cinfo^.max_v_samp_factor - prep^.next_buf_row; - {numrows := int( MIN(JDIMENSION(numrows), inrows) );} - if inrows < JDIMENSION(numrows) then - numrows := int(inrows); - local_input_buf := JSAMPARRAY(@(input_buf^[in_row_ctr])); - cinfo^.cconvert^.color_convert (cinfo, local_input_buf, - JSAMPIMAGE(@prep^.color_buf), - JDIMENSION(prep^.next_buf_row), - numrows); - Inc(in_row_ctr, numrows); - Inc(prep^.next_buf_row, numrows); - Dec(prep^.rows_to_go, numrows); - { If at bottom of image, pad to fill the conversion buffer. } - if (prep^.rows_to_go = 0) and - (prep^.next_buf_row < cinfo^.max_v_samp_factor) then - begin - for ci := 0 to pred(cinfo^.num_components) do - begin - expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width, - prep^.next_buf_row, cinfo^.max_v_samp_factor); - end; - prep^.next_buf_row := cinfo^.max_v_samp_factor; - end; - { If we've filled the conversion buffer, empty it. } - if (prep^.next_buf_row = cinfo^.max_v_samp_factor) then - begin - cinfo^.downsample^.downsample (cinfo, - JSAMPIMAGE(@prep^.color_buf), - JDIMENSION (0), - output_buf, - out_row_group_ctr); - prep^.next_buf_row := 0; - Inc(out_row_group_ctr);; - end; - { If at bottom of image, pad the output to a full iMCU height. - Note we assume the caller is providing a one-iMCU-height output buffer! } - if (prep^.rows_to_go = 0) and - (out_row_group_ctr < out_row_groups_avail) then - begin - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - expand_bottom_edge(output_buf^[ci], - compptr^.width_in_blocks * DCTSIZE, - int (out_row_group_ctr) * compptr^.v_samp_factor, - int (out_row_groups_avail) * compptr^.v_samp_factor); - Inc(compptr); - end; - out_row_group_ctr := out_row_groups_avail; - break; { can exit outer loop without test } - end; - end; -end; - - -{$ifdef CONTEXT_ROWS_SUPPORTED} - -{ Process some data in the context case. } - -{METHODDEF} -procedure pre_process_context (cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - var in_row_ctr : JDIMENSION; - in_rows_avail : JDIMENSION; - output_buf : JSAMPIMAGE; - var out_row_group_ctr : JDIMENSION; - out_row_groups_avail : JDIMENSION); -var - prep : my_prep_ptr; - numrows, ci : int; - buf_height : int; - inrows : JDIMENSION; -var - row : int; - -begin - prep := my_prep_ptr (cinfo^.prep); - buf_height := cinfo^.max_v_samp_factor * 3; - - while (out_row_group_ctr < out_row_groups_avail) do - begin - if (in_row_ctr < in_rows_avail) then - begin - { Do color conversion to fill the conversion buffer. } - inrows := in_rows_avail - in_row_ctr; - numrows := prep^.next_buf_stop - prep^.next_buf_row; - {numrows := int ( MIN( JDIMENSION(numrows), inrows) );} - if inrows < JDIMENSION(numrows) then - numrows := int(inrows); - cinfo^.cconvert^.color_convert (cinfo, - JSAMPARRAY(@input_buf^[in_row_ctr]), - JSAMPIMAGE(@prep^.color_buf), - JDIMENSION (prep^.next_buf_row), - numrows); - { Pad at top of image, if first time through } - if (prep^.rows_to_go = cinfo^.image_height) then - begin - for ci := 0 to pred(cinfo^.num_components) do - begin - for row := 1 to cinfo^.max_v_samp_factor do - begin - jcopy_sample_rows(prep^.color_buf[ci], 0, - prep^.color_buf[ci], -row, - 1, cinfo^.image_width); - end; - end; - end; - Inc(in_row_ctr, numrows); - Inc(prep^.next_buf_row, numrows); - Dec(prep^.rows_to_go, numrows); - end - else - begin - { Return for more data, unless we are at the bottom of the image. } - if (prep^.rows_to_go <> 0) then - break; - { When at bottom of image, pad to fill the conversion buffer. } - if (prep^.next_buf_row < prep^.next_buf_stop) then - begin - for ci := 0 to pred(cinfo^.num_components) do - begin - expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width, - prep^.next_buf_row, prep^.next_buf_stop); - end; - prep^.next_buf_row := prep^.next_buf_stop; - end; - end; - { If we've gotten enough data, downsample a row group. } - if (prep^.next_buf_row = prep^.next_buf_stop) then - begin - cinfo^.downsample^.downsample (cinfo, - JSAMPIMAGE(@prep^.color_buf), - JDIMENSION(prep^.this_row_group), - output_buf, - out_row_group_ctr); - Inc(out_row_group_ctr); - { Advance pointers with wraparound as necessary. } - Inc(prep^.this_row_group, cinfo^.max_v_samp_factor); - if (prep^.this_row_group >= buf_height) then - prep^.this_row_group := 0; - if (prep^.next_buf_row >= buf_height) then - prep^.next_buf_row := 0; - prep^.next_buf_stop := prep^.next_buf_row + cinfo^.max_v_samp_factor; - end; - end; -end; - - -{ Create the wrapped-around downsampling input buffer needed for context mode. } - -{LOCAL} -procedure create_context_buffer (cinfo : j_compress_ptr); -var - prep : my_prep_ptr; - rgroup_height : int; - ci, i : int; - compptr : jpeg_component_info_ptr; - true_buffer, fake_buffer : JSAMPARRAY; -begin - prep := my_prep_ptr (cinfo^.prep); - rgroup_height := cinfo^.max_v_samp_factor; - { Grab enough space for fake row pointers for all the components; - we need five row groups' worth of pointers for each component. } - - fake_buffer := JSAMPARRAY( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - (cinfo^.num_components * 5 * rgroup_height) * - SIZEOF(JSAMPROW)) ); - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - { Allocate the actual buffer space (3 row groups) for this component. - We make the buffer wide enough to allow the downsampler to edge-expand - horizontally within the buffer, if it so chooses. } - true_buffer := cinfo^.mem^.alloc_sarray - (j_common_ptr(cinfo), JPOOL_IMAGE, - JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE * - cinfo^.max_h_samp_factor) div compptr^.h_samp_factor), - JDIMENSION (3 * rgroup_height)); - { Copy true buffer row pointers into the middle of the fake row array } - MEMCOPY(JSAMPARRAY(@ fake_buffer^[rgroup_height]), true_buffer, - 3 * rgroup_height * SIZEOF(JSAMPROW)); - { Fill in the above and below wraparound pointers } - for i := 0 to pred(rgroup_height) do - begin - fake_buffer^[i] := true_buffer^[2 * rgroup_height + i]; - fake_buffer^[4 * rgroup_height + i] := true_buffer^[i]; - end; - prep^.color_buf[ci] := JSAMPARRAY(@ fake_buffer^[rgroup_height]); - Inc(JSAMPROW_PTR(fake_buffer), 5 * rgroup_height); { point to space for next component } - Inc(compptr); - end; -end; - -{$endif} { CONTEXT_ROWS_SUPPORTED } - - -{ Initialize preprocessing controller. } - -{GLOBAL} -procedure jinit_c_prep_controller (cinfo : j_compress_ptr; - need_full_buffer : boolean); -var - prep : my_prep_ptr; - ci : int; - compptr : jpeg_component_info_ptr; -begin - - if (need_full_buffer) then { safety check } - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - - prep := my_prep_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_prep_controller)) ); - cinfo^.prep := jpeg_c_prep_controller_ptr(prep); - prep^.pub.start_pass := start_pass_prep; - - { Allocate the color conversion buffer. - We make the buffer wide enough to allow the downsampler to edge-expand - horizontally within the buffer, if it so chooses. } - - if (cinfo^.downsample^.need_context_rows) then - begin - { Set up to provide context rows } -{$ifdef CONTEXT_ROWS_SUPPORTED} - prep^.pub.pre_process_data := pre_process_context; - create_context_buffer(cinfo); -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} - end - else - begin - { No context, just make it tall enough for one row group } - prep^.pub.pre_process_data := pre_process_data; - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - prep^.color_buf[ci] := cinfo^.mem^.alloc_sarray - (j_common_ptr(cinfo), JPOOL_IMAGE, - JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE * - cinfo^.max_h_samp_factor) div compptr^.h_samp_factor), - JDIMENSION(cinfo^.max_v_samp_factor) ); - Inc(compptr); - end; - end; -end; - -end. +unit imjcprepct; + +{ Original : jcprepct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + +{ This file contains the compression preprocessing controller. + This controller manages the color conversion, downsampling, + and edge expansion steps. + + Most of the complexity here is associated with buffering input rows + as required by the downsampler. See the comments at the head of + jcsample.c for the downsampler's needs. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjpeglib, + imjdeferr, + imjerror, + imjinclude, + imjutils; + +{GLOBAL} +procedure jinit_c_prep_controller (cinfo : j_compress_ptr; + need_full_buffer : boolean); + +implementation + + +{ At present, jcsample.c can request context rows only for smoothing. + In the future, we might also need context rows for CCIR601 sampling + or other more-complex downsampling procedures. The code to support + context rows should be compiled only if needed. } + +{$ifdef INPUT_SMOOTHING_SUPPORTED} + {$define CONTEXT_ROWS_SUPPORTED} +{$endif} + + +{ For the simple (no-context-row) case, we just need to buffer one + row group's worth of pixels for the downsampling step. At the bottom of + the image, we pad to a full row group by replicating the last pixel row. + The downsampler's last output row is then replicated if needed to pad + out to a full iMCU row. + + When providing context rows, we must buffer three row groups' worth of + pixels. Three row groups are physically allocated, but the row pointer + arrays are made five row groups high, with the extra pointers above and + below "wrapping around" to point to the last and first real row groups. + This allows the downsampler to access the proper context rows. + At the top and bottom of the image, we create dummy context rows by + copying the first or last real pixel row. This copying could be avoided + by pointer hacking as is done in jdmainct.c, but it doesn't seem worth the + trouble on the compression side. } + + +{ Private buffer controller object } + +type + my_prep_ptr = ^my_prep_controller; + my_prep_controller = record + pub : jpeg_c_prep_controller; { public fields } + + { Downsampling input buffer. This buffer holds color-converted data + until we have enough to do a downsample step. } + + color_buf : array[0..MAX_COMPONENTS-1] of JSAMPARRAY; + + rows_to_go : JDIMENSION; { counts rows remaining in source image } + next_buf_row : int; { index of next row to store in color_buf } + + {$ifdef CONTEXT_ROWS_SUPPORTED} { only needed for context case } + this_row_group : int; { starting row index of group to process } + next_buf_stop : int; { downsample when we reach this index } + {$endif} + end; {my_prep_controller;} + + +{ Initialize for a processing pass. } + +{METHODDEF} +procedure start_pass_prep (cinfo : j_compress_ptr; + pass_mode : J_BUF_MODE ); +var + prep : my_prep_ptr; +begin + prep := my_prep_ptr (cinfo^.prep); + + if (pass_mode <> JBUF_PASS_THRU) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + + { Initialize total-height counter for detecting bottom of image } + prep^.rows_to_go := cinfo^.image_height; + { Mark the conversion buffer empty } + prep^.next_buf_row := 0; +{$ifdef CONTEXT_ROWS_SUPPORTED} + { Preset additional state variables for context mode. + These aren't used in non-context mode, so we needn't test which mode. } + prep^.this_row_group := 0; + { Set next_buf_stop to stop after two row groups have been read in. } + prep^.next_buf_stop := 2 * cinfo^.max_v_samp_factor; +{$endif} +end; + + +{ Expand an image vertically from height input_rows to height output_rows, + by duplicating the bottom row. } + +{LOCAL} +procedure expand_bottom_edge (image_data : JSAMPARRAY; + num_cols : JDIMENSION; + input_rows : int; + output_rows : int); +var + {register} row : int; +begin + for row := input_rows to pred(output_rows) do + begin + jcopy_sample_rows(image_data, input_rows-1, image_data, row, + 1, num_cols); + end; +end; + + +{ Process some data in the simple no-context case. + + Preprocessor output data is counted in "row groups". A row group + is defined to be v_samp_factor sample rows of each component. + Downsampling will produce this much data from each max_v_samp_factor + input rows. } + +{METHODDEF} +procedure pre_process_data (cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + var in_row_ctr : JDIMENSION; + in_rows_avail : JDIMENSION; + output_buf : JSAMPIMAGE; + var out_row_group_ctr : JDIMENSION; + out_row_groups_avail : JDIMENSION); +var + prep : my_prep_ptr; + numrows, ci : int; + inrows : JDIMENSION; + compptr : jpeg_component_info_ptr; +var + local_input_buf : JSAMPARRAY; +begin + prep := my_prep_ptr (cinfo^.prep); + + while (in_row_ctr < in_rows_avail) and + (out_row_group_ctr < out_row_groups_avail) do + begin + { Do color conversion to fill the conversion buffer. } + inrows := in_rows_avail - in_row_ctr; + numrows := cinfo^.max_v_samp_factor - prep^.next_buf_row; + {numrows := int( MIN(JDIMENSION(numrows), inrows) );} + if inrows < JDIMENSION(numrows) then + numrows := int(inrows); + local_input_buf := JSAMPARRAY(@(input_buf^[in_row_ctr])); + cinfo^.cconvert^.color_convert (cinfo, local_input_buf, + JSAMPIMAGE(@prep^.color_buf), + JDIMENSION(prep^.next_buf_row), + numrows); + Inc(in_row_ctr, numrows); + Inc(prep^.next_buf_row, numrows); + Dec(prep^.rows_to_go, numrows); + { If at bottom of image, pad to fill the conversion buffer. } + if (prep^.rows_to_go = 0) and + (prep^.next_buf_row < cinfo^.max_v_samp_factor) then + begin + for ci := 0 to pred(cinfo^.num_components) do + begin + expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width, + prep^.next_buf_row, cinfo^.max_v_samp_factor); + end; + prep^.next_buf_row := cinfo^.max_v_samp_factor; + end; + { If we've filled the conversion buffer, empty it. } + if (prep^.next_buf_row = cinfo^.max_v_samp_factor) then + begin + cinfo^.downsample^.downsample (cinfo, + JSAMPIMAGE(@prep^.color_buf), + JDIMENSION (0), + output_buf, + out_row_group_ctr); + prep^.next_buf_row := 0; + Inc(out_row_group_ctr);; + end; + { If at bottom of image, pad the output to a full iMCU height. + Note we assume the caller is providing a one-iMCU-height output buffer! } + if (prep^.rows_to_go = 0) and + (out_row_group_ctr < out_row_groups_avail) then + begin + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + expand_bottom_edge(output_buf^[ci], + compptr^.width_in_blocks * DCTSIZE, + int (out_row_group_ctr) * compptr^.v_samp_factor, + int (out_row_groups_avail) * compptr^.v_samp_factor); + Inc(compptr); + end; + out_row_group_ctr := out_row_groups_avail; + break; { can exit outer loop without test } + end; + end; +end; + + +{$ifdef CONTEXT_ROWS_SUPPORTED} + +{ Process some data in the context case. } + +{METHODDEF} +procedure pre_process_context (cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + var in_row_ctr : JDIMENSION; + in_rows_avail : JDIMENSION; + output_buf : JSAMPIMAGE; + var out_row_group_ctr : JDIMENSION; + out_row_groups_avail : JDIMENSION); +var + prep : my_prep_ptr; + numrows, ci : int; + buf_height : int; + inrows : JDIMENSION; +var + row : int; + +begin + prep := my_prep_ptr (cinfo^.prep); + buf_height := cinfo^.max_v_samp_factor * 3; + + while (out_row_group_ctr < out_row_groups_avail) do + begin + if (in_row_ctr < in_rows_avail) then + begin + { Do color conversion to fill the conversion buffer. } + inrows := in_rows_avail - in_row_ctr; + numrows := prep^.next_buf_stop - prep^.next_buf_row; + {numrows := int ( MIN( JDIMENSION(numrows), inrows) );} + if inrows < JDIMENSION(numrows) then + numrows := int(inrows); + cinfo^.cconvert^.color_convert (cinfo, + JSAMPARRAY(@input_buf^[in_row_ctr]), + JSAMPIMAGE(@prep^.color_buf), + JDIMENSION (prep^.next_buf_row), + numrows); + { Pad at top of image, if first time through } + if (prep^.rows_to_go = cinfo^.image_height) then + begin + for ci := 0 to pred(cinfo^.num_components) do + begin + for row := 1 to cinfo^.max_v_samp_factor do + begin + jcopy_sample_rows(prep^.color_buf[ci], 0, + prep^.color_buf[ci], -row, + 1, cinfo^.image_width); + end; + end; + end; + Inc(in_row_ctr, numrows); + Inc(prep^.next_buf_row, numrows); + Dec(prep^.rows_to_go, numrows); + end + else + begin + { Return for more data, unless we are at the bottom of the image. } + if (prep^.rows_to_go <> 0) then + break; + { When at bottom of image, pad to fill the conversion buffer. } + if (prep^.next_buf_row < prep^.next_buf_stop) then + begin + for ci := 0 to pred(cinfo^.num_components) do + begin + expand_bottom_edge(prep^.color_buf[ci], cinfo^.image_width, + prep^.next_buf_row, prep^.next_buf_stop); + end; + prep^.next_buf_row := prep^.next_buf_stop; + end; + end; + { If we've gotten enough data, downsample a row group. } + if (prep^.next_buf_row = prep^.next_buf_stop) then + begin + cinfo^.downsample^.downsample (cinfo, + JSAMPIMAGE(@prep^.color_buf), + JDIMENSION(prep^.this_row_group), + output_buf, + out_row_group_ctr); + Inc(out_row_group_ctr); + { Advance pointers with wraparound as necessary. } + Inc(prep^.this_row_group, cinfo^.max_v_samp_factor); + if (prep^.this_row_group >= buf_height) then + prep^.this_row_group := 0; + if (prep^.next_buf_row >= buf_height) then + prep^.next_buf_row := 0; + prep^.next_buf_stop := prep^.next_buf_row + cinfo^.max_v_samp_factor; + end; + end; +end; + + +{ Create the wrapped-around downsampling input buffer needed for context mode. } + +{LOCAL} +procedure create_context_buffer (cinfo : j_compress_ptr); +var + prep : my_prep_ptr; + rgroup_height : int; + ci, i : int; + compptr : jpeg_component_info_ptr; + true_buffer, fake_buffer : JSAMPARRAY; +begin + prep := my_prep_ptr (cinfo^.prep); + rgroup_height := cinfo^.max_v_samp_factor; + { Grab enough space for fake row pointers for all the components; + we need five row groups' worth of pointers for each component. } + + fake_buffer := JSAMPARRAY( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + (cinfo^.num_components * 5 * rgroup_height) * + SIZEOF(JSAMPROW)) ); + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + { Allocate the actual buffer space (3 row groups) for this component. + We make the buffer wide enough to allow the downsampler to edge-expand + horizontally within the buffer, if it so chooses. } + true_buffer := cinfo^.mem^.alloc_sarray + (j_common_ptr(cinfo), JPOOL_IMAGE, + JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE * + cinfo^.max_h_samp_factor) div compptr^.h_samp_factor), + JDIMENSION (3 * rgroup_height)); + { Copy true buffer row pointers into the middle of the fake row array } + MEMCOPY(JSAMPARRAY(@ fake_buffer^[rgroup_height]), true_buffer, + 3 * rgroup_height * SIZEOF(JSAMPROW)); + { Fill in the above and below wraparound pointers } + for i := 0 to pred(rgroup_height) do + begin + fake_buffer^[i] := true_buffer^[2 * rgroup_height + i]; + fake_buffer^[4 * rgroup_height + i] := true_buffer^[i]; + end; + prep^.color_buf[ci] := JSAMPARRAY(@ fake_buffer^[rgroup_height]); + Inc(JSAMPROW_PTR(fake_buffer), 5 * rgroup_height); { point to space for next component } + Inc(compptr); + end; +end; + +{$endif} { CONTEXT_ROWS_SUPPORTED } + + +{ Initialize preprocessing controller. } + +{GLOBAL} +procedure jinit_c_prep_controller (cinfo : j_compress_ptr; + need_full_buffer : boolean); +var + prep : my_prep_ptr; + ci : int; + compptr : jpeg_component_info_ptr; +begin + + if (need_full_buffer) then { safety check } + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + + prep := my_prep_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_prep_controller)) ); + cinfo^.prep := jpeg_c_prep_controller_ptr(prep); + prep^.pub.start_pass := start_pass_prep; + + { Allocate the color conversion buffer. + We make the buffer wide enough to allow the downsampler to edge-expand + horizontally within the buffer, if it so chooses. } + + if (cinfo^.downsample^.need_context_rows) then + begin + { Set up to provide context rows } +{$ifdef CONTEXT_ROWS_SUPPORTED} + prep^.pub.pre_process_data := pre_process_context; + create_context_buffer(cinfo); +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} + end + else + begin + { No context, just make it tall enough for one row group } + prep^.pub.pre_process_data := pre_process_data; + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + prep^.color_buf[ci] := cinfo^.mem^.alloc_sarray + (j_common_ptr(cinfo), JPOOL_IMAGE, + JDIMENSION (( long(compptr^.width_in_blocks) * DCTSIZE * + cinfo^.max_h_samp_factor) div compptr^.h_samp_factor), + JDIMENSION(cinfo^.max_v_samp_factor) ); + Inc(compptr); + end; + end; +end; + +end. diff --git a/Imaging/JpegLib/imjcsample.pas b/Imaging/JpegLib/imjcsample.pas index 5be2e80..8cce199 100644 --- a/Imaging/JpegLib/imjcsample.pas +++ b/Imaging/JpegLib/imjcsample.pas @@ -1,631 +1,631 @@ -unit imjcsample; - -{ This file contains downsampling routines. - - Downsampling input data is counted in "row groups". A row group - is defined to be max_v_samp_factor pixel rows of each component, - from which the downsampler produces v_samp_factor sample rows. - A single row group is processed in each call to the downsampler module. - - The downsampler is responsible for edge-expansion of its output data - to fill an integral number of DCT blocks horizontally. The source buffer - may be modified if it is helpful for this purpose (the source buffer is - allocated wide enough to correspond to the desired output width). - The caller (the prep controller) is responsible for vertical padding. - - The downsampler may request "context rows" by setting need_context_rows - during startup. In this case, the input arrays will contain at least - one row group's worth of pixels above and below the passed-in data; - the caller will create dummy rows at image top and bottom by replicating - the first or last real pixel row. - - An excellent reference for image resampling is - Digital Image Warping, George Wolberg, 1990. - Pub. by IEEE Computer Society Press, Los Alamitos, CA. ISBN 0-8186-8944-7. - - The downsampling algorithm used here is a simple average of the source - pixels covered by the output pixel. The hi-falutin sampling literature - refers to this as a "box filter". In general the characteristics of a box - filter are not very good, but for the specific cases we normally use (1:1 - and 2:1 ratios) the box is equivalent to a "triangle filter" which is not - nearly so bad. If you intend to use other sampling ratios, you'd be well - advised to improve this code. - - A simple input-smoothing capability is provided. This is mainly intended - for cleaning up color-dithered GIF input files (if you find it inadequate, - we suggest using an external filtering program such as pnmconvol). When - enabled, each input pixel P is replaced by a weighted sum of itself and its - eight neighbors. P's weight is 1-8*SF and each neighbor's weight is SF, - where SF := (smoothing_factor / 1024). - Currently, smoothing is only supported for 2h2v sampling factors. } - -{ Original: jcsample.c ; Copyright (C) 1991-1996, Thomas G. Lane. } - - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjutils, - imjdeferr, - imjerror, - imjpeglib; - - -{ Module initialization routine for downsampling. - Note that we must select a routine for each component. } - -{GLOBAL} -procedure jinit_downsampler (cinfo : j_compress_ptr); - -implementation - -{ Pointer to routine to downsample a single component } -type - downsample1_ptr = procedure(cinfo : j_compress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - output_data : JSAMPARRAY); - -{ Private subobject } - -type - my_downsample_ptr = ^my_downsampler; - my_downsampler = record - pub : jpeg_downsampler; { public fields } - - { Downsampling method pointers, one per component } - methods : array[0..MAX_COMPONENTS-1] of downsample1_ptr; - end; - -{ Initialize for a downsampling pass. } - -{METHODDEF} -procedure start_pass_downsample (cinfo : j_compress_ptr); -begin - { no work for now } -end; - - -{ Expand a component horizontally from width input_cols to width output_cols, - by duplicating the rightmost samples. } - -{LOCAL} -procedure expand_right_edge (image_data : JSAMPARRAY; - num_rows : int; - input_cols : JDIMENSION; - output_cols : JDIMENSION); -var - {register} ptr : JSAMPLE_PTR; - {register} pixval : JSAMPLE; - {register} count : int; - row : int; - numcols : int; -begin - numcols := int (output_cols - input_cols); - - if (numcols > 0) then - begin - for row := 0 to pred(num_rows) do - begin - ptr := JSAMPLE_PTR(@(image_data^[row]^[input_cols-1])); - pixval := ptr^; { don't need GETJSAMPLE() here } - for count := pred(numcols) downto 0 do - begin - Inc(ptr); - ptr^ := pixval; - end; - end; - end; -end; - - -{ Do downsampling for a whole row group (all components). - - In this version we simply downsample each component independently. } - -{METHODDEF} -procedure sep_downsample (cinfo : j_compress_ptr; - input_buf : JSAMPIMAGE; - in_row_index : JDIMENSION; - output_buf : JSAMPIMAGE; - out_row_group_index : JDIMENSION); -var - downsample : my_downsample_ptr; - ci : int; - compptr : jpeg_component_info_ptr; - in_ptr, out_ptr : JSAMPARRAY; -begin - downsample := my_downsample_ptr (cinfo^.downsample); - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - in_ptr := JSAMPARRAY(@ input_buf^[ci]^[in_row_index]); - out_ptr := JSAMPARRAY(@ output_buf^[ci]^ - [out_row_group_index * JDIMENSION(compptr^.v_samp_factor)]); - downsample^.methods[ci] (cinfo, compptr, in_ptr, out_ptr); - Inc(compptr); - end; -end; - - -{ Downsample pixel values of a single component. - One row group is processed per call. - This version handles arbitrary integral sampling ratios, without smoothing. - Note that this version is not actually used for customary sampling ratios. } - -{METHODDEF} -procedure int_downsample (cinfo : j_compress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - output_data : JSAMPARRAY); -var - inrow, outrow, h_expand, v_expand, numpix, numpix2, h, v : int; - outcol, outcol_h : JDIMENSION; { outcol_h = outcol*h_expand } - output_cols : JDIMENSION; - inptr, - outptr : JSAMPLE_PTR; - outvalue : INT32; -begin - output_cols := compptr^.width_in_blocks * DCTSIZE; - - h_expand := cinfo^.max_h_samp_factor div compptr^.h_samp_factor; - v_expand := cinfo^.max_v_samp_factor div compptr^.v_samp_factor; - numpix := h_expand * v_expand; - numpix2 := numpix div 2; - - { Expand input data enough to let all the output samples be generated - by the standard loop. Special-casing padded output would be more - efficient. } - - expand_right_edge(input_data, cinfo^.max_v_samp_factor, - cinfo^.image_width, output_cols * JDIMENSION(h_expand)); - - inrow := 0; - for outrow := 0 to pred(compptr^.v_samp_factor) do - begin - outptr := JSAMPLE_PTR(output_data^[outrow]); - outcol_h := 0; - for outcol := 0 to pred(output_cols) do - begin - outvalue := 0; - for v := 0 to pred(v_expand) do - begin - inptr := @(input_data^[inrow+v]^[outcol_h]); - for h := 0 to pred(h_expand) do - begin - Inc(outvalue, INT32 (GETJSAMPLE(inptr^)) ); - Inc(inptr); - end; - end; - outptr^ := JSAMPLE ((outvalue + numpix2) div numpix); - Inc(outptr); - Inc(outcol_h, h_expand); - end; - Inc(inrow, v_expand); - end; -end; - - -{ Downsample pixel values of a single component. - This version handles the special case of a full-size component, - without smoothing. } - -{METHODDEF} -procedure fullsize_downsample (cinfo : j_compress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - output_data : JSAMPARRAY); -begin - { Copy the data } - jcopy_sample_rows(input_data, 0, output_data, 0, - cinfo^.max_v_samp_factor, cinfo^.image_width); - { Edge-expand } - expand_right_edge(output_data, cinfo^.max_v_samp_factor, - cinfo^.image_width, compptr^.width_in_blocks * DCTSIZE); -end; - - -{ Downsample pixel values of a single component. - This version handles the common case of 2:1 horizontal and 1:1 vertical, - without smoothing. - - A note about the "bias" calculations: when rounding fractional values to - integer, we do not want to always round 0.5 up to the next integer. - If we did that, we'd introduce a noticeable bias towards larger values. - Instead, this code is arranged so that 0.5 will be rounded up or down at - alternate pixel locations (a simple ordered dither pattern). } - -{METHODDEF} -procedure h2v1_downsample (cinfo : j_compress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - output_data : JSAMPARRAY); -var - outrow : int; - outcol : JDIMENSION; - output_cols : JDIMENSION; - {register} inptr, outptr : JSAMPLE_PTR; - {register} bias : int; -begin - output_cols := compptr^.width_in_blocks * DCTSIZE; - - { Expand input data enough to let all the output samples be generated - by the standard loop. Special-casing padded output would be more - efficient. } - - expand_right_edge(input_data, cinfo^.max_v_samp_factor, - cinfo^.image_width, output_cols * 2); - - for outrow := 0 to pred(compptr^.v_samp_factor) do - begin - outptr := JSAMPLE_PTR(output_data^[outrow]); - inptr := JSAMPLE_PTR(input_data^[outrow]); - bias := 0; { bias := 0,1,0,1,... for successive samples } - for outcol := 0 to pred(output_cols) do - begin - outptr^ := JSAMPLE ((GETJSAMPLE(inptr^) + - GETJSAMPLE(JSAMPROW(inptr)^[1]) + bias) shr 1); - Inc(outptr); - bias := bias xor 1; { 0=>1, 1=>0 } - Inc(inptr, 2); - end; - end; -end; - - -{ Downsample pixel values of a single component. - This version handles the standard case of 2:1 horizontal and 2:1 vertical, - without smoothing. } - -{METHODDEF} -procedure h2v2_downsample (cinfo : j_compress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - output_data : JSAMPARRAY); -var - inrow, outrow : int; - outcol : JDIMENSION; - output_cols : JDIMENSION; - {register} inptr0, inptr1, outptr : JSAMPLE_PTR; - {register} bias : int; -begin - output_cols := compptr^.width_in_blocks * DCTSIZE; - - { Expand input data enough to let all the output samples be generated - by the standard loop. Special-casing padded output would be more - efficient. } - - expand_right_edge(input_data, cinfo^.max_v_samp_factor, - cinfo^.image_width, output_cols * 2); - - inrow := 0; - for outrow := 0 to pred(compptr^.v_samp_factor) do - begin - outptr := JSAMPLE_PTR(output_data^[outrow]); - inptr0 := JSAMPLE_PTR(input_data^[inrow]); - inptr1 := JSAMPLE_PTR(input_data^[inrow+1]); - bias := 1; { bias := 1,2,1,2,... for successive samples } - for outcol := 0 to pred(output_cols) do - begin - outptr^ := JSAMPLE ((GETJSAMPLE(inptr0^) + - GETJSAMPLE(JSAMPROW(inptr0)^[1]) + - GETJSAMPLE(inptr1^) + - GETJSAMPLE(JSAMPROW(inptr1)^[1]) + bias) shr 2); - Inc(outptr); - bias := bias xor 3; { 1=>2, 2=>1 } - Inc(inptr0, 2); - Inc(inptr1, 2); - end; - Inc(inrow, 2); - end; -end; - - -{$ifdef INPUT_SMOOTHING_SUPPORTED} - -{ Downsample pixel values of a single component. - This version handles the standard case of 2:1 horizontal and 2:1 vertical, - with smoothing. One row of context is required. } - -{METHODDEF} -procedure h2v2_smooth_downsample (cinfo : j_compress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - output_data : JSAMPARRAY); -var - inrow, outrow : int; - colctr : JDIMENSION; - output_cols : JDIMENSION; - {register} inptr0, inptr1, above_ptr, below_ptr, outptr : JSAMPLE_PTR; - membersum, neighsum, memberscale, neighscale : INT32; -var - prev_input_data : JSAMPARRAY; - prev_inptr0, prev_inptr1, prev_above_ptr, prev_below_ptr : JSAMPLE_PTR; -begin - output_cols := compptr^.width_in_blocks * DCTSIZE; - - { Expand input data enough to let all the output samples be generated - by the standard loop. Special-casing padded output would be more - efficient. } - - prev_input_data := input_data; - Dec(JSAMPROW_PTR(prev_input_data)); - expand_right_edge(prev_input_data, cinfo^.max_v_samp_factor + 2, - cinfo^.image_width, output_cols * 2); - - { We don't bother to form the individual "smoothed" input pixel values; - we can directly compute the output which is the average of the four - smoothed values. Each of the four member pixels contributes a fraction - (1-8*SF) to its own smoothed image and a fraction SF to each of the three - other smoothed pixels, therefore a total fraction (1-5*SF)/4 to the final - output. The four corner-adjacent neighbor pixels contribute a fraction - SF to just one smoothed pixel, or SF/4 to the final output; while the - eight edge-adjacent neighbors contribute SF to each of two smoothed - pixels, or SF/2 overall. In order to use integer arithmetic, these - factors are scaled by 2^16 := 65536. - Also recall that SF := smoothing_factor / 1024. } - - memberscale := 16384 - cinfo^.smoothing_factor * 80; { scaled (1-5*SF)/4 } - neighscale := cinfo^.smoothing_factor * 16; { scaled SF/4 } - - inrow := 0; - for outrow := 0 to pred(compptr^.v_samp_factor) do - begin - outptr := JSAMPLE_PTR(output_data^[outrow]); - inptr0 := JSAMPLE_PTR(input_data^[inrow]); - inptr1 := JSAMPLE_PTR(input_data^[inrow+1]); - above_ptr := JSAMPLE_PTR(input_data^[inrow-1]); - below_ptr := JSAMPLE_PTR(input_data^[inrow+2]); - - { Special case for first column: pretend column -1 is same as column 0 } - membersum := GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) + - GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]); - neighsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(JSAMPROW(above_ptr)^[1]) + - GETJSAMPLE(below_ptr^) + GETJSAMPLE(JSAMPROW(below_ptr)^[1]) + - GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[2]) + - GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[2]); - Inc(neighsum, neighsum); - Inc(neighsum, GETJSAMPLE(above_ptr^) + - GETJSAMPLE(JSAMPROW(above_ptr)^[2]) + - GETJSAMPLE(below_ptr^) + - GETJSAMPLE(JSAMPROW(below_ptr)^[2]) ); - membersum := membersum * memberscale + neighsum * neighscale; - outptr^ := JSAMPLE ((membersum + 32768) shr 16); - Inc(outptr); - prev_inptr0 := inptr0; - prev_inptr1 := inptr1; - Inc(prev_inptr0); - Inc(prev_inptr1); - Inc(inptr0, 2); - Inc(inptr1, 2); - prev_above_ptr := above_ptr; - prev_below_ptr := below_ptr; - Inc(above_ptr, 2); - Inc(below_ptr, 2); - Inc(prev_above_ptr, 1); - Inc(prev_below_ptr, 1); - - for colctr := pred(output_cols - 2) downto 0 do - begin - { sum of pixels directly mapped to this output element } - membersum := GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) + - GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]); - { sum of edge-neighbor pixels } - neighsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(JSAMPROW(above_ptr)^[1]) + - GETJSAMPLE(below_ptr^) + GETJSAMPLE(JSAMPROW(below_ptr)^[1]) + - GETJSAMPLE(prev_inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[2]) + - GETJSAMPLE(prev_inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[2]); - { The edge-neighbors count twice as much as corner-neighbors } - Inc(neighsum, neighsum); - { Add in the corner-neighbors } - Inc(neighsum, GETJSAMPLE(prev_above_ptr^) + - GETJSAMPLE(JSAMPROW(above_ptr)^[2]) + - GETJSAMPLE(prev_below_ptr^) + - GETJSAMPLE(JSAMPROW(below_ptr)^[2]) ); - { form final output scaled up by 2^16 } - membersum := membersum * memberscale + neighsum * neighscale; - { round, descale and output it } - outptr^ := JSAMPLE ((membersum + 32768) shr 16); - Inc(outptr); - Inc(inptr0, 2); - Inc(inptr1, 2); - Inc(prev_inptr0, 2); - Inc(prev_inptr1, 2); - Inc(above_ptr, 2); - Inc(below_ptr, 2); - Inc(prev_above_ptr, 2); - Inc(prev_below_ptr, 2); - end; - - { Special case for last column } - membersum := GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) + - GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]); - neighsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(JSAMPROW(above_ptr)^[1]) + - GETJSAMPLE(below_ptr^) + GETJSAMPLE(JSAMPROW(below_ptr)^[1]) + - GETJSAMPLE(prev_inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) + - GETJSAMPLE(prev_inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]); - Inc(neighsum, neighsum); - Inc(neighsum, GETJSAMPLE(prev_above_ptr^) + - GETJSAMPLE(JSAMPROW(above_ptr)^[1]) + - GETJSAMPLE(prev_below_ptr^) + - GETJSAMPLE(JSAMPROW(below_ptr)^[1]) ); - membersum := membersum * memberscale + neighsum * neighscale; - outptr^ := JSAMPLE ((membersum + 32768) shr 16); - - Inc(inrow, 2); - end; -end; - - -{ Downsample pixel values of a single component. - This version handles the special case of a full-size component, - with smoothing. One row of context is required. } - -{METHODDEF} -procedure fullsize_smooth_downsample (cinfo : j_compress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - output_data : JSAMPARRAY); -var - outrow : int; - colctr : JDIMENSION; - output_cols : JDIMENSION; - {register} inptr, above_ptr, below_ptr, outptr : JSAMPLE_PTR; - membersum, neighsum, memberscale, neighscale : INT32; - colsum, lastcolsum, nextcolsum : int; -var - prev_input_data : JSAMPARRAY; -begin - output_cols := compptr^.width_in_blocks * DCTSIZE; - - { Expand input data enough to let all the output samples be generated - by the standard loop. Special-casing padded output would be more - efficient. } - - prev_input_data := input_data; - Dec(JSAMPROW_PTR(prev_input_data)); - expand_right_edge(prev_input_data, cinfo^.max_v_samp_factor + 2, - cinfo^.image_width, output_cols); - - { Each of the eight neighbor pixels contributes a fraction SF to the - smoothed pixel, while the main pixel contributes (1-8*SF). In order - to use integer arithmetic, these factors are multiplied by 2^16 := 65536. - Also recall that SF := smoothing_factor / 1024. } - - memberscale := long(65536) - cinfo^.smoothing_factor * long(512); { scaled 1-8*SF } - neighscale := cinfo^.smoothing_factor * 64; { scaled SF } - - for outrow := 0 to pred(compptr^.v_samp_factor) do - begin - outptr := JSAMPLE_PTR(output_data^[outrow]); - inptr := JSAMPLE_PTR(input_data^[outrow]); - above_ptr := JSAMPLE_PTR(input_data^[outrow-1]); - below_ptr := JSAMPLE_PTR(input_data^[outrow+1]); - - { Special case for first column } - colsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(below_ptr^) + - GETJSAMPLE(inptr^); - Inc(above_ptr); - Inc(below_ptr); - membersum := GETJSAMPLE(inptr^); - Inc(inptr); - nextcolsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(below_ptr^) + - GETJSAMPLE(inptr^); - neighsum := colsum + (colsum - membersum) + nextcolsum; - membersum := membersum * memberscale + neighsum * neighscale; - outptr^ := JSAMPLE ((membersum + 32768) shr 16); - Inc(outptr); - lastcolsum := colsum; colsum := nextcolsum; - - for colctr := pred(output_cols - 2) downto 0 do - begin - membersum := GETJSAMPLE(inptr^); - Inc(inptr); - Inc(above_ptr); - Inc(below_ptr); - nextcolsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(below_ptr^) + - GETJSAMPLE(inptr^); - neighsum := lastcolsum + (colsum - membersum) + nextcolsum; - membersum := membersum * memberscale + neighsum * neighscale; - outptr^ := JSAMPLE ((membersum + 32768) shr 16); - Inc(outptr); - lastcolsum := colsum; colsum := nextcolsum; - end; - - { Special case for last column } - membersum := GETJSAMPLE(inptr^); - neighsum := lastcolsum + (colsum - membersum) + colsum; - membersum := membersum * memberscale + neighsum * neighscale; - outptr^ := JSAMPLE ((membersum + 32768) shr 16); - end; -end; - -{$endif} { INPUT_SMOOTHING_SUPPORTED } - - -{ Module initialization routine for downsampling. - Note that we must select a routine for each component. } - -{GLOBAL} -procedure jinit_downsampler (cinfo : j_compress_ptr); -var - downsample : my_downsample_ptr; - ci : int; - compptr : jpeg_component_info_ptr; - smoothok : boolean; -begin - smoothok := TRUE; - - downsample := my_downsample_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_downsampler)) ); - cinfo^.downsample := jpeg_downsampler_ptr (downsample); - downsample^.pub.start_pass := start_pass_downsample; - downsample^.pub.downsample := sep_downsample; - downsample^.pub.need_context_rows := FALSE; - - if (cinfo^.CCIR601_sampling) then - ERREXIT(j_common_ptr(cinfo), JERR_CCIR601_NOTIMPL); - - { Verify we can handle the sampling factors, and set up method pointers } - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - if (compptr^.h_samp_factor = cinfo^.max_h_samp_factor) and - (compptr^.v_samp_factor = cinfo^.max_v_samp_factor) then - begin -{$ifdef INPUT_SMOOTHING_SUPPORTED} - if (cinfo^.smoothing_factor <> 0) then - begin - downsample^.methods[ci] := fullsize_smooth_downsample; - downsample^.pub.need_context_rows := TRUE; - end - else -{$endif} - downsample^.methods[ci] := fullsize_downsample; - end - else - if (compptr^.h_samp_factor * 2 = cinfo^.max_h_samp_factor) and - (compptr^.v_samp_factor = cinfo^.max_v_samp_factor) then - begin - smoothok := FALSE; - downsample^.methods[ci] := h2v1_downsample; - end - else - if (compptr^.h_samp_factor * 2 = cinfo^.max_h_samp_factor) and - (compptr^.v_samp_factor * 2 = cinfo^.max_v_samp_factor) then - begin - {$ifdef INPUT_SMOOTHING_SUPPORTED} - if (cinfo^.smoothing_factor <> 0) then - begin - downsample^.methods[ci] := h2v2_smooth_downsample; - downsample^.pub.need_context_rows := TRUE; - end - else - {$endif} - downsample^.methods[ci] := h2v2_downsample; - end - else - if ((cinfo^.max_h_samp_factor mod compptr^.h_samp_factor) = 0) and - ((cinfo^.max_v_samp_factor mod compptr^.v_samp_factor) = 0) then - begin - smoothok := FALSE; - downsample^.methods[ci] := int_downsample; - end - else - ERREXIT(j_common_ptr(cinfo), JERR_FRACT_SAMPLE_NOTIMPL); - Inc(compptr); - end; - -{$ifdef INPUT_SMOOTHING_SUPPORTED} - if (cinfo^.smoothing_factor <> 0) and (not smoothok) then - TRACEMS(j_common_ptr(cinfo), 0, JTRC_SMOOTH_NOTIMPL); -{$endif} -end; - -end. +unit imjcsample; + +{ This file contains downsampling routines. + + Downsampling input data is counted in "row groups". A row group + is defined to be max_v_samp_factor pixel rows of each component, + from which the downsampler produces v_samp_factor sample rows. + A single row group is processed in each call to the downsampler module. + + The downsampler is responsible for edge-expansion of its output data + to fill an integral number of DCT blocks horizontally. The source buffer + may be modified if it is helpful for this purpose (the source buffer is + allocated wide enough to correspond to the desired output width). + The caller (the prep controller) is responsible for vertical padding. + + The downsampler may request "context rows" by setting need_context_rows + during startup. In this case, the input arrays will contain at least + one row group's worth of pixels above and below the passed-in data; + the caller will create dummy rows at image top and bottom by replicating + the first or last real pixel row. + + An excellent reference for image resampling is + Digital Image Warping, George Wolberg, 1990. + Pub. by IEEE Computer Society Press, Los Alamitos, CA. ISBN 0-8186-8944-7. + + The downsampling algorithm used here is a simple average of the source + pixels covered by the output pixel. The hi-falutin sampling literature + refers to this as a "box filter". In general the characteristics of a box + filter are not very good, but for the specific cases we normally use (1:1 + and 2:1 ratios) the box is equivalent to a "triangle filter" which is not + nearly so bad. If you intend to use other sampling ratios, you'd be well + advised to improve this code. + + A simple input-smoothing capability is provided. This is mainly intended + for cleaning up color-dithered GIF input files (if you find it inadequate, + we suggest using an external filtering program such as pnmconvol). When + enabled, each input pixel P is replaced by a weighted sum of itself and its + eight neighbors. P's weight is 1-8*SF and each neighbor's weight is SF, + where SF := (smoothing_factor / 1024). + Currently, smoothing is only supported for 2h2v sampling factors. } + +{ Original: jcsample.c ; Copyright (C) 1991-1996, Thomas G. Lane. } + + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjutils, + imjdeferr, + imjerror, + imjpeglib; + + +{ Module initialization routine for downsampling. + Note that we must select a routine for each component. } + +{GLOBAL} +procedure jinit_downsampler (cinfo : j_compress_ptr); + +implementation + +{ Pointer to routine to downsample a single component } +type + downsample1_ptr = procedure(cinfo : j_compress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + output_data : JSAMPARRAY); + +{ Private subobject } + +type + my_downsample_ptr = ^my_downsampler; + my_downsampler = record + pub : jpeg_downsampler; { public fields } + + { Downsampling method pointers, one per component } + methods : array[0..MAX_COMPONENTS-1] of downsample1_ptr; + end; + +{ Initialize for a downsampling pass. } + +{METHODDEF} +procedure start_pass_downsample (cinfo : j_compress_ptr); +begin + { no work for now } +end; + + +{ Expand a component horizontally from width input_cols to width output_cols, + by duplicating the rightmost samples. } + +{LOCAL} +procedure expand_right_edge (image_data : JSAMPARRAY; + num_rows : int; + input_cols : JDIMENSION; + output_cols : JDIMENSION); +var + {register} ptr : JSAMPLE_PTR; + {register} pixval : JSAMPLE; + {register} count : int; + row : int; + numcols : int; +begin + numcols := int (output_cols - input_cols); + + if (numcols > 0) then + begin + for row := 0 to pred(num_rows) do + begin + ptr := JSAMPLE_PTR(@(image_data^[row]^[input_cols-1])); + pixval := ptr^; { don't need GETJSAMPLE() here } + for count := pred(numcols) downto 0 do + begin + Inc(ptr); + ptr^ := pixval; + end; + end; + end; +end; + + +{ Do downsampling for a whole row group (all components). + + In this version we simply downsample each component independently. } + +{METHODDEF} +procedure sep_downsample (cinfo : j_compress_ptr; + input_buf : JSAMPIMAGE; + in_row_index : JDIMENSION; + output_buf : JSAMPIMAGE; + out_row_group_index : JDIMENSION); +var + downsample : my_downsample_ptr; + ci : int; + compptr : jpeg_component_info_ptr; + in_ptr, out_ptr : JSAMPARRAY; +begin + downsample := my_downsample_ptr (cinfo^.downsample); + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + in_ptr := JSAMPARRAY(@ input_buf^[ci]^[in_row_index]); + out_ptr := JSAMPARRAY(@ output_buf^[ci]^ + [out_row_group_index * JDIMENSION(compptr^.v_samp_factor)]); + downsample^.methods[ci] (cinfo, compptr, in_ptr, out_ptr); + Inc(compptr); + end; +end; + + +{ Downsample pixel values of a single component. + One row group is processed per call. + This version handles arbitrary integral sampling ratios, without smoothing. + Note that this version is not actually used for customary sampling ratios. } + +{METHODDEF} +procedure int_downsample (cinfo : j_compress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + output_data : JSAMPARRAY); +var + inrow, outrow, h_expand, v_expand, numpix, numpix2, h, v : int; + outcol, outcol_h : JDIMENSION; { outcol_h = outcol*h_expand } + output_cols : JDIMENSION; + inptr, + outptr : JSAMPLE_PTR; + outvalue : INT32; +begin + output_cols := compptr^.width_in_blocks * DCTSIZE; + + h_expand := cinfo^.max_h_samp_factor div compptr^.h_samp_factor; + v_expand := cinfo^.max_v_samp_factor div compptr^.v_samp_factor; + numpix := h_expand * v_expand; + numpix2 := numpix div 2; + + { Expand input data enough to let all the output samples be generated + by the standard loop. Special-casing padded output would be more + efficient. } + + expand_right_edge(input_data, cinfo^.max_v_samp_factor, + cinfo^.image_width, output_cols * JDIMENSION(h_expand)); + + inrow := 0; + for outrow := 0 to pred(compptr^.v_samp_factor) do + begin + outptr := JSAMPLE_PTR(output_data^[outrow]); + outcol_h := 0; + for outcol := 0 to pred(output_cols) do + begin + outvalue := 0; + for v := 0 to pred(v_expand) do + begin + inptr := @(input_data^[inrow+v]^[outcol_h]); + for h := 0 to pred(h_expand) do + begin + Inc(outvalue, INT32 (GETJSAMPLE(inptr^)) ); + Inc(inptr); + end; + end; + outptr^ := JSAMPLE ((outvalue + numpix2) div numpix); + Inc(outptr); + Inc(outcol_h, h_expand); + end; + Inc(inrow, v_expand); + end; +end; + + +{ Downsample pixel values of a single component. + This version handles the special case of a full-size component, + without smoothing. } + +{METHODDEF} +procedure fullsize_downsample (cinfo : j_compress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + output_data : JSAMPARRAY); +begin + { Copy the data } + jcopy_sample_rows(input_data, 0, output_data, 0, + cinfo^.max_v_samp_factor, cinfo^.image_width); + { Edge-expand } + expand_right_edge(output_data, cinfo^.max_v_samp_factor, + cinfo^.image_width, compptr^.width_in_blocks * DCTSIZE); +end; + + +{ Downsample pixel values of a single component. + This version handles the common case of 2:1 horizontal and 1:1 vertical, + without smoothing. + + A note about the "bias" calculations: when rounding fractional values to + integer, we do not want to always round 0.5 up to the next integer. + If we did that, we'd introduce a noticeable bias towards larger values. + Instead, this code is arranged so that 0.5 will be rounded up or down at + alternate pixel locations (a simple ordered dither pattern). } + +{METHODDEF} +procedure h2v1_downsample (cinfo : j_compress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + output_data : JSAMPARRAY); +var + outrow : int; + outcol : JDIMENSION; + output_cols : JDIMENSION; + {register} inptr, outptr : JSAMPLE_PTR; + {register} bias : int; +begin + output_cols := compptr^.width_in_blocks * DCTSIZE; + + { Expand input data enough to let all the output samples be generated + by the standard loop. Special-casing padded output would be more + efficient. } + + expand_right_edge(input_data, cinfo^.max_v_samp_factor, + cinfo^.image_width, output_cols * 2); + + for outrow := 0 to pred(compptr^.v_samp_factor) do + begin + outptr := JSAMPLE_PTR(output_data^[outrow]); + inptr := JSAMPLE_PTR(input_data^[outrow]); + bias := 0; { bias := 0,1,0,1,... for successive samples } + for outcol := 0 to pred(output_cols) do + begin + outptr^ := JSAMPLE ((GETJSAMPLE(inptr^) + + GETJSAMPLE(JSAMPROW(inptr)^[1]) + bias) shr 1); + Inc(outptr); + bias := bias xor 1; { 0=>1, 1=>0 } + Inc(inptr, 2); + end; + end; +end; + + +{ Downsample pixel values of a single component. + This version handles the standard case of 2:1 horizontal and 2:1 vertical, + without smoothing. } + +{METHODDEF} +procedure h2v2_downsample (cinfo : j_compress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + output_data : JSAMPARRAY); +var + inrow, outrow : int; + outcol : JDIMENSION; + output_cols : JDIMENSION; + {register} inptr0, inptr1, outptr : JSAMPLE_PTR; + {register} bias : int; +begin + output_cols := compptr^.width_in_blocks * DCTSIZE; + + { Expand input data enough to let all the output samples be generated + by the standard loop. Special-casing padded output would be more + efficient. } + + expand_right_edge(input_data, cinfo^.max_v_samp_factor, + cinfo^.image_width, output_cols * 2); + + inrow := 0; + for outrow := 0 to pred(compptr^.v_samp_factor) do + begin + outptr := JSAMPLE_PTR(output_data^[outrow]); + inptr0 := JSAMPLE_PTR(input_data^[inrow]); + inptr1 := JSAMPLE_PTR(input_data^[inrow+1]); + bias := 1; { bias := 1,2,1,2,... for successive samples } + for outcol := 0 to pred(output_cols) do + begin + outptr^ := JSAMPLE ((GETJSAMPLE(inptr0^) + + GETJSAMPLE(JSAMPROW(inptr0)^[1]) + + GETJSAMPLE(inptr1^) + + GETJSAMPLE(JSAMPROW(inptr1)^[1]) + bias) shr 2); + Inc(outptr); + bias := bias xor 3; { 1=>2, 2=>1 } + Inc(inptr0, 2); + Inc(inptr1, 2); + end; + Inc(inrow, 2); + end; +end; + + +{$ifdef INPUT_SMOOTHING_SUPPORTED} + +{ Downsample pixel values of a single component. + This version handles the standard case of 2:1 horizontal and 2:1 vertical, + with smoothing. One row of context is required. } + +{METHODDEF} +procedure h2v2_smooth_downsample (cinfo : j_compress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + output_data : JSAMPARRAY); +var + inrow, outrow : int; + colctr : JDIMENSION; + output_cols : JDIMENSION; + {register} inptr0, inptr1, above_ptr, below_ptr, outptr : JSAMPLE_PTR; + membersum, neighsum, memberscale, neighscale : INT32; +var + prev_input_data : JSAMPARRAY; + prev_inptr0, prev_inptr1, prev_above_ptr, prev_below_ptr : JSAMPLE_PTR; +begin + output_cols := compptr^.width_in_blocks * DCTSIZE; + + { Expand input data enough to let all the output samples be generated + by the standard loop. Special-casing padded output would be more + efficient. } + + prev_input_data := input_data; + Dec(JSAMPROW_PTR(prev_input_data)); + expand_right_edge(prev_input_data, cinfo^.max_v_samp_factor + 2, + cinfo^.image_width, output_cols * 2); + + { We don't bother to form the individual "smoothed" input pixel values; + we can directly compute the output which is the average of the four + smoothed values. Each of the four member pixels contributes a fraction + (1-8*SF) to its own smoothed image and a fraction SF to each of the three + other smoothed pixels, therefore a total fraction (1-5*SF)/4 to the final + output. The four corner-adjacent neighbor pixels contribute a fraction + SF to just one smoothed pixel, or SF/4 to the final output; while the + eight edge-adjacent neighbors contribute SF to each of two smoothed + pixels, or SF/2 overall. In order to use integer arithmetic, these + factors are scaled by 2^16 := 65536. + Also recall that SF := smoothing_factor / 1024. } + + memberscale := 16384 - cinfo^.smoothing_factor * 80; { scaled (1-5*SF)/4 } + neighscale := cinfo^.smoothing_factor * 16; { scaled SF/4 } + + inrow := 0; + for outrow := 0 to pred(compptr^.v_samp_factor) do + begin + outptr := JSAMPLE_PTR(output_data^[outrow]); + inptr0 := JSAMPLE_PTR(input_data^[inrow]); + inptr1 := JSAMPLE_PTR(input_data^[inrow+1]); + above_ptr := JSAMPLE_PTR(input_data^[inrow-1]); + below_ptr := JSAMPLE_PTR(input_data^[inrow+2]); + + { Special case for first column: pretend column -1 is same as column 0 } + membersum := GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) + + GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]); + neighsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(JSAMPROW(above_ptr)^[1]) + + GETJSAMPLE(below_ptr^) + GETJSAMPLE(JSAMPROW(below_ptr)^[1]) + + GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[2]) + + GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[2]); + Inc(neighsum, neighsum); + Inc(neighsum, GETJSAMPLE(above_ptr^) + + GETJSAMPLE(JSAMPROW(above_ptr)^[2]) + + GETJSAMPLE(below_ptr^) + + GETJSAMPLE(JSAMPROW(below_ptr)^[2]) ); + membersum := membersum * memberscale + neighsum * neighscale; + outptr^ := JSAMPLE ((membersum + 32768) shr 16); + Inc(outptr); + prev_inptr0 := inptr0; + prev_inptr1 := inptr1; + Inc(prev_inptr0); + Inc(prev_inptr1); + Inc(inptr0, 2); + Inc(inptr1, 2); + prev_above_ptr := above_ptr; + prev_below_ptr := below_ptr; + Inc(above_ptr, 2); + Inc(below_ptr, 2); + Inc(prev_above_ptr, 1); + Inc(prev_below_ptr, 1); + + for colctr := pred(output_cols - 2) downto 0 do + begin + { sum of pixels directly mapped to this output element } + membersum := GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) + + GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]); + { sum of edge-neighbor pixels } + neighsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(JSAMPROW(above_ptr)^[1]) + + GETJSAMPLE(below_ptr^) + GETJSAMPLE(JSAMPROW(below_ptr)^[1]) + + GETJSAMPLE(prev_inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[2]) + + GETJSAMPLE(prev_inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[2]); + { The edge-neighbors count twice as much as corner-neighbors } + Inc(neighsum, neighsum); + { Add in the corner-neighbors } + Inc(neighsum, GETJSAMPLE(prev_above_ptr^) + + GETJSAMPLE(JSAMPROW(above_ptr)^[2]) + + GETJSAMPLE(prev_below_ptr^) + + GETJSAMPLE(JSAMPROW(below_ptr)^[2]) ); + { form final output scaled up by 2^16 } + membersum := membersum * memberscale + neighsum * neighscale; + { round, descale and output it } + outptr^ := JSAMPLE ((membersum + 32768) shr 16); + Inc(outptr); + Inc(inptr0, 2); + Inc(inptr1, 2); + Inc(prev_inptr0, 2); + Inc(prev_inptr1, 2); + Inc(above_ptr, 2); + Inc(below_ptr, 2); + Inc(prev_above_ptr, 2); + Inc(prev_below_ptr, 2); + end; + + { Special case for last column } + membersum := GETJSAMPLE(inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) + + GETJSAMPLE(inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]); + neighsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(JSAMPROW(above_ptr)^[1]) + + GETJSAMPLE(below_ptr^) + GETJSAMPLE(JSAMPROW(below_ptr)^[1]) + + GETJSAMPLE(prev_inptr0^) + GETJSAMPLE(JSAMPROW(inptr0)^[1]) + + GETJSAMPLE(prev_inptr1^) + GETJSAMPLE(JSAMPROW(inptr1)^[1]); + Inc(neighsum, neighsum); + Inc(neighsum, GETJSAMPLE(prev_above_ptr^) + + GETJSAMPLE(JSAMPROW(above_ptr)^[1]) + + GETJSAMPLE(prev_below_ptr^) + + GETJSAMPLE(JSAMPROW(below_ptr)^[1]) ); + membersum := membersum * memberscale + neighsum * neighscale; + outptr^ := JSAMPLE ((membersum + 32768) shr 16); + + Inc(inrow, 2); + end; +end; + + +{ Downsample pixel values of a single component. + This version handles the special case of a full-size component, + with smoothing. One row of context is required. } + +{METHODDEF} +procedure fullsize_smooth_downsample (cinfo : j_compress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + output_data : JSAMPARRAY); +var + outrow : int; + colctr : JDIMENSION; + output_cols : JDIMENSION; + {register} inptr, above_ptr, below_ptr, outptr : JSAMPLE_PTR; + membersum, neighsum, memberscale, neighscale : INT32; + colsum, lastcolsum, nextcolsum : int; +var + prev_input_data : JSAMPARRAY; +begin + output_cols := compptr^.width_in_blocks * DCTSIZE; + + { Expand input data enough to let all the output samples be generated + by the standard loop. Special-casing padded output would be more + efficient. } + + prev_input_data := input_data; + Dec(JSAMPROW_PTR(prev_input_data)); + expand_right_edge(prev_input_data, cinfo^.max_v_samp_factor + 2, + cinfo^.image_width, output_cols); + + { Each of the eight neighbor pixels contributes a fraction SF to the + smoothed pixel, while the main pixel contributes (1-8*SF). In order + to use integer arithmetic, these factors are multiplied by 2^16 := 65536. + Also recall that SF := smoothing_factor / 1024. } + + memberscale := long(65536) - cinfo^.smoothing_factor * long(512); { scaled 1-8*SF } + neighscale := cinfo^.smoothing_factor * 64; { scaled SF } + + for outrow := 0 to pred(compptr^.v_samp_factor) do + begin + outptr := JSAMPLE_PTR(output_data^[outrow]); + inptr := JSAMPLE_PTR(input_data^[outrow]); + above_ptr := JSAMPLE_PTR(input_data^[outrow-1]); + below_ptr := JSAMPLE_PTR(input_data^[outrow+1]); + + { Special case for first column } + colsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(below_ptr^) + + GETJSAMPLE(inptr^); + Inc(above_ptr); + Inc(below_ptr); + membersum := GETJSAMPLE(inptr^); + Inc(inptr); + nextcolsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(below_ptr^) + + GETJSAMPLE(inptr^); + neighsum := colsum + (colsum - membersum) + nextcolsum; + membersum := membersum * memberscale + neighsum * neighscale; + outptr^ := JSAMPLE ((membersum + 32768) shr 16); + Inc(outptr); + lastcolsum := colsum; colsum := nextcolsum; + + for colctr := pred(output_cols - 2) downto 0 do + begin + membersum := GETJSAMPLE(inptr^); + Inc(inptr); + Inc(above_ptr); + Inc(below_ptr); + nextcolsum := GETJSAMPLE(above_ptr^) + GETJSAMPLE(below_ptr^) + + GETJSAMPLE(inptr^); + neighsum := lastcolsum + (colsum - membersum) + nextcolsum; + membersum := membersum * memberscale + neighsum * neighscale; + outptr^ := JSAMPLE ((membersum + 32768) shr 16); + Inc(outptr); + lastcolsum := colsum; colsum := nextcolsum; + end; + + { Special case for last column } + membersum := GETJSAMPLE(inptr^); + neighsum := lastcolsum + (colsum - membersum) + colsum; + membersum := membersum * memberscale + neighsum * neighscale; + outptr^ := JSAMPLE ((membersum + 32768) shr 16); + end; +end; + +{$endif} { INPUT_SMOOTHING_SUPPORTED } + + +{ Module initialization routine for downsampling. + Note that we must select a routine for each component. } + +{GLOBAL} +procedure jinit_downsampler (cinfo : j_compress_ptr); +var + downsample : my_downsample_ptr; + ci : int; + compptr : jpeg_component_info_ptr; + smoothok : boolean; +begin + smoothok := TRUE; + + downsample := my_downsample_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_downsampler)) ); + cinfo^.downsample := jpeg_downsampler_ptr (downsample); + downsample^.pub.start_pass := start_pass_downsample; + downsample^.pub.downsample := sep_downsample; + downsample^.pub.need_context_rows := FALSE; + + if (cinfo^.CCIR601_sampling) then + ERREXIT(j_common_ptr(cinfo), JERR_CCIR601_NOTIMPL); + + { Verify we can handle the sampling factors, and set up method pointers } + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + if (compptr^.h_samp_factor = cinfo^.max_h_samp_factor) and + (compptr^.v_samp_factor = cinfo^.max_v_samp_factor) then + begin +{$ifdef INPUT_SMOOTHING_SUPPORTED} + if (cinfo^.smoothing_factor <> 0) then + begin + downsample^.methods[ci] := fullsize_smooth_downsample; + downsample^.pub.need_context_rows := TRUE; + end + else +{$endif} + downsample^.methods[ci] := fullsize_downsample; + end + else + if (compptr^.h_samp_factor * 2 = cinfo^.max_h_samp_factor) and + (compptr^.v_samp_factor = cinfo^.max_v_samp_factor) then + begin + smoothok := FALSE; + downsample^.methods[ci] := h2v1_downsample; + end + else + if (compptr^.h_samp_factor * 2 = cinfo^.max_h_samp_factor) and + (compptr^.v_samp_factor * 2 = cinfo^.max_v_samp_factor) then + begin + {$ifdef INPUT_SMOOTHING_SUPPORTED} + if (cinfo^.smoothing_factor <> 0) then + begin + downsample^.methods[ci] := h2v2_smooth_downsample; + downsample^.pub.need_context_rows := TRUE; + end + else + {$endif} + downsample^.methods[ci] := h2v2_downsample; + end + else + if ((cinfo^.max_h_samp_factor mod compptr^.h_samp_factor) = 0) and + ((cinfo^.max_v_samp_factor mod compptr^.v_samp_factor) = 0) then + begin + smoothok := FALSE; + downsample^.methods[ci] := int_downsample; + end + else + ERREXIT(j_common_ptr(cinfo), JERR_FRACT_SAMPLE_NOTIMPL); + Inc(compptr); + end; + +{$ifdef INPUT_SMOOTHING_SUPPORTED} + if (cinfo^.smoothing_factor <> 0) and (not smoothok) then + TRACEMS(j_common_ptr(cinfo), 0, JTRC_SMOOTH_NOTIMPL); +{$endif} +end; + +end. diff --git a/Imaging/JpegLib/imjdapimin.pas b/Imaging/JpegLib/imjdapimin.pas index 367128e..f3a7039 100644 --- a/Imaging/JpegLib/imjdapimin.pas +++ b/Imaging/JpegLib/imjdapimin.pas @@ -1,505 +1,503 @@ -unit imjdapimin; - -{$N+} { Nomssi: cinfo^.output_gamma } - -{ This file contains application interface code for the decompression half - of the JPEG library. These are the "minimum" API routines that may be - needed in either the normal full-decompression case or the - transcoding-only case. - - Most of the routines intended to be called directly by an application - are in this file or in jdapistd.c. But also see jcomapi.c for routines - shared by compression and decompression, and jdtrans.c for the transcoding - case. } - -{ Original : jdapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjpeglib, - imjmemmgr, imjdmarker, imjdinput, imjcomapi; - -{ Nomssi } -procedure jpeg_create_decompress(cinfo : j_decompress_ptr); - -{ Initialization of a JPEG decompression object. - The error manager must already be set up (in case memory manager fails). } - -{GLOBAL} -procedure jpeg_CreateDecompress (cinfo : j_decompress_ptr; - version : int; - structsize : size_t); - -{ Destruction of a JPEG decompression object } - -{GLOBAL} -procedure jpeg_destroy_decompress (cinfo : j_decompress_ptr); - - -{ Decompression startup: read start of JPEG datastream to see what's there. - Need only initialize JPEG object and supply a data source before calling. - - This routine will read as far as the first SOS marker (ie, actual start of - compressed data), and will save all tables and parameters in the JPEG - object. It will also initialize the decompression parameters to default - values, and finally return JPEG_HEADER_OK. On return, the application may - adjust the decompression parameters and then call jpeg_start_decompress. - (Or, if the application only wanted to determine the image parameters, - the data need not be decompressed. In that case, call jpeg_abort or - jpeg_destroy to release any temporary space.) - If an abbreviated (tables only) datastream is presented, the routine will - return JPEG_HEADER_TABLES_ONLY upon reaching EOI. The application may then - re-use the JPEG object to read the abbreviated image datastream(s). - It is unnecessary (but OK) to call jpeg_abort in this case. - The JPEG_SUSPENDED return code only occurs if the data source module - requests suspension of the decompressor. In this case the application - should load more source data and then re-call jpeg_read_header to resume - processing. - If a non-suspending data source is used and require_image is TRUE, then the - return code need not be inspected since only JPEG_HEADER_OK is possible. - - This routine is now just a front end to jpeg_consume_input, with some - extra error checking. } - -{GLOBAL} -function jpeg_read_header (cinfo : j_decompress_ptr; - require_image : boolean) : int; - -{ Consume data in advance of what the decompressor requires. - This can be called at any time once the decompressor object has - been created and a data source has been set up. - - This routine is essentially a state machine that handles a couple - of critical state-transition actions, namely initial setup and - transition from header scanning to ready-for-start_decompress. - All the actual input is done via the input controller's consume_input - method. } - -{GLOBAL} -function jpeg_consume_input (cinfo : j_decompress_ptr) : int; - -{ Have we finished reading the input file? } - -{GLOBAL} -function jpeg_input_complete (cinfo : j_decompress_ptr) : boolean; - -{ Is there more than one scan? } - -{GLOBAL} -function jpeg_has_multiple_scans (cinfo : j_decompress_ptr) : boolean; - - -{ Finish JPEG decompression. - - This will normally just verify the file trailer and release temp storage. - - Returns FALSE if suspended. The return value need be inspected only if - a suspending data source is used. } - -{GLOBAL} -function jpeg_finish_decompress (cinfo : j_decompress_ptr) : boolean; - -implementation - -procedure jpeg_create_decompress(cinfo : j_decompress_ptr); -begin - jpeg_CreateDecompress(cinfo, JPEG_LIB_VERSION, - size_t(sizeof(jpeg_decompress_struct))); -end; - -{ Initialization of a JPEG decompression object. - The error manager must already be set up (in case memory manager fails). } - -{GLOBAL} -procedure jpeg_CreateDecompress (cinfo : j_decompress_ptr; - version : int; - structsize : size_t); -var - i : int; -var - err : jpeg_error_mgr_ptr; - client_data : voidp; -begin - { Guard against version mismatches between library and caller. } - cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called } - if (version <> JPEG_LIB_VERSION) then - ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version); - if (structsize <> SIZEOF(jpeg_decompress_struct)) then - ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE, - int(SIZEOF(jpeg_decompress_struct)), int(structsize)); - - { For debugging purposes, we zero the whole master structure. - But the application has already set the err pointer, and may have set - client_data, so we have to save and restore those fields. - Note: if application hasn't set client_data, tools like Purify may - complain here. } - begin - err := cinfo^.err; - client_data := cinfo^.client_data; { ignore Purify complaint here } - MEMZERO(j_common_ptr(cinfo), SIZEOF(jpeg_decompress_struct)); - cinfo^.err := err; - cinfo^.client_data := client_data; - end; - cinfo^.is_decompressor := TRUE; - - { Initialize a memory manager instance for this object } - jinit_memory_mgr(j_common_ptr(cinfo)); - - { Zero out pointers to permanent structures. } - cinfo^.progress := NIL; - cinfo^.src := NIL; - - for i := 0 to pred(NUM_QUANT_TBLS) do - cinfo^.quant_tbl_ptrs[i] := NIL; - - for i := 0 to pred(NUM_HUFF_TBLS) do - begin - cinfo^.dc_huff_tbl_ptrs[i] := NIL; - cinfo^.ac_huff_tbl_ptrs[i] := NIL; - end; - - { Initialize marker processor so application can override methods - for COM, APPn markers before calling jpeg_read_header. } - cinfo^.marker_list := NIL; - jinit_marker_reader(cinfo); - - { And initialize the overall input controller. } - jinit_input_controller(cinfo); - - { OK, I'm ready } - cinfo^.global_state := DSTATE_START; -end; - - -{ Destruction of a JPEG decompression object } - -{GLOBAL} -procedure jpeg_destroy_decompress (cinfo : j_decompress_ptr); -begin - jpeg_destroy(j_common_ptr(cinfo)); { use common routine } -end; - - -{ Abort processing of a JPEG decompression operation, - but don't destroy the object itself. } - -{GLOBAL} -procedure jpeg_abort_decompress (cinfo : j_decompress_ptr); -begin - jpeg_abort(j_common_ptr(cinfo)); { use common routine } -end; - - -{ Set default decompression parameters. } - -{LOCAL} -procedure default_decompress_parms (cinfo : j_decompress_ptr); -var - cid0 : int; - cid1 : int; - cid2 : int; -begin - { Guess the input colorspace, and set output colorspace accordingly. } - { (Wish JPEG committee had provided a real way to specify this...) } - { Note application may override our guesses. } - case (cinfo^.num_components) of - 1: begin - cinfo^.jpeg_color_space := JCS_GRAYSCALE; - cinfo^.out_color_space := JCS_GRAYSCALE; - end; - - 3: begin - if (cinfo^.saw_JFIF_marker) then - begin - cinfo^.jpeg_color_space := JCS_YCbCr; { JFIF implies YCbCr } - end - else - if (cinfo^.saw_Adobe_marker) then - begin - case (cinfo^.Adobe_transform) of - 0: cinfo^.jpeg_color_space := JCS_RGB; - 1: cinfo^.jpeg_color_space := JCS_YCbCr; - else - begin - WARNMS1(j_common_ptr(cinfo), JWRN_ADOBE_XFORM, cinfo^.Adobe_transform); - cinfo^.jpeg_color_space := JCS_YCbCr; { assume it's YCbCr } - end; - end; - end - else - begin - { Saw no special markers, try to guess from the component IDs } - cid0 := cinfo^.comp_info^[0].component_id; - cid1 := cinfo^.comp_info^[1].component_id; - cid2 := cinfo^.comp_info^[2].component_id; - - if (cid0 = 1) and (cid1 = 2) and (cid2 = 3) then - cinfo^.jpeg_color_space := JCS_YCbCr { assume JFIF w/out marker } - else - if (cid0 = 82) and (cid1 = 71) and (cid2 = 66) then - cinfo^.jpeg_color_space := JCS_RGB { ASCII 'R', 'G', 'B' } - else - begin - {$IFDEF DEBUG} - TRACEMS3(j_common_ptr(cinfo), 1, JTRC_UNKNOWN_IDS, cid0, cid1, cid2); - {$ENDIF} - cinfo^.jpeg_color_space := JCS_YCbCr; { assume it's YCbCr } - end; - end; - { Always guess RGB is proper output colorspace. } - cinfo^.out_color_space := JCS_RGB; - end; - - 4: begin - if (cinfo^.saw_Adobe_marker) then - begin - case (cinfo^.Adobe_transform) of - 0: cinfo^.jpeg_color_space := JCS_CMYK; - 2: cinfo^.jpeg_color_space := JCS_YCCK; - else - begin - WARNMS1(j_common_ptr(cinfo), JWRN_ADOBE_XFORM, cinfo^.Adobe_transform); - cinfo^.jpeg_color_space := JCS_YCCK; { assume it's YCCK } - end; - end; - end - else - begin - { No special markers, assume straight CMYK. } - cinfo^.jpeg_color_space := JCS_CMYK; - end; - cinfo^.out_color_space := JCS_CMYK; - end; - - else - begin - cinfo^.jpeg_color_space := JCS_UNKNOWN; - cinfo^.out_color_space := JCS_UNKNOWN; - end; - end; - - { Set defaults for other decompression parameters. } - cinfo^.scale_num := 1; { 1:1 scaling } - cinfo^.scale_denom := 1; - cinfo^.output_gamma := 1.0; - cinfo^.buffered_image := FALSE; - cinfo^.raw_data_out := FALSE; - cinfo^.dct_method := JDCT_DEFAULT; - cinfo^.do_fancy_upsampling := TRUE; - cinfo^.do_block_smoothing := TRUE; - cinfo^.quantize_colors := FALSE; - { We set these in case application only sets quantize_colors. } - cinfo^.dither_mode := JDITHER_FS; -{$ifdef QUANT_2PASS_SUPPORTED} - cinfo^.two_pass_quantize := TRUE; -{$else} - cinfo^.two_pass_quantize := FALSE; -{$endif} - cinfo^.desired_number_of_colors := 256; - cinfo^.colormap := NIL; - { Initialize for no mode change in buffered-image mode. } - cinfo^.enable_1pass_quant := FALSE; - cinfo^.enable_external_quant := FALSE; - cinfo^.enable_2pass_quant := FALSE; -end; - - -{ Decompression startup: read start of JPEG datastream to see what's there. - Need only initialize JPEG object and supply a data source before calling. - - This routine will read as far as the first SOS marker (ie, actual start of - compressed data), and will save all tables and parameters in the JPEG - object. It will also initialize the decompression parameters to default - values, and finally return JPEG_HEADER_OK. On return, the application may - adjust the decompression parameters and then call jpeg_start_decompress. - (Or, if the application only wanted to determine the image parameters, - the data need not be decompressed. In that case, call jpeg_abort or - jpeg_destroy to release any temporary space.) - If an abbreviated (tables only) datastream is presented, the routine will - return JPEG_HEADER_TABLES_ONLY upon reaching EOI. The application may then - re-use the JPEG object to read the abbreviated image datastream(s). - It is unnecessary (but OK) to call jpeg_abort in this case. - The JPEG_SUSPENDED return code only occurs if the data source module - requests suspension of the decompressor. In this case the application - should load more source data and then re-call jpeg_read_header to resume - processing. - If a non-suspending data source is used and require_image is TRUE, then the - return code need not be inspected since only JPEG_HEADER_OK is possible. - - This routine is now just a front end to jpeg_consume_input, with some - extra error checking. } - -{GLOBAL} -function jpeg_read_header (cinfo : j_decompress_ptr; - require_image : boolean) : int; -var - retcode : int; -begin - if (cinfo^.global_state <> DSTATE_START) and - (cinfo^.global_state <> DSTATE_INHEADER) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - - retcode := jpeg_consume_input(cinfo); - - case (retcode) of - JPEG_REACHED_SOS: - retcode := JPEG_HEADER_OK; - JPEG_REACHED_EOI: - begin - if (require_image) then { Complain if application wanted an image } - ERREXIT(j_common_ptr(cinfo), JERR_NO_IMAGE); - { Reset to start state; it would be safer to require the application to - call jpeg_abort, but we can't change it now for compatibility reasons. - A side effect is to free any temporary memory (there shouldn't be any). } - - jpeg_abort(j_common_ptr(cinfo)); { sets state := DSTATE_START } - retcode := JPEG_HEADER_TABLES_ONLY; - end; - JPEG_SUSPENDED: ; { no work } - end; - - jpeg_read_header := retcode; -end; - - -{ Consume data in advance of what the decompressor requires. - This can be called at any time once the decompressor object has - been created and a data source has been set up. - - This routine is essentially a state machine that handles a couple - of critical state-transition actions, namely initial setup and - transition from header scanning to ready-for-start_decompress. - All the actual input is done via the input controller's consume_input - method. } - -{GLOBAL} -function jpeg_consume_input (cinfo : j_decompress_ptr) : int; -var - retcode : int; -begin - retcode := JPEG_SUSPENDED; - - { NB: every possible DSTATE value should be listed in this switch } - - if (cinfo^.global_state) = DSTATE_START then - begin {work around the FALLTHROUGH} - { Start-of-datastream actions: reset appropriate modules } - cinfo^.inputctl^.reset_input_controller (cinfo); - { Initialize application's data source module } - cinfo^.src^.init_source (cinfo); - cinfo^.global_state := DSTATE_INHEADER; - end; - - case (cinfo^.global_state) of - DSTATE_START, - DSTATE_INHEADER: - begin - retcode := cinfo^.inputctl^.consume_input (cinfo); - if (retcode = JPEG_REACHED_SOS) then - begin { Found SOS, prepare to decompress } - { Set up default parameters based on header data } - default_decompress_parms(cinfo); - { Set global state: ready for start_decompress } - cinfo^.global_state := DSTATE_READY; - end; - end; - DSTATE_READY: - { Can't advance past first SOS until start_decompress is called } - retcode := JPEG_REACHED_SOS; - - DSTATE_PRELOAD, - DSTATE_PRESCAN, - DSTATE_SCANNING, - DSTATE_RAW_OK, - DSTATE_BUFIMAGE, - DSTATE_BUFPOST, - DSTATE_STOPPING: - retcode := cinfo^.inputctl^.consume_input (cinfo); - else - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - end; - jpeg_consume_input := retcode; -end; - - -{ Have we finished reading the input file? } - -{GLOBAL} -function jpeg_input_complete (cinfo : j_decompress_ptr) : boolean; -begin - { Check for valid jpeg object } - if (cinfo^.global_state < DSTATE_START) or - (cinfo^.global_state > DSTATE_STOPPING) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - jpeg_input_complete := cinfo^.inputctl^.eoi_reached; -end; - - -{ Is there more than one scan? } - -{GLOBAL} -function jpeg_has_multiple_scans (cinfo : j_decompress_ptr) : boolean; -begin - { Only valid after jpeg_read_header completes } - if (cinfo^.global_state < DSTATE_READY) or - (cinfo^.global_state > DSTATE_STOPPING) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - jpeg_has_multiple_scans := cinfo^.inputctl^.has_multiple_scans; -end; - - -{ Finish JPEG decompression. - - This will normally just verify the file trailer and release temp storage. - - Returns FALSE if suspended. The return value need be inspected only if - a suspending data source is used. } - -{GLOBAL} -function jpeg_finish_decompress (cinfo : j_decompress_ptr) : boolean; -begin - if ((cinfo^.global_state = DSTATE_SCANNING) or - (cinfo^.global_state = DSTATE_RAW_OK) and (not cinfo^.buffered_image)) then - begin - { Terminate final pass of non-buffered mode } - if (cinfo^.output_scanline < cinfo^.output_height) then - ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA); - cinfo^.master^.finish_output_pass (cinfo); - cinfo^.global_state := DSTATE_STOPPING; - end - else - if (cinfo^.global_state = DSTATE_BUFIMAGE) then - begin - { Finishing after a buffered-image operation } - cinfo^.global_state := DSTATE_STOPPING; - end - else - if (cinfo^.global_state <> DSTATE_STOPPING) then - begin - { STOPPING := repeat call after a suspension, anything else is error } - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - end; - { Read until EOI } - while (not cinfo^.inputctl^.eoi_reached) do - begin - if (cinfo^.inputctl^.consume_input (cinfo) = JPEG_SUSPENDED) then - begin - jpeg_finish_decompress := FALSE; { Suspend, come back later } - exit; - end; - end; - { Do final cleanup } - cinfo^.src^.term_source (cinfo); - { We can use jpeg_abort to release memory and reset global_state } - jpeg_abort(j_common_ptr(cinfo)); - jpeg_finish_decompress := TRUE; -end; - -end. +unit imjdapimin; + +{ This file contains application interface code for the decompression half + of the JPEG library. These are the "minimum" API routines that may be + needed in either the normal full-decompression case or the + transcoding-only case. + + Most of the routines intended to be called directly by an application + are in this file or in jdapistd.c. But also see jcomapi.c for routines + shared by compression and decompression, and jdtrans.c for the transcoding + case. } + +{ Original : jdapimin.c ; Copyright (C) 1994-1998, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjpeglib, + imjmemmgr, imjdmarker, imjdinput, imjcomapi; + +{ Nomssi } +procedure jpeg_create_decompress(cinfo : j_decompress_ptr); + +{ Initialization of a JPEG decompression object. + The error manager must already be set up (in case memory manager fails). } + +{GLOBAL} +procedure jpeg_CreateDecompress (cinfo : j_decompress_ptr; + version : int; + structsize : size_t); + +{ Destruction of a JPEG decompression object } + +{GLOBAL} +procedure jpeg_destroy_decompress (cinfo : j_decompress_ptr); + + +{ Decompression startup: read start of JPEG datastream to see what's there. + Need only initialize JPEG object and supply a data source before calling. + + This routine will read as far as the first SOS marker (ie, actual start of + compressed data), and will save all tables and parameters in the JPEG + object. It will also initialize the decompression parameters to default + values, and finally return JPEG_HEADER_OK. On return, the application may + adjust the decompression parameters and then call jpeg_start_decompress. + (Or, if the application only wanted to determine the image parameters, + the data need not be decompressed. In that case, call jpeg_abort or + jpeg_destroy to release any temporary space.) + If an abbreviated (tables only) datastream is presented, the routine will + return JPEG_HEADER_TABLES_ONLY upon reaching EOI. The application may then + re-use the JPEG object to read the abbreviated image datastream(s). + It is unnecessary (but OK) to call jpeg_abort in this case. + The JPEG_SUSPENDED return code only occurs if the data source module + requests suspension of the decompressor. In this case the application + should load more source data and then re-call jpeg_read_header to resume + processing. + If a non-suspending data source is used and require_image is TRUE, then the + return code need not be inspected since only JPEG_HEADER_OK is possible. + + This routine is now just a front end to jpeg_consume_input, with some + extra error checking. } + +{GLOBAL} +function jpeg_read_header (cinfo : j_decompress_ptr; + require_image : boolean) : int; + +{ Consume data in advance of what the decompressor requires. + This can be called at any time once the decompressor object has + been created and a data source has been set up. + + This routine is essentially a state machine that handles a couple + of critical state-transition actions, namely initial setup and + transition from header scanning to ready-for-start_decompress. + All the actual input is done via the input controller's consume_input + method. } + +{GLOBAL} +function jpeg_consume_input (cinfo : j_decompress_ptr) : int; + +{ Have we finished reading the input file? } + +{GLOBAL} +function jpeg_input_complete (cinfo : j_decompress_ptr) : boolean; + +{ Is there more than one scan? } + +{GLOBAL} +function jpeg_has_multiple_scans (cinfo : j_decompress_ptr) : boolean; + + +{ Finish JPEG decompression. + + This will normally just verify the file trailer and release temp storage. + + Returns FALSE if suspended. The return value need be inspected only if + a suspending data source is used. } + +{GLOBAL} +function jpeg_finish_decompress (cinfo : j_decompress_ptr) : boolean; + +implementation + +procedure jpeg_create_decompress(cinfo : j_decompress_ptr); +begin + jpeg_CreateDecompress(cinfo, JPEG_LIB_VERSION, + size_t(sizeof(jpeg_decompress_struct))); +end; + +{ Initialization of a JPEG decompression object. + The error manager must already be set up (in case memory manager fails). } + +{GLOBAL} +procedure jpeg_CreateDecompress (cinfo : j_decompress_ptr; + version : int; + structsize : size_t); +var + i : int; +var + err : jpeg_error_mgr_ptr; + client_data : voidp; +begin + { Guard against version mismatches between library and caller. } + cinfo^.mem := NIL; { so jpeg_destroy knows mem mgr not called } + if (version <> JPEG_LIB_VERSION) then + ERREXIT2(j_common_ptr(cinfo), JERR_BAD_LIB_VERSION, JPEG_LIB_VERSION, version); + if (structsize <> SIZEOF(jpeg_decompress_struct)) then + ERREXIT2(j_common_ptr(cinfo), JERR_BAD_STRUCT_SIZE, + int(SIZEOF(jpeg_decompress_struct)), int(structsize)); + + { For debugging purposes, we zero the whole master structure. + But the application has already set the err pointer, and may have set + client_data, so we have to save and restore those fields. + Note: if application hasn't set client_data, tools like Purify may + complain here. } + begin + err := cinfo^.err; + client_data := cinfo^.client_data; { ignore Purify complaint here } + MEMZERO(j_common_ptr(cinfo), SIZEOF(jpeg_decompress_struct)); + cinfo^.err := err; + cinfo^.client_data := client_data; + end; + cinfo^.is_decompressor := TRUE; + + { Initialize a memory manager instance for this object } + jinit_memory_mgr(j_common_ptr(cinfo)); + + { Zero out pointers to permanent structures. } + cinfo^.progress := NIL; + cinfo^.src := NIL; + + for i := 0 to pred(NUM_QUANT_TBLS) do + cinfo^.quant_tbl_ptrs[i] := NIL; + + for i := 0 to pred(NUM_HUFF_TBLS) do + begin + cinfo^.dc_huff_tbl_ptrs[i] := NIL; + cinfo^.ac_huff_tbl_ptrs[i] := NIL; + end; + + { Initialize marker processor so application can override methods + for COM, APPn markers before calling jpeg_read_header. } + cinfo^.marker_list := NIL; + jinit_marker_reader(cinfo); + + { And initialize the overall input controller. } + jinit_input_controller(cinfo); + + { OK, I'm ready } + cinfo^.global_state := DSTATE_START; +end; + + +{ Destruction of a JPEG decompression object } + +{GLOBAL} +procedure jpeg_destroy_decompress (cinfo : j_decompress_ptr); +begin + jpeg_destroy(j_common_ptr(cinfo)); { use common routine } +end; + + +{ Abort processing of a JPEG decompression operation, + but don't destroy the object itself. } + +{GLOBAL} +procedure jpeg_abort_decompress (cinfo : j_decompress_ptr); +begin + jpeg_abort(j_common_ptr(cinfo)); { use common routine } +end; + + +{ Set default decompression parameters. } + +{LOCAL} +procedure default_decompress_parms (cinfo : j_decompress_ptr); +var + cid0 : int; + cid1 : int; + cid2 : int; +begin + { Guess the input colorspace, and set output colorspace accordingly. } + { (Wish JPEG committee had provided a real way to specify this...) } + { Note application may override our guesses. } + case (cinfo^.num_components) of + 1: begin + cinfo^.jpeg_color_space := JCS_GRAYSCALE; + cinfo^.out_color_space := JCS_GRAYSCALE; + end; + + 3: begin + if (cinfo^.saw_JFIF_marker) then + begin + cinfo^.jpeg_color_space := JCS_YCbCr; { JFIF implies YCbCr } + end + else + if (cinfo^.saw_Adobe_marker) then + begin + case (cinfo^.Adobe_transform) of + 0: cinfo^.jpeg_color_space := JCS_RGB; + 1: cinfo^.jpeg_color_space := JCS_YCbCr; + else + begin + WARNMS1(j_common_ptr(cinfo), JWRN_ADOBE_XFORM, cinfo^.Adobe_transform); + cinfo^.jpeg_color_space := JCS_YCbCr; { assume it's YCbCr } + end; + end; + end + else + begin + { Saw no special markers, try to guess from the component IDs } + cid0 := cinfo^.comp_info^[0].component_id; + cid1 := cinfo^.comp_info^[1].component_id; + cid2 := cinfo^.comp_info^[2].component_id; + + if (cid0 = 1) and (cid1 = 2) and (cid2 = 3) then + cinfo^.jpeg_color_space := JCS_YCbCr { assume JFIF w/out marker } + else + if (cid0 = 82) and (cid1 = 71) and (cid2 = 66) then + cinfo^.jpeg_color_space := JCS_RGB { ASCII 'R', 'G', 'B' } + else + begin + {$IFDEF DEBUG} + TRACEMS3(j_common_ptr(cinfo), 1, JTRC_UNKNOWN_IDS, cid0, cid1, cid2); + {$ENDIF} + cinfo^.jpeg_color_space := JCS_YCbCr; { assume it's YCbCr } + end; + end; + { Always guess RGB is proper output colorspace. } + cinfo^.out_color_space := JCS_RGB; + end; + + 4: begin + if (cinfo^.saw_Adobe_marker) then + begin + case (cinfo^.Adobe_transform) of + 0: cinfo^.jpeg_color_space := JCS_CMYK; + 2: cinfo^.jpeg_color_space := JCS_YCCK; + else + begin + WARNMS1(j_common_ptr(cinfo), JWRN_ADOBE_XFORM, cinfo^.Adobe_transform); + cinfo^.jpeg_color_space := JCS_YCCK; { assume it's YCCK } + end; + end; + end + else + begin + { No special markers, assume straight CMYK. } + cinfo^.jpeg_color_space := JCS_CMYK; + end; + cinfo^.out_color_space := JCS_CMYK; + end; + + else + begin + cinfo^.jpeg_color_space := JCS_UNKNOWN; + cinfo^.out_color_space := JCS_UNKNOWN; + end; + end; + + { Set defaults for other decompression parameters. } + cinfo^.scale_num := 1; { 1:1 scaling } + cinfo^.scale_denom := 1; + cinfo^.output_gamma := 1.0; + cinfo^.buffered_image := FALSE; + cinfo^.raw_data_out := FALSE; + cinfo^.dct_method := JDCT_DEFAULT; + cinfo^.do_fancy_upsampling := TRUE; + cinfo^.do_block_smoothing := TRUE; + cinfo^.quantize_colors := FALSE; + { We set these in case application only sets quantize_colors. } + cinfo^.dither_mode := JDITHER_FS; +{$ifdef QUANT_2PASS_SUPPORTED} + cinfo^.two_pass_quantize := TRUE; +{$else} + cinfo^.two_pass_quantize := FALSE; +{$endif} + cinfo^.desired_number_of_colors := 256; + cinfo^.colormap := NIL; + { Initialize for no mode change in buffered-image mode. } + cinfo^.enable_1pass_quant := FALSE; + cinfo^.enable_external_quant := FALSE; + cinfo^.enable_2pass_quant := FALSE; +end; + + +{ Decompression startup: read start of JPEG datastream to see what's there. + Need only initialize JPEG object and supply a data source before calling. + + This routine will read as far as the first SOS marker (ie, actual start of + compressed data), and will save all tables and parameters in the JPEG + object. It will also initialize the decompression parameters to default + values, and finally return JPEG_HEADER_OK. On return, the application may + adjust the decompression parameters and then call jpeg_start_decompress. + (Or, if the application only wanted to determine the image parameters, + the data need not be decompressed. In that case, call jpeg_abort or + jpeg_destroy to release any temporary space.) + If an abbreviated (tables only) datastream is presented, the routine will + return JPEG_HEADER_TABLES_ONLY upon reaching EOI. The application may then + re-use the JPEG object to read the abbreviated image datastream(s). + It is unnecessary (but OK) to call jpeg_abort in this case. + The JPEG_SUSPENDED return code only occurs if the data source module + requests suspension of the decompressor. In this case the application + should load more source data and then re-call jpeg_read_header to resume + processing. + If a non-suspending data source is used and require_image is TRUE, then the + return code need not be inspected since only JPEG_HEADER_OK is possible. + + This routine is now just a front end to jpeg_consume_input, with some + extra error checking. } + +{GLOBAL} +function jpeg_read_header (cinfo : j_decompress_ptr; + require_image : boolean) : int; +var + retcode : int; +begin + if (cinfo^.global_state <> DSTATE_START) and + (cinfo^.global_state <> DSTATE_INHEADER) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + + retcode := jpeg_consume_input(cinfo); + + case (retcode) of + JPEG_REACHED_SOS: + retcode := JPEG_HEADER_OK; + JPEG_REACHED_EOI: + begin + if (require_image) then { Complain if application wanted an image } + ERREXIT(j_common_ptr(cinfo), JERR_NO_IMAGE); + { Reset to start state; it would be safer to require the application to + call jpeg_abort, but we can't change it now for compatibility reasons. + A side effect is to free any temporary memory (there shouldn't be any). } + + jpeg_abort(j_common_ptr(cinfo)); { sets state := DSTATE_START } + retcode := JPEG_HEADER_TABLES_ONLY; + end; + JPEG_SUSPENDED: ; { no work } + end; + + jpeg_read_header := retcode; +end; + + +{ Consume data in advance of what the decompressor requires. + This can be called at any time once the decompressor object has + been created and a data source has been set up. + + This routine is essentially a state machine that handles a couple + of critical state-transition actions, namely initial setup and + transition from header scanning to ready-for-start_decompress. + All the actual input is done via the input controller's consume_input + method. } + +{GLOBAL} +function jpeg_consume_input (cinfo : j_decompress_ptr) : int; +var + retcode : int; +begin + retcode := JPEG_SUSPENDED; + + { NB: every possible DSTATE value should be listed in this switch } + + if (cinfo^.global_state) = DSTATE_START then + begin {work around the FALLTHROUGH} + { Start-of-datastream actions: reset appropriate modules } + cinfo^.inputctl^.reset_input_controller (cinfo); + { Initialize application's data source module } + cinfo^.src^.init_source (cinfo); + cinfo^.global_state := DSTATE_INHEADER; + end; + + case (cinfo^.global_state) of + DSTATE_START, + DSTATE_INHEADER: + begin + retcode := cinfo^.inputctl^.consume_input (cinfo); + if (retcode = JPEG_REACHED_SOS) then + begin { Found SOS, prepare to decompress } + { Set up default parameters based on header data } + default_decompress_parms(cinfo); + { Set global state: ready for start_decompress } + cinfo^.global_state := DSTATE_READY; + end; + end; + DSTATE_READY: + { Can't advance past first SOS until start_decompress is called } + retcode := JPEG_REACHED_SOS; + + DSTATE_PRELOAD, + DSTATE_PRESCAN, + DSTATE_SCANNING, + DSTATE_RAW_OK, + DSTATE_BUFIMAGE, + DSTATE_BUFPOST, + DSTATE_STOPPING: + retcode := cinfo^.inputctl^.consume_input (cinfo); + else + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + end; + jpeg_consume_input := retcode; +end; + + +{ Have we finished reading the input file? } + +{GLOBAL} +function jpeg_input_complete (cinfo : j_decompress_ptr) : boolean; +begin + { Check for valid jpeg object } + if (cinfo^.global_state < DSTATE_START) or + (cinfo^.global_state > DSTATE_STOPPING) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + jpeg_input_complete := cinfo^.inputctl^.eoi_reached; +end; + + +{ Is there more than one scan? } + +{GLOBAL} +function jpeg_has_multiple_scans (cinfo : j_decompress_ptr) : boolean; +begin + { Only valid after jpeg_read_header completes } + if (cinfo^.global_state < DSTATE_READY) or + (cinfo^.global_state > DSTATE_STOPPING) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + jpeg_has_multiple_scans := cinfo^.inputctl^.has_multiple_scans; +end; + + +{ Finish JPEG decompression. + + This will normally just verify the file trailer and release temp storage. + + Returns FALSE if suspended. The return value need be inspected only if + a suspending data source is used. } + +{GLOBAL} +function jpeg_finish_decompress (cinfo : j_decompress_ptr) : boolean; +begin + if ((cinfo^.global_state = DSTATE_SCANNING) or + (cinfo^.global_state = DSTATE_RAW_OK) and (not cinfo^.buffered_image)) then + begin + { Terminate final pass of non-buffered mode } + if (cinfo^.output_scanline < cinfo^.output_height) then + ERREXIT(j_common_ptr(cinfo), JERR_TOO_LITTLE_DATA); + cinfo^.master^.finish_output_pass (cinfo); + cinfo^.global_state := DSTATE_STOPPING; + end + else + if (cinfo^.global_state = DSTATE_BUFIMAGE) then + begin + { Finishing after a buffered-image operation } + cinfo^.global_state := DSTATE_STOPPING; + end + else + if (cinfo^.global_state <> DSTATE_STOPPING) then + begin + { STOPPING := repeat call after a suspension, anything else is error } + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + end; + { Read until EOI } + while (not cinfo^.inputctl^.eoi_reached) do + begin + if (cinfo^.inputctl^.consume_input (cinfo) = JPEG_SUSPENDED) then + begin + jpeg_finish_decompress := FALSE; { Suspend, come back later } + exit; + end; + end; + { Do final cleanup } + cinfo^.src^.term_source (cinfo); + { We can use jpeg_abort to release memory and reset global_state } + jpeg_abort(j_common_ptr(cinfo)); + jpeg_finish_decompress := TRUE; +end; + +end. diff --git a/Imaging/JpegLib/imjdapistd.pas b/Imaging/JpegLib/imjdapistd.pas index cef249b..04bf666 100644 --- a/Imaging/JpegLib/imjdapistd.pas +++ b/Imaging/JpegLib/imjdapistd.pas @@ -1,377 +1,377 @@ -unit imjdapistd; - -{ Original : jdapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - -{ This file is part of the Independent JPEG Group's software. - For conditions of distribution and use, see the accompanying README file. - - This file contains application interface code for the decompression half - of the JPEG library. These are the "standard" API routines that are - used in the normal full-decompression case. They are not used by a - transcoding-only application. Note that if an application links in - jpeg_start_decompress, it will end up linking in the entire decompressor. - We thus must separate this file from jdapimin.c to avoid linking the - whole decompression library into a transcoder. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjpeglib, - imjdmaster; - -{ Read some scanlines of data from the JPEG decompressor. - - The return value will be the number of lines actually read. - This may be less than the number requested in several cases, - including bottom of image, data source suspension, and operating - modes that emit multiple scanlines at a time. - - Note: we warn about excess calls to jpeg_read_scanlines() since - this likely signals an application programmer error. However, - an oversize buffer (max_lines > scanlines remaining) is not an error. } - -{GLOBAL} -function jpeg_read_scanlines (cinfo : j_decompress_ptr; - scanlines : JSAMPARRAY; - max_lines : JDIMENSION) : JDIMENSION; - - -{ Alternate entry point to read raw data. - Processes exactly one iMCU row per call, unless suspended. } - -{GLOBAL} -function jpeg_read_raw_data (cinfo : j_decompress_ptr; - data : JSAMPIMAGE; - max_lines : JDIMENSION) : JDIMENSION; - -{$ifdef D_MULTISCAN_FILES_SUPPORTED} - -{ Initialize for an output pass in buffered-image mode. } - -{GLOBAL} -function jpeg_start_output (cinfo : j_decompress_ptr; - scan_number : int) : boolean; - -{ Finish up after an output pass in buffered-image mode. - - Returns FALSE if suspended. The return value need be inspected only if - a suspending data source is used. } - -{GLOBAL} -function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean; - -{$endif} { D_MULTISCAN_FILES_SUPPORTED } - -{ Decompression initialization. - jpeg_read_header must be completed before calling this. - - If a multipass operating mode was selected, this will do all but the - last pass, and thus may take a great deal of time. - - Returns FALSE if suspended. The return value need be inspected only if - a suspending data source is used. } - -{GLOBAL} -function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean; - - -implementation - -{ Forward declarations } -{LOCAL} -function output_pass_setup (cinfo : j_decompress_ptr) : boolean; forward; - -{ Decompression initialization. - jpeg_read_header must be completed before calling this. - - If a multipass operating mode was selected, this will do all but the - last pass, and thus may take a great deal of time. - - Returns FALSE if suspended. The return value need be inspected only if - a suspending data source is used. } - -{GLOBAL} -function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean; -var - retcode : int; -begin - if (cinfo^.global_state = DSTATE_READY) then - begin - { First call: initialize master control, select active modules } - jinit_master_decompress(cinfo); - if (cinfo^.buffered_image) then - begin - { No more work here; expecting jpeg_start_output next } - cinfo^.global_state := DSTATE_BUFIMAGE; - jpeg_start_decompress := TRUE; - exit; - end; - cinfo^.global_state := DSTATE_PRELOAD; - end; - if (cinfo^.global_state = DSTATE_PRELOAD) then - begin - { If file has multiple scans, absorb them all into the coef buffer } - if (cinfo^.inputctl^.has_multiple_scans) then - begin -{$ifdef D_MULTISCAN_FILES_SUPPORTED} - while TRUE do - begin - - { Call progress monitor hook if present } - if (cinfo^.progress <> NIL) then - cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); - { Absorb some more input } - retcode := cinfo^.inputctl^.consume_input (cinfo); - if (retcode = JPEG_SUSPENDED) then - begin - jpeg_start_decompress := FALSE; - exit; - end; - if (retcode = JPEG_REACHED_EOI) then - break; - { Advance progress counter if appropriate } - if (cinfo^.progress <> NIL) and - ((retcode = JPEG_ROW_COMPLETED) or (retcode = JPEG_REACHED_SOS)) then - begin - Inc(cinfo^.progress^.pass_counter); - if (cinfo^.progress^.pass_counter >= cinfo^.progress^.pass_limit) then - begin - { jdmaster underestimated number of scans; ratchet up one scan } - Inc(cinfo^.progress^.pass_limit, long(cinfo^.total_iMCU_rows)); - end; - end; - end; -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} { D_MULTISCAN_FILES_SUPPORTED } - end; - cinfo^.output_scan_number := cinfo^.input_scan_number; - end - else - if (cinfo^.global_state <> DSTATE_PRESCAN) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - { Perform any dummy output passes, and set up for the final pass } - jpeg_start_decompress := output_pass_setup(cinfo); -end; - - -{ Set up for an output pass, and perform any dummy pass(es) needed. - Common subroutine for jpeg_start_decompress and jpeg_start_output. - Entry: global_state := DSTATE_PRESCAN only if previously suspended. - Exit: If done, returns TRUE and sets global_state for proper output mode. - If suspended, returns FALSE and sets global_state := DSTATE_PRESCAN. } - -{LOCAL} -function output_pass_setup (cinfo : j_decompress_ptr) : boolean; -var - last_scanline : JDIMENSION; -begin - if (cinfo^.global_state <> DSTATE_PRESCAN) then - begin - { First call: do pass setup } - cinfo^.master^.prepare_for_output_pass (cinfo); - cinfo^.output_scanline := 0; - cinfo^.global_state := DSTATE_PRESCAN; - end; - { Loop over any required dummy passes } - while (cinfo^.master^.is_dummy_pass) do - begin -{$ifdef QUANT_2PASS_SUPPORTED} - { Crank through the dummy pass } - while (cinfo^.output_scanline < cinfo^.output_height) do - begin - { Call progress monitor hook if present } - if (cinfo^.progress <> NIL) then - begin - cinfo^.progress^.pass_counter := long (cinfo^.output_scanline); - cinfo^.progress^.pass_limit := long (cinfo^.output_height); - cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); - end; - { Process some data } - last_scanline := cinfo^.output_scanline; - cinfo^.main^.process_data (cinfo, JSAMPARRAY(NIL), - cinfo^.output_scanline, {var} - JDIMENSION(0)); - if (cinfo^.output_scanline = last_scanline) then - begin - output_pass_setup := FALSE; { No progress made, must suspend } - exit; - end; - end; - { Finish up dummy pass, and set up for another one } - cinfo^.master^.finish_output_pass (cinfo); - cinfo^.master^.prepare_for_output_pass (cinfo); - cinfo^.output_scanline := 0; -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} { QUANT_2PASS_SUPPORTED } - end; - { Ready for application to drive output pass through - jpeg_read_scanlines or jpeg_read_raw_data. } - if cinfo^.raw_data_out then - cinfo^.global_state := DSTATE_RAW_OK - else - cinfo^.global_state := DSTATE_SCANNING; - output_pass_setup := TRUE; -end; - - -{ Read some scanlines of data from the JPEG decompressor. - - The return value will be the number of lines actually read. - This may be less than the number requested in several cases, - including bottom of image, data source suspension, and operating - modes that emit multiple scanlines at a time. - - Note: we warn about excess calls to jpeg_read_scanlines() since - this likely signals an application programmer error. However, - an oversize buffer (max_lines > scanlines remaining) is not an error. } - -{GLOBAL} -function jpeg_read_scanlines (cinfo : j_decompress_ptr; - scanlines : JSAMPARRAY; - max_lines : JDIMENSION) : JDIMENSION; -var - row_ctr : JDIMENSION; -begin - if (cinfo^.global_state <> DSTATE_SCANNING) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - if (cinfo^.output_scanline >= cinfo^.output_height) then - begin - WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); - jpeg_read_scanlines := 0; - exit; - end; - - { Call progress monitor hook if present } - if (cinfo^.progress <> NIL) then - begin - cinfo^.progress^.pass_counter := long (cinfo^.output_scanline); - cinfo^.progress^.pass_limit := long (cinfo^.output_height); - cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); - end; - - { Process some data } - row_ctr := 0; - cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, max_lines); - Inc(cinfo^.output_scanline, row_ctr); - jpeg_read_scanlines := row_ctr; -end; - - -{ Alternate entry point to read raw data. - Processes exactly one iMCU row per call, unless suspended. } - -{GLOBAL} -function jpeg_read_raw_data (cinfo : j_decompress_ptr; - data : JSAMPIMAGE; - max_lines : JDIMENSION) : JDIMENSION; -var - lines_per_iMCU_row : JDIMENSION; -begin - if (cinfo^.global_state <> DSTATE_RAW_OK) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - if (cinfo^.output_scanline >= cinfo^.output_height) then - begin - WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); - jpeg_read_raw_data := 0; - exit; - end; - - { Call progress monitor hook if present } - if (cinfo^.progress <> NIL) then - begin - cinfo^.progress^.pass_counter := long (cinfo^.output_scanline); - cinfo^.progress^.pass_limit := long (cinfo^.output_height); - cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); - end; - - { Verify that at least one iMCU row can be returned. } - lines_per_iMCU_row := cinfo^.max_v_samp_factor * cinfo^.min_DCT_scaled_size; - if (max_lines < lines_per_iMCU_row) then - ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE); - - { Decompress directly into user's buffer. } - if (cinfo^.coef^.decompress_data (cinfo, data) = 0) then - begin - jpeg_read_raw_data := 0; { suspension forced, can do nothing more } - exit; - end; - - { OK, we processed one iMCU row. } - Inc(cinfo^.output_scanline, lines_per_iMCU_row); - jpeg_read_raw_data := lines_per_iMCU_row; -end; - - -{ Additional entry points for buffered-image mode. } - -{$ifdef D_MULTISCAN_FILES_SUPPORTED} - -{ Initialize for an output pass in buffered-image mode. } - -{GLOBAL} -function jpeg_start_output (cinfo : j_decompress_ptr; - scan_number : int) : boolean; -begin - if (cinfo^.global_state <> DSTATE_BUFIMAGE) and - (cinfo^.global_state <> DSTATE_PRESCAN) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - { Limit scan number to valid range } - if (scan_number <= 0) then - scan_number := 1; - if (cinfo^.inputctl^.eoi_reached) and - (scan_number > cinfo^.input_scan_number) then - scan_number := cinfo^.input_scan_number; - cinfo^.output_scan_number := scan_number; - { Perform any dummy output passes, and set up for the real pass } - jpeg_start_output := output_pass_setup(cinfo); -end; - - -{ Finish up after an output pass in buffered-image mode. - - Returns FALSE if suspended. The return value need be inspected only if - a suspending data source is used. } - -{GLOBAL} -function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean; -begin - if ((cinfo^.global_state = DSTATE_SCANNING) or - (cinfo^.global_state = DSTATE_RAW_OK) and cinfo^.buffered_image) then - begin - { Terminate this pass. } - { We do not require the whole pass to have been completed. } - cinfo^.master^.finish_output_pass (cinfo); - cinfo^.global_state := DSTATE_BUFPOST; - end - else - if (cinfo^.global_state <> DSTATE_BUFPOST) then - begin - { BUFPOST := repeat call after a suspension, anything else is error } - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - end; - { Read markers looking for SOS or EOI } - while (cinfo^.input_scan_number <= cinfo^.output_scan_number) and - (not cinfo^.inputctl^.eoi_reached) do - begin - if (cinfo^.inputctl^.consume_input (cinfo) = JPEG_SUSPENDED) then - begin - jpeg_finish_output := FALSE; { Suspend, come back later } - exit; - end; - end; - cinfo^.global_state := DSTATE_BUFIMAGE; - jpeg_finish_output := TRUE; -end; - -{$endif} { D_MULTISCAN_FILES_SUPPORTED } - -end. - +unit imjdapistd; + +{ Original : jdapistd.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + +{ This file is part of the Independent JPEG Group's software. + For conditions of distribution and use, see the accompanying README file. + + This file contains application interface code for the decompression half + of the JPEG library. These are the "standard" API routines that are + used in the normal full-decompression case. They are not used by a + transcoding-only application. Note that if an application links in + jpeg_start_decompress, it will end up linking in the entire decompressor. + We thus must separate this file from jdapimin.c to avoid linking the + whole decompression library into a transcoder. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjpeglib, + imjdmaster; + +{ Read some scanlines of data from the JPEG decompressor. + + The return value will be the number of lines actually read. + This may be less than the number requested in several cases, + including bottom of image, data source suspension, and operating + modes that emit multiple scanlines at a time. + + Note: we warn about excess calls to jpeg_read_scanlines() since + this likely signals an application programmer error. However, + an oversize buffer (max_lines > scanlines remaining) is not an error. } + +{GLOBAL} +function jpeg_read_scanlines (cinfo : j_decompress_ptr; + scanlines : JSAMPARRAY; + max_lines : JDIMENSION) : JDIMENSION; + + +{ Alternate entry point to read raw data. + Processes exactly one iMCU row per call, unless suspended. } + +{GLOBAL} +function jpeg_read_raw_data (cinfo : j_decompress_ptr; + data : JSAMPIMAGE; + max_lines : JDIMENSION) : JDIMENSION; + +{$ifdef D_MULTISCAN_FILES_SUPPORTED} + +{ Initialize for an output pass in buffered-image mode. } + +{GLOBAL} +function jpeg_start_output (cinfo : j_decompress_ptr; + scan_number : int) : boolean; + +{ Finish up after an output pass in buffered-image mode. + + Returns FALSE if suspended. The return value need be inspected only if + a suspending data source is used. } + +{GLOBAL} +function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean; + +{$endif} { D_MULTISCAN_FILES_SUPPORTED } + +{ Decompression initialization. + jpeg_read_header must be completed before calling this. + + If a multipass operating mode was selected, this will do all but the + last pass, and thus may take a great deal of time. + + Returns FALSE if suspended. The return value need be inspected only if + a suspending data source is used. } + +{GLOBAL} +function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean; + + +implementation + +{ Forward declarations } +{LOCAL} +function output_pass_setup (cinfo : j_decompress_ptr) : boolean; forward; + +{ Decompression initialization. + jpeg_read_header must be completed before calling this. + + If a multipass operating mode was selected, this will do all but the + last pass, and thus may take a great deal of time. + + Returns FALSE if suspended. The return value need be inspected only if + a suspending data source is used. } + +{GLOBAL} +function jpeg_start_decompress (cinfo : j_decompress_ptr) : boolean; +var + retcode : int; +begin + if (cinfo^.global_state = DSTATE_READY) then + begin + { First call: initialize master control, select active modules } + jinit_master_decompress(cinfo); + if (cinfo^.buffered_image) then + begin + { No more work here; expecting jpeg_start_output next } + cinfo^.global_state := DSTATE_BUFIMAGE; + jpeg_start_decompress := TRUE; + exit; + end; + cinfo^.global_state := DSTATE_PRELOAD; + end; + if (cinfo^.global_state = DSTATE_PRELOAD) then + begin + { If file has multiple scans, absorb them all into the coef buffer } + if (cinfo^.inputctl^.has_multiple_scans) then + begin +{$ifdef D_MULTISCAN_FILES_SUPPORTED} + while TRUE do + begin + + { Call progress monitor hook if present } + if (cinfo^.progress <> NIL) then + cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); + { Absorb some more input } + retcode := cinfo^.inputctl^.consume_input (cinfo); + if (retcode = JPEG_SUSPENDED) then + begin + jpeg_start_decompress := FALSE; + exit; + end; + if (retcode = JPEG_REACHED_EOI) then + break; + { Advance progress counter if appropriate } + if (cinfo^.progress <> NIL) and + ((retcode = JPEG_ROW_COMPLETED) or (retcode = JPEG_REACHED_SOS)) then + begin + Inc(cinfo^.progress^.pass_counter); + if (cinfo^.progress^.pass_counter >= cinfo^.progress^.pass_limit) then + begin + { jdmaster underestimated number of scans; ratchet up one scan } + Inc(cinfo^.progress^.pass_limit, long(cinfo^.total_iMCU_rows)); + end; + end; + end; +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} { D_MULTISCAN_FILES_SUPPORTED } + end; + cinfo^.output_scan_number := cinfo^.input_scan_number; + end + else + if (cinfo^.global_state <> DSTATE_PRESCAN) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + { Perform any dummy output passes, and set up for the final pass } + jpeg_start_decompress := output_pass_setup(cinfo); +end; + + +{ Set up for an output pass, and perform any dummy pass(es) needed. + Common subroutine for jpeg_start_decompress and jpeg_start_output. + Entry: global_state := DSTATE_PRESCAN only if previously suspended. + Exit: If done, returns TRUE and sets global_state for proper output mode. + If suspended, returns FALSE and sets global_state := DSTATE_PRESCAN. } + +{LOCAL} +function output_pass_setup (cinfo : j_decompress_ptr) : boolean; +var + last_scanline : JDIMENSION; +begin + if (cinfo^.global_state <> DSTATE_PRESCAN) then + begin + { First call: do pass setup } + cinfo^.master^.prepare_for_output_pass (cinfo); + cinfo^.output_scanline := 0; + cinfo^.global_state := DSTATE_PRESCAN; + end; + { Loop over any required dummy passes } + while (cinfo^.master^.is_dummy_pass) do + begin +{$ifdef QUANT_2PASS_SUPPORTED} + { Crank through the dummy pass } + while (cinfo^.output_scanline < cinfo^.output_height) do + begin + { Call progress monitor hook if present } + if (cinfo^.progress <> NIL) then + begin + cinfo^.progress^.pass_counter := long (cinfo^.output_scanline); + cinfo^.progress^.pass_limit := long (cinfo^.output_height); + cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); + end; + { Process some data } + last_scanline := cinfo^.output_scanline; + cinfo^.main^.process_data (cinfo, JSAMPARRAY(NIL), + cinfo^.output_scanline, {var} + JDIMENSION(0)); + if (cinfo^.output_scanline = last_scanline) then + begin + output_pass_setup := FALSE; { No progress made, must suspend } + exit; + end; + end; + { Finish up dummy pass, and set up for another one } + cinfo^.master^.finish_output_pass (cinfo); + cinfo^.master^.prepare_for_output_pass (cinfo); + cinfo^.output_scanline := 0; +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} { QUANT_2PASS_SUPPORTED } + end; + { Ready for application to drive output pass through + jpeg_read_scanlines or jpeg_read_raw_data. } + if cinfo^.raw_data_out then + cinfo^.global_state := DSTATE_RAW_OK + else + cinfo^.global_state := DSTATE_SCANNING; + output_pass_setup := TRUE; +end; + + +{ Read some scanlines of data from the JPEG decompressor. + + The return value will be the number of lines actually read. + This may be less than the number requested in several cases, + including bottom of image, data source suspension, and operating + modes that emit multiple scanlines at a time. + + Note: we warn about excess calls to jpeg_read_scanlines() since + this likely signals an application programmer error. However, + an oversize buffer (max_lines > scanlines remaining) is not an error. } + +{GLOBAL} +function jpeg_read_scanlines (cinfo : j_decompress_ptr; + scanlines : JSAMPARRAY; + max_lines : JDIMENSION) : JDIMENSION; +var + row_ctr : JDIMENSION; +begin + if (cinfo^.global_state <> DSTATE_SCANNING) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + if (cinfo^.output_scanline >= cinfo^.output_height) then + begin + WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); + jpeg_read_scanlines := 0; + exit; + end; + + { Call progress monitor hook if present } + if (cinfo^.progress <> NIL) then + begin + cinfo^.progress^.pass_counter := long (cinfo^.output_scanline); + cinfo^.progress^.pass_limit := long (cinfo^.output_height); + cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); + end; + + { Process some data } + row_ctr := 0; + cinfo^.main^.process_data (cinfo, scanlines, {var}row_ctr, max_lines); + Inc(cinfo^.output_scanline, row_ctr); + jpeg_read_scanlines := row_ctr; +end; + + +{ Alternate entry point to read raw data. + Processes exactly one iMCU row per call, unless suspended. } + +{GLOBAL} +function jpeg_read_raw_data (cinfo : j_decompress_ptr; + data : JSAMPIMAGE; + max_lines : JDIMENSION) : JDIMENSION; +var + lines_per_iMCU_row : JDIMENSION; +begin + if (cinfo^.global_state <> DSTATE_RAW_OK) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + if (cinfo^.output_scanline >= cinfo^.output_height) then + begin + WARNMS(j_common_ptr(cinfo), JWRN_TOO_MUCH_DATA); + jpeg_read_raw_data := 0; + exit; + end; + + { Call progress monitor hook if present } + if (cinfo^.progress <> NIL) then + begin + cinfo^.progress^.pass_counter := long (cinfo^.output_scanline); + cinfo^.progress^.pass_limit := long (cinfo^.output_height); + cinfo^.progress^.progress_monitor (j_common_ptr(cinfo)); + end; + + { Verify that at least one iMCU row can be returned. } + lines_per_iMCU_row := cinfo^.max_v_samp_factor * cinfo^.min_DCT_scaled_size; + if (max_lines < lines_per_iMCU_row) then + ERREXIT(j_common_ptr(cinfo), JERR_BUFFER_SIZE); + + { Decompress directly into user's buffer. } + if (cinfo^.coef^.decompress_data (cinfo, data) = 0) then + begin + jpeg_read_raw_data := 0; { suspension forced, can do nothing more } + exit; + end; + + { OK, we processed one iMCU row. } + Inc(cinfo^.output_scanline, lines_per_iMCU_row); + jpeg_read_raw_data := lines_per_iMCU_row; +end; + + +{ Additional entry points for buffered-image mode. } + +{$ifdef D_MULTISCAN_FILES_SUPPORTED} + +{ Initialize for an output pass in buffered-image mode. } + +{GLOBAL} +function jpeg_start_output (cinfo : j_decompress_ptr; + scan_number : int) : boolean; +begin + if (cinfo^.global_state <> DSTATE_BUFIMAGE) and + (cinfo^.global_state <> DSTATE_PRESCAN) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + { Limit scan number to valid range } + if (scan_number <= 0) then + scan_number := 1; + if (cinfo^.inputctl^.eoi_reached) and + (scan_number > cinfo^.input_scan_number) then + scan_number := cinfo^.input_scan_number; + cinfo^.output_scan_number := scan_number; + { Perform any dummy output passes, and set up for the real pass } + jpeg_start_output := output_pass_setup(cinfo); +end; + + +{ Finish up after an output pass in buffered-image mode. + + Returns FALSE if suspended. The return value need be inspected only if + a suspending data source is used. } + +{GLOBAL} +function jpeg_finish_output (cinfo : j_decompress_ptr) : boolean; +begin + if ((cinfo^.global_state = DSTATE_SCANNING) or + (cinfo^.global_state = DSTATE_RAW_OK) and cinfo^.buffered_image) then + begin + { Terminate this pass. } + { We do not require the whole pass to have been completed. } + cinfo^.master^.finish_output_pass (cinfo); + cinfo^.global_state := DSTATE_BUFPOST; + end + else + if (cinfo^.global_state <> DSTATE_BUFPOST) then + begin + { BUFPOST := repeat call after a suspension, anything else is error } + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + end; + { Read markers looking for SOS or EOI } + while (cinfo^.input_scan_number <= cinfo^.output_scan_number) and + (not cinfo^.inputctl^.eoi_reached) do + begin + if (cinfo^.inputctl^.consume_input (cinfo) = JPEG_SUSPENDED) then + begin + jpeg_finish_output := FALSE; { Suspend, come back later } + exit; + end; + end; + cinfo^.global_state := DSTATE_BUFIMAGE; + jpeg_finish_output := TRUE; +end; + +{$endif} { D_MULTISCAN_FILES_SUPPORTED } + +end. + diff --git a/Imaging/JpegLib/imjdcoefct.pas b/Imaging/JpegLib/imjdcoefct.pas index caa69a2..d488dec 100644 --- a/Imaging/JpegLib/imjdcoefct.pas +++ b/Imaging/JpegLib/imjdcoefct.pas @@ -1,895 +1,895 @@ -unit imjdcoefct; - -{ This file contains the coefficient buffer controller for decompression. - This controller is the top level of the JPEG decompressor proper. - The coefficient buffer lies between entropy decoding and inverse-DCT steps. - - In buffered-image mode, this controller is the interface between - input-oriented processing and output-oriented processing. - Also, the input side (only) is used when reading a file for transcoding. } - -{ Original: jdcoefct.c ; Copyright (C) 1994-1997, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjutils, - imjpeglib; - -{GLOBAL} -procedure jinit_d_coef_controller (cinfo : j_decompress_ptr; - need_full_buffer : boolean); - - -implementation - - -{ Block smoothing is only applicable for progressive JPEG, so: } -{$ifndef D_PROGRESSIVE_SUPPORTED} -{$undef BLOCK_SMOOTHING_SUPPORTED} -{$endif} - -{ Private buffer controller object } - -{$ifdef BLOCK_SMOOTHING_SUPPORTED} -const - SAVED_COEFS = 6; { we save coef_bits[0..5] } -type - Latch = array[0..SAVED_COEFS-1] of int; - Latch_ptr = ^Latch; -{$endif} - -type - my_coef_ptr = ^my_coef_controller; - my_coef_controller = record - pub : jpeg_d_coef_controller; { public fields } - - { These variables keep track of the current location of the input side. } - { cinfo^.input_iMCU_row is also used for this. } - MCU_ctr : JDIMENSION; { counts MCUs processed in current row } - MCU_vert_offset : int; { counts MCU rows within iMCU row } - MCU_rows_per_iMCU_row : int; { number of such rows needed } - - { The output side's location is represented by cinfo^.output_iMCU_row. } - - { In single-pass modes, it's sufficient to buffer just one MCU. - We allocate a workspace of D_MAX_BLOCKS_IN_MCU coefficient blocks, - and let the entropy decoder write into that workspace each time. - (On 80x86, the workspace is FAR even though it's not really very big; - this is to keep the module interfaces unchanged when a large coefficient - buffer is necessary.) - In multi-pass modes, this array points to the current MCU's blocks - within the virtual arrays; it is used only by the input side. } - - MCU_buffer : array[0..D_MAX_BLOCKS_IN_MCU-1] of JBLOCKROW; - - {$ifdef D_MULTISCAN_FILES_SUPPORTED} - { In multi-pass modes, we need a virtual block array for each component. } - whole_image : jvirt_barray_tbl; - {$endif} - - {$ifdef BLOCK_SMOOTHING_SUPPORTED} - { When doing block smoothing, we latch coefficient Al values here } - coef_bits_latch : Latch_Ptr; - {$endif} - end; - -{ Forward declarations } -{METHODDEF} -function decompress_onepass (cinfo : j_decompress_ptr; - output_buf : JSAMPIMAGE) : int; forward; -{$ifdef D_MULTISCAN_FILES_SUPPORTED} -{METHODDEF} -function decompress_data (cinfo : j_decompress_ptr; - output_buf : JSAMPIMAGE) : int; forward; -{$endif} -{$ifdef BLOCK_SMOOTHING_SUPPORTED} -{LOCAL} -function smoothing_ok (cinfo : j_decompress_ptr) : boolean; forward; - -{METHODDEF} -function decompress_smooth_data (cinfo : j_decompress_ptr; - output_buf : JSAMPIMAGE) : int; forward; -{$endif} - - -{LOCAL} -procedure start_iMCU_row (cinfo : j_decompress_ptr); -{ Reset within-iMCU-row counters for a new row (input side) } -var - coef : my_coef_ptr; -begin - coef := my_coef_ptr (cinfo^.coef); - - { In an interleaved scan, an MCU row is the same as an iMCU row. - In a noninterleaved scan, an iMCU row has v_samp_factor MCU rows. - But at the bottom of the image, process only what's left. } - - if (cinfo^.comps_in_scan > 1) then - begin - coef^.MCU_rows_per_iMCU_row := 1; - end - else - begin - if (cinfo^.input_iMCU_row < (cinfo^.total_iMCU_rows-1)) then - coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.v_samp_factor - else - coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.last_row_height; - end; - - coef^.MCU_ctr := 0; - coef^.MCU_vert_offset := 0; -end; - - -{ Initialize for an input processing pass. } - -{METHODDEF} -procedure start_input_pass (cinfo : j_decompress_ptr); -begin - cinfo^.input_iMCU_row := 0; - start_iMCU_row(cinfo); -end; - - -{ Initialize for an output processing pass. } - -{METHODDEF} -procedure start_output_pass (cinfo : j_decompress_ptr); -var - coef : my_coef_ptr; -begin -{$ifdef BLOCK_SMOOTHING_SUPPORTED} - coef := my_coef_ptr (cinfo^.coef); - - { If multipass, check to see whether to use block smoothing on this pass } - if (coef^.pub.coef_arrays <> NIL) then - begin - if (cinfo^.do_block_smoothing) and smoothing_ok(cinfo) then - coef^.pub.decompress_data := decompress_smooth_data - else - coef^.pub.decompress_data := decompress_data; - end; -{$endif} - cinfo^.output_iMCU_row := 0; -end; - - -{ Decompress and return some data in the single-pass case. - Always attempts to emit one fully interleaved MCU row ("iMCU" row). - Input and output must run in lockstep since we have only a one-MCU buffer. - Return value is JPEG_ROW_COMPLETED, JPEG_SCAN_COMPLETED, or JPEG_SUSPENDED. - - NB: output_buf contains a plane for each component in image, - which we index according to the component's SOF position.} - -{METHODDEF} -function decompress_onepass (cinfo : j_decompress_ptr; - output_buf : JSAMPIMAGE) : int; -var - coef : my_coef_ptr; - MCU_col_num : JDIMENSION; { index of current MCU within row } - last_MCU_col : JDIMENSION; - last_iMCU_row : JDIMENSION; - blkn, ci, xindex, yindex, yoffset, useful_width : int; - output_ptr : JSAMPARRAY; - start_col, output_col : JDIMENSION; - compptr : jpeg_component_info_ptr; - inverse_DCT : inverse_DCT_method_ptr; -begin - coef := my_coef_ptr (cinfo^.coef); - last_MCU_col := cinfo^.MCUs_per_row - 1; - last_iMCU_row := cinfo^.total_iMCU_rows - 1; - - { Loop to process as much as one whole iMCU row } - for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do - begin - for MCU_col_num := coef^.MCU_ctr to last_MCU_col do - begin - { Try to fetch an MCU. Entropy decoder expects buffer to be zeroed. } - jzero_far( coef^.MCU_buffer[0], - size_t (cinfo^.blocks_in_MCU * SIZEOF(JBLOCK))); - if (not cinfo^.entropy^.decode_mcu (cinfo, coef^.MCU_buffer)) then - begin - { Suspension forced; update state counters and exit } - coef^.MCU_vert_offset := yoffset; - coef^.MCU_ctr := MCU_col_num; - decompress_onepass := JPEG_SUSPENDED; - exit; - end; - { Determine where data should go in output_buf and do the IDCT thing. - We skip dummy blocks at the right and bottom edges (but blkn gets - incremented past them!). Note the inner loop relies on having - allocated the MCU_buffer[] blocks sequentially. } - - blkn := 0; { index of current DCT block within MCU } - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - { Don't bother to IDCT an uninteresting component. } - if (not compptr^.component_needed) then - begin - Inc(blkn, compptr^.MCU_blocks); - continue; - end; - inverse_DCT := cinfo^.idct^.inverse_DCT[compptr^.component_index]; - if (MCU_col_num < last_MCU_col) then - useful_width := compptr^.MCU_width - else - useful_width := compptr^.last_col_width; - - output_ptr := JSAMPARRAY(@ output_buf^[compptr^.component_index]^ - [yoffset * compptr^.DCT_scaled_size]); - start_col := LongInt(MCU_col_num) * compptr^.MCU_sample_width; - for yindex := 0 to pred(compptr^.MCU_height) do - begin - if (cinfo^.input_iMCU_row < last_iMCU_row) or - (yoffset+yindex < compptr^.last_row_height) then - begin - output_col := start_col; - for xindex := 0 to pred(useful_width) do - begin - inverse_DCT (cinfo, compptr, - JCOEFPTR(coef^.MCU_buffer[blkn+xindex]), - output_ptr, output_col); - Inc(output_col, compptr^.DCT_scaled_size); - end; - end; - Inc(blkn, compptr^.MCU_width); - Inc(JSAMPROW_PTR(output_ptr), compptr^.DCT_scaled_size); - end; - end; - end; - { Completed an MCU row, but perhaps not an iMCU row } - coef^.MCU_ctr := 0; - end; - { Completed the iMCU row, advance counters for next one } - Inc(cinfo^.output_iMCU_row); - - Inc(cinfo^.input_iMCU_row); - if (cinfo^.input_iMCU_row < cinfo^.total_iMCU_rows) then - begin - start_iMCU_row(cinfo); - decompress_onepass := JPEG_ROW_COMPLETED; - exit; - end; - { Completed the scan } - cinfo^.inputctl^.finish_input_pass (cinfo); - decompress_onepass := JPEG_SCAN_COMPLETED; -end; - -{ Dummy consume-input routine for single-pass operation. } - -{METHODDEF} -function dummy_consume_data (cinfo : j_decompress_ptr) : int; -begin - dummy_consume_data := JPEG_SUSPENDED; { Always indicate nothing was done } -end; - - -{$ifdef D_MULTISCAN_FILES_SUPPORTED} - -{ Consume input data and store it in the full-image coefficient buffer. - We read as much as one fully interleaved MCU row ("iMCU" row) per call, - ie, v_samp_factor block rows for each component in the scan. - Return value is JPEG_ROW_COMPLETED, JPEG_SCAN_COMPLETED, or JPEG_SUSPENDED.} - -{METHODDEF} -function consume_data (cinfo : j_decompress_ptr) : int; -var - coef : my_coef_ptr; - MCU_col_num : JDIMENSION; { index of current MCU within row } - blkn, ci, xindex, yindex, yoffset : int; - start_col : JDIMENSION; - buffer : array[0..MAX_COMPS_IN_SCAN-1] of JBLOCKARRAY; - buffer_ptr : JBLOCKROW; - compptr : jpeg_component_info_ptr; -begin - coef := my_coef_ptr (cinfo^.coef); - - { Align the virtual buffers for the components used in this scan. } - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - buffer[ci] := cinfo^.mem^.access_virt_barray - (j_common_ptr (cinfo), coef^.whole_image[compptr^.component_index], - LongInt(cinfo^.input_iMCU_row) * compptr^.v_samp_factor, - JDIMENSION (compptr^.v_samp_factor), TRUE); - { Note: entropy decoder expects buffer to be zeroed, - but this is handled automatically by the memory manager - because we requested a pre-zeroed array. } - - end; - - { Loop to process one whole iMCU row } - for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do - begin - for MCU_col_num := coef^.MCU_ctr to pred(cinfo^.MCUs_per_row) do - begin - { Construct list of pointers to DCT blocks belonging to this MCU } - blkn := 0; { index of current DCT block within MCU } - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - start_col := LongInt(MCU_col_num) * compptr^.MCU_width; - for yindex := 0 to pred(compptr^.MCU_height) do - begin - buffer_ptr := JBLOCKROW(@ buffer[ci]^[yindex+yoffset]^[start_col]); - for xindex := 0 to pred(compptr^.MCU_width) do - begin - coef^.MCU_buffer[blkn] := buffer_ptr; - Inc(blkn); - Inc(JBLOCK_PTR(buffer_ptr)); - end; - end; - end; - { Try to fetch the MCU. } - if (not cinfo^.entropy^.decode_mcu (cinfo, coef^.MCU_buffer)) then - begin - { Suspension forced; update state counters and exit } - coef^.MCU_vert_offset := yoffset; - coef^.MCU_ctr := MCU_col_num; - consume_data := JPEG_SUSPENDED; - exit; - end; - end; - { Completed an MCU row, but perhaps not an iMCU row } - coef^.MCU_ctr := 0; - end; - { Completed the iMCU row, advance counters for next one } - Inc(cinfo^.input_iMCU_row); - if (cinfo^.input_iMCU_row < cinfo^.total_iMCU_rows) then - begin - start_iMCU_row(cinfo); - consume_data := JPEG_ROW_COMPLETED; - exit; - end; - { Completed the scan } - cinfo^.inputctl^.finish_input_pass (cinfo); - consume_data := JPEG_SCAN_COMPLETED; -end; - - -{ Decompress and return some data in the multi-pass case. - Always attempts to emit one fully interleaved MCU row ("iMCU" row). - Return value is JPEG_ROW_COMPLETED, JPEG_SCAN_COMPLETED, or JPEG_SUSPENDED. - - NB: output_buf contains a plane for each component in image. } - -{METHODDEF} -function decompress_data (cinfo : j_decompress_ptr; - output_buf : JSAMPIMAGE) : int; -var - coef : my_coef_ptr; - last_iMCU_row : JDIMENSION; - block_num : JDIMENSION; - ci, block_row, block_rows : int; - buffer : JBLOCKARRAY; - buffer_ptr : JBLOCKROW; - output_ptr : JSAMPARRAY; - output_col : JDIMENSION; - compptr : jpeg_component_info_ptr; - inverse_DCT : inverse_DCT_method_ptr; -begin - coef := my_coef_ptr (cinfo^.coef); - last_iMCU_row := cinfo^.total_iMCU_rows - 1; - - { Force some input to be done if we are getting ahead of the input. } - while (cinfo^.input_scan_number < cinfo^.output_scan_number) or - ((cinfo^.input_scan_number = cinfo^.output_scan_number) and - (LongInt(cinfo^.input_iMCU_row) <= cinfo^.output_iMCU_row)) do - begin - if (cinfo^.inputctl^.consume_input(cinfo) = JPEG_SUSPENDED) then - begin - decompress_data := JPEG_SUSPENDED; - exit; - end; - end; - - { OK, output from the virtual arrays. } - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - { Don't bother to IDCT an uninteresting component. } - if (not compptr^.component_needed) then - continue; - { Align the virtual buffer for this component. } - buffer := cinfo^.mem^.access_virt_barray - (j_common_ptr (cinfo), coef^.whole_image[ci], - cinfo^.output_iMCU_row * compptr^.v_samp_factor, - JDIMENSION (compptr^.v_samp_factor), FALSE); - { Count non-dummy DCT block rows in this iMCU row. } - if (cinfo^.output_iMCU_row < LongInt(last_iMCU_row)) then - block_rows := compptr^.v_samp_factor - else - begin - { NB: can't use last_row_height here; it is input-side-dependent! } - block_rows := int(LongInt(compptr^.height_in_blocks) mod compptr^.v_samp_factor); - if (block_rows = 0) then - block_rows := compptr^.v_samp_factor; - end; - inverse_DCT := cinfo^.idct^.inverse_DCT[ci]; - output_ptr := output_buf^[ci]; - { Loop over all DCT blocks to be processed. } - for block_row := 0 to pred(block_rows) do - begin - buffer_ptr := buffer^[block_row]; - output_col := 0; - for block_num := 0 to pred(compptr^.width_in_blocks) do - begin - inverse_DCT (cinfo, compptr, JCOEFPTR (buffer_ptr), - output_ptr, output_col); - Inc(JBLOCK_PTR(buffer_ptr)); - Inc(output_col, compptr^.DCT_scaled_size); - end; - Inc(JSAMPROW_PTR(output_ptr), compptr^.DCT_scaled_size); - end; - Inc(compptr); - end; - - Inc(cinfo^.output_iMCU_row); - if (cinfo^.output_iMCU_row < LongInt(cinfo^.total_iMCU_rows)) then - begin - decompress_data := JPEG_ROW_COMPLETED; - exit; - end; - decompress_data := JPEG_SCAN_COMPLETED; -end; - -{$endif} { D_MULTISCAN_FILES_SUPPORTED } - - -{$ifdef BLOCK_SMOOTHING_SUPPORTED} - -{ This code applies interblock smoothing as described by section K.8 - of the JPEG standard: the first 5 AC coefficients are estimated from - the DC values of a DCT block and its 8 neighboring blocks. - We apply smoothing only for progressive JPEG decoding, and only if - the coefficients it can estimate are not yet known to full precision. } - -{ Natural-order array positions of the first 5 zigzag-order coefficients } -const - Q01_POS = 1; - Q10_POS = 8; - Q20_POS = 16; - Q11_POS = 9; - Q02_POS = 2; - -{ Determine whether block smoothing is applicable and safe. - We also latch the current states of the coef_bits[] entries for the - AC coefficients; otherwise, if the input side of the decompressor - advances into a new scan, we might think the coefficients are known - more accurately than they really are. } - -{LOCAL} -function smoothing_ok (cinfo : j_decompress_ptr) : boolean; -var - coef : my_coef_ptr; - smoothing_useful : boolean; - ci, coefi : int; - compptr : jpeg_component_info_ptr; - qtable : JQUANT_TBL_PTR; - coef_bits : coef_bits_ptr; - coef_bits_latch : Latch_Ptr; -begin - coef := my_coef_ptr (cinfo^.coef); - smoothing_useful := FALSE; - - if (not cinfo^.progressive_mode) or (cinfo^.coef_bits = NIL) then - begin - smoothing_ok := FALSE; - exit; - end; - - { Allocate latch area if not already done } - if (coef^.coef_bits_latch = NIL) then - coef^.coef_bits_latch := Latch_Ptr( - cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, - cinfo^.num_components * - (SAVED_COEFS * SIZEOF(int))) ); - coef_bits_latch := (coef^.coef_bits_latch); - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - { All components' quantization values must already be latched. } - qtable := compptr^.quant_table; - if (qtable = NIL) then - begin - smoothing_ok := FALSE; - exit; - end; - { Verify DC & first 5 AC quantizers are nonzero to avoid zero-divide. } - if (qtable^.quantval[0] = 0) or - (qtable^.quantval[Q01_POS] = 0) or - (qtable^.quantval[Q10_POS] = 0) or - (qtable^.quantval[Q20_POS] = 0) or - (qtable^.quantval[Q11_POS] = 0) or - (qtable^.quantval[Q02_POS] = 0) then - begin - smoothing_ok := FALSE; - exit; - end; - { DC values must be at least partly known for all components. } - coef_bits := @cinfo^.coef_bits^[ci]; { Nomssi } - if (coef_bits^[0] < 0) then - begin - smoothing_ok := FALSE; - exit; - end; - { Block smoothing is helpful if some AC coefficients remain inaccurate. } - for coefi := 1 to 5 do - begin - coef_bits_latch^[coefi] := coef_bits^[coefi]; - if (coef_bits^[coefi] <> 0) then - smoothing_useful := TRUE; - end; - Inc(coef_bits_latch {SAVED_COEFS}); - Inc(compptr); - end; - - smoothing_ok := smoothing_useful; -end; - - -{ Variant of decompress_data for use when doing block smoothing. } - -{METHODDEF} -function decompress_smooth_data (cinfo : j_decompress_ptr; - output_buf : JSAMPIMAGE) : int; -var - coef : my_coef_ptr; - last_iMCU_row : JDIMENSION; - block_num, last_block_column : JDIMENSION; - ci, block_row, block_rows, access_rows : int; - buffer : JBLOCKARRAY; - buffer_ptr, prev_block_row, next_block_row : JBLOCKROW; - output_ptr : JSAMPARRAY; - output_col : JDIMENSION; - compptr : jpeg_component_info_ptr; - inverse_DCT : inverse_DCT_method_ptr; - first_row, last_row : boolean; - workspace : JBLOCK; - coef_bits : Latch_Ptr; { coef_bits_ptr; } - quanttbl : JQUANT_TBL_PTR; - Q00,Q01,Q02,Q10,Q11,Q20, num : INT32; - DC1,DC2,DC3,DC4,DC5,DC6,DC7,DC8,DC9 : int; - Al, pred : int; -var - delta : JDIMENSION; -begin - coef := my_coef_ptr (cinfo^.coef); - last_iMCU_row := cinfo^.total_iMCU_rows - 1; - - { Force some input to be done if we are getting ahead of the input. } - while (cinfo^.input_scan_number <= cinfo^.output_scan_number) and - (not cinfo^.inputctl^.eoi_reached) do - begin - if (cinfo^.input_scan_number = cinfo^.output_scan_number) then - begin - { If input is working on current scan, we ordinarily want it to - have completed the current row. But if input scan is DC, - we want it to keep one row ahead so that next block row's DC - values are up to date. } - - if (cinfo^.Ss = 0) then - delta := 1 - else - delta := 0; - if (LongInt(cinfo^.input_iMCU_row) > cinfo^.output_iMCU_row+LongInt(delta)) then - break; - end; - if (cinfo^.inputctl^.consume_input(cinfo) = JPEG_SUSPENDED) then - begin - decompress_smooth_data := JPEG_SUSPENDED; - exit; - end; - end; - - { OK, output from the virtual arrays. } - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to (cinfo^.num_components-1) do - begin - { Don't bother to IDCT an uninteresting component. } - if (not compptr^.component_needed) then - continue; - { Count non-dummy DCT block rows in this iMCU row. } - if (cinfo^.output_iMCU_row < LongInt(last_iMCU_row)) then - begin - block_rows := compptr^.v_samp_factor; - access_rows := block_rows * 2; { this and next iMCU row } - last_row := FALSE; - end - else - begin - { NB: can't use last_row_height here; it is input-side-dependent! } - block_rows := int (compptr^.height_in_blocks) mod compptr^.v_samp_factor; - if (block_rows = 0) then - block_rows := compptr^.v_samp_factor; - access_rows := block_rows; { this iMCU row only } - last_row := TRUE; - end; - { Align the virtual buffer for this component. } - if (cinfo^.output_iMCU_row > 0) then - begin - Inc(access_rows, compptr^.v_samp_factor); { prior iMCU row too } - buffer := cinfo^.mem^.access_virt_barray - (j_common_ptr (cinfo), coef^.whole_image[ci], - (cinfo^.output_iMCU_row - 1) * compptr^.v_samp_factor, - JDIMENSION (access_rows), FALSE); - Inc(JBLOCKROW_PTR(buffer), compptr^.v_samp_factor); { point to current iMCU row } - first_row := FALSE; - end - else - begin - buffer := cinfo^.mem^.access_virt_barray - (j_common_ptr (cinfo), coef^.whole_image[ci], - JDIMENSION (0), JDIMENSION (access_rows), FALSE); - first_row := TRUE; - end; - { Fetch component-dependent info } - coef_bits := coef^.coef_bits_latch; - Inc(coef_bits, ci); { ci * SAVED_COEFS} - quanttbl := compptr^.quant_table; - Q00 := quanttbl^.quantval[0]; - Q01 := quanttbl^.quantval[Q01_POS]; - Q10 := quanttbl^.quantval[Q10_POS]; - Q20 := quanttbl^.quantval[Q20_POS]; - Q11 := quanttbl^.quantval[Q11_POS]; - Q02 := quanttbl^.quantval[Q02_POS]; - inverse_DCT := cinfo^.idct^.inverse_DCT[ci]; - output_ptr := output_buf^[ci]; - { Loop over all DCT blocks to be processed. } - for block_row := 0 to (block_rows-1) do - begin - buffer_ptr := buffer^[block_row]; - if (first_row) and (block_row = 0) then - prev_block_row := buffer_ptr - else - prev_block_row := buffer^[block_row-1]; - if (last_row) and (block_row = block_rows-1) then - next_block_row := buffer_ptr - else - next_block_row := buffer^[block_row+1]; - { We fetch the surrounding DC values using a sliding-register approach. - Initialize all nine here so as to do the right thing on narrow pics.} - - DC3 := int(prev_block_row^[0][0]); - DC2 := DC3; - DC1 := DC2; - DC6 := int(buffer_ptr^[0][0]); - DC5 := DC6; - DC4 := DC5; - DC9 := int(next_block_row^[0][0]); - DC8 := DC9; - DC7 := DC8 ; - output_col := 0; - last_block_column := compptr^.width_in_blocks - 1; - for block_num := 0 to last_block_column do - begin - { Fetch current DCT block into workspace so we can modify it. } - jcopy_block_row(buffer_ptr, JBLOCKROW (@workspace), JDIMENSION(1)); - { Update DC values } - if (block_num < last_block_column) then - begin - DC3 := int (prev_block_row^[1][0]); - DC6 := int (buffer_ptr^[1][0]); - DC9 := int (next_block_row^[1][0]); - end; - { Compute coefficient estimates per K.8. - An estimate is applied only if coefficient is still zero, - and is not known to be fully accurate. } - - { AC01 } - Al := coef_bits^[1]; - if (Al <> 0) and (workspace[1] = 0) then - begin - num := 36 * Q00 * (DC4 - DC6); - if (num >= 0) then - begin - pred := int (((Q01 shl 7) + num) div (Q01 shl 8)); - if (Al > 0) and (pred >= (1 shl Al)) then - pred := (1 shl Al)-1; - end - else - begin - pred := int (((Q01 shl 7) - num) div (Q01 shl 8)); - if (Al > 0) and (pred >= (1 shl Al)) then - pred := (1 shl Al)-1; - pred := -pred; - end; - workspace[1] := JCOEF (pred); - end; - { AC10 } - Al := coef_bits^[2]; - if (Al <> 0) and (workspace[8] = 0) then - begin - num := 36 * Q00 * (DC2 - DC8); - if (num >= 0) then - begin - pred := int (((Q10 shl 7) + num) div (Q10 shl 8)); - if (Al > 0) and (pred >= (1 shl Al)) then - pred := (1 shl Al)-1; - end - else - begin - pred := int (((Q10 shl 7) - num) div (Q10 shl 8)); - if (Al > 0) and (pred >= (1 shl Al)) then - pred := (1 shl Al)-1; - pred := -pred; - end; - workspace[8] := JCOEF (pred); - end; - { AC20 } - Al := coef_bits^[3]; - if (Al <> 0) and (workspace[16] = 0) then - begin - num := 9 * Q00 * (DC2 + DC8 - 2*DC5); - if (num >= 0) then - begin - pred := int (((Q20 shl 7) + num) div (Q20 shl 8)); - if (Al > 0) and (pred >= (1 shl Al)) then - pred := (1 shl Al)-1; - end - else - begin - pred := int (((Q20 shl 7) - num) div (Q20 shl 8)); - if (Al > 0) and (pred >= (1 shl Al)) then - pred := (1 shl Al)-1; - pred := -pred; - end; - workspace[16] := JCOEF (pred); - end; - { AC11 } - Al := coef_bits^[4]; - if (Al <> 0) and (workspace[9] = 0) then - begin - num := 5 * Q00 * (DC1 - DC3 - DC7 + DC9); - if (num >= 0) then - begin - pred := int (((Q11 shl 7) + num) div (Q11 shl 8)); - if (Al > 0) and (pred >= (1 shl Al)) then - pred := (1 shl Al)-1; - end - else - begin - pred := int (((Q11 shl 7) - num) div (Q11 shl 8)); - if (Al > 0) and (pred >= (1 shl Al)) then - pred := (1 shl Al)-1; - pred := -pred; - end; - workspace[9] := JCOEF (pred); - end; - { AC02 } - Al := coef_bits^[5]; - if (Al <> 0) and (workspace[2] = 0) then - begin - num := 9 * Q00 * (DC4 + DC6 - 2*DC5); - if (num >= 0) then - begin - pred := int (((Q02 shl 7) + num) div (Q02 shl 8)); - if (Al > 0) and (pred >= (1 shl Al)) then - pred := (1 shl Al)-1; - end - else - begin - pred := int (((Q02 shl 7) - num) div (Q02 shl 8)); - if (Al > 0) and (pred >= (1 shl Al)) then - pred := (1 shl Al)-1; - pred := -pred; - end; - workspace[2] := JCOEF (pred); - end; - { OK, do the IDCT } - inverse_DCT (cinfo, compptr, JCOEFPTR (@workspace), - output_ptr, output_col); - { Advance for next column } - DC1 := DC2; DC2 := DC3; - DC4 := DC5; DC5 := DC6; - DC7 := DC8; DC8 := DC9; - Inc(JBLOCK_PTR(buffer_ptr)); - Inc(JBLOCK_PTR(prev_block_row)); - Inc(JBLOCK_PTR(next_block_row)); - Inc(output_col, compptr^.DCT_scaled_size); - end; - Inc(JSAMPROW_PTR(output_ptr), compptr^.DCT_scaled_size); - end; - Inc(compptr); - end; - - Inc(cinfo^.output_iMCU_row); - if (cinfo^.output_iMCU_row < LongInt(cinfo^.total_iMCU_rows)) then - begin - decompress_smooth_data := JPEG_ROW_COMPLETED; - exit; - end; - decompress_smooth_data := JPEG_SCAN_COMPLETED; -end; - -{$endif} { BLOCK_SMOOTHING_SUPPORTED } - - -{ Initialize coefficient buffer controller. } - -{GLOBAL} -procedure jinit_d_coef_controller (cinfo : j_decompress_ptr; - need_full_buffer : boolean); -var - coef : my_coef_ptr; -{$ifdef D_MULTISCAN_FILES_SUPPORTED} -var - ci, access_rows : int; - compptr : jpeg_component_info_ptr; -{$endif} -var - buffer : JBLOCK_PTR; - i : int; -begin - coef := my_coef_ptr( - cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, - SIZEOF(my_coef_controller)) ); - cinfo^.coef := jpeg_d_coef_controller_ptr(coef); - coef^.pub.start_input_pass := start_input_pass; - coef^.pub.start_output_pass := start_output_pass; -{$ifdef BLOCK_SMOOTHING_SUPPORTED} - coef^.coef_bits_latch := NIL; -{$endif} - - { Create the coefficient buffer. } - if (need_full_buffer) then - begin -{$ifdef D_MULTISCAN_FILES_SUPPORTED} - { Allocate a full-image virtual array for each component, } - { padded to a multiple of samp_factor DCT blocks in each direction. } - { Note we ask for a pre-zeroed array. } - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - access_rows := compptr^.v_samp_factor; -{$ifdef BLOCK_SMOOTHING_SUPPORTED} - { If block smoothing could be used, need a bigger window } - if (cinfo^.progressive_mode) then - access_rows := access_rows * 3; -{$endif} - coef^.whole_image[ci] := cinfo^.mem^.request_virt_barray - (j_common_ptr (cinfo), JPOOL_IMAGE, TRUE, - JDIMENSION (jround_up( long(compptr^.width_in_blocks), - long(compptr^.h_samp_factor) )), - JDIMENSION (jround_up( long(compptr^.height_in_blocks), - long(compptr^.v_samp_factor) )), - JDIMENSION (access_rows)); - Inc(compptr); - end; - coef^.pub.consume_data := consume_data; - coef^.pub.decompress_data := decompress_data; - coef^.pub.coef_arrays := @(coef^.whole_image); - { link to virtual arrays } -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} - end - else - begin - { We only need a single-MCU buffer. } - buffer := JBLOCK_PTR ( - cinfo^.mem^.alloc_large (j_common_ptr (cinfo), JPOOL_IMAGE, - D_MAX_BLOCKS_IN_MCU * SIZEOF(JBLOCK)) ); - for i := 0 to pred(D_MAX_BLOCKS_IN_MCU) do - begin - coef^.MCU_buffer[i] := JBLOCKROW(buffer); - Inc(buffer); - end; - coef^.pub.consume_data := dummy_consume_data; - coef^.pub.decompress_data := decompress_onepass; - coef^.pub.coef_arrays := NIL; { flag for no virtual arrays } - end; -end; - -end. +unit imjdcoefct; + +{ This file contains the coefficient buffer controller for decompression. + This controller is the top level of the JPEG decompressor proper. + The coefficient buffer lies between entropy decoding and inverse-DCT steps. + + In buffered-image mode, this controller is the interface between + input-oriented processing and output-oriented processing. + Also, the input side (only) is used when reading a file for transcoding. } + +{ Original: jdcoefct.c ; Copyright (C) 1994-1997, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjutils, + imjpeglib; + +{GLOBAL} +procedure jinit_d_coef_controller (cinfo : j_decompress_ptr; + need_full_buffer : boolean); + + +implementation + + +{ Block smoothing is only applicable for progressive JPEG, so: } +{$ifndef D_PROGRESSIVE_SUPPORTED} +{$undef BLOCK_SMOOTHING_SUPPORTED} +{$endif} + +{ Private buffer controller object } + +{$ifdef BLOCK_SMOOTHING_SUPPORTED} +const + SAVED_COEFS = 6; { we save coef_bits[0..5] } +type + Latch = array[0..SAVED_COEFS-1] of int; + Latch_ptr = ^Latch; +{$endif} + +type + my_coef_ptr = ^my_coef_controller; + my_coef_controller = record + pub : jpeg_d_coef_controller; { public fields } + + { These variables keep track of the current location of the input side. } + { cinfo^.input_iMCU_row is also used for this. } + MCU_ctr : JDIMENSION; { counts MCUs processed in current row } + MCU_vert_offset : int; { counts MCU rows within iMCU row } + MCU_rows_per_iMCU_row : int; { number of such rows needed } + + { The output side's location is represented by cinfo^.output_iMCU_row. } + + { In single-pass modes, it's sufficient to buffer just one MCU. + We allocate a workspace of D_MAX_BLOCKS_IN_MCU coefficient blocks, + and let the entropy decoder write into that workspace each time. + (On 80x86, the workspace is FAR even though it's not really very big; + this is to keep the module interfaces unchanged when a large coefficient + buffer is necessary.) + In multi-pass modes, this array points to the current MCU's blocks + within the virtual arrays; it is used only by the input side. } + + MCU_buffer : array[0..D_MAX_BLOCKS_IN_MCU-1] of JBLOCKROW; + + {$ifdef D_MULTISCAN_FILES_SUPPORTED} + { In multi-pass modes, we need a virtual block array for each component. } + whole_image : jvirt_barray_tbl; + {$endif} + + {$ifdef BLOCK_SMOOTHING_SUPPORTED} + { When doing block smoothing, we latch coefficient Al values here } + coef_bits_latch : Latch_Ptr; + {$endif} + end; + +{ Forward declarations } +{METHODDEF} +function decompress_onepass (cinfo : j_decompress_ptr; + output_buf : JSAMPIMAGE) : int; forward; +{$ifdef D_MULTISCAN_FILES_SUPPORTED} +{METHODDEF} +function decompress_data (cinfo : j_decompress_ptr; + output_buf : JSAMPIMAGE) : int; forward; +{$endif} +{$ifdef BLOCK_SMOOTHING_SUPPORTED} +{LOCAL} +function smoothing_ok (cinfo : j_decompress_ptr) : boolean; forward; + +{METHODDEF} +function decompress_smooth_data (cinfo : j_decompress_ptr; + output_buf : JSAMPIMAGE) : int; forward; +{$endif} + + +{LOCAL} +procedure start_iMCU_row (cinfo : j_decompress_ptr); +{ Reset within-iMCU-row counters for a new row (input side) } +var + coef : my_coef_ptr; +begin + coef := my_coef_ptr (cinfo^.coef); + + { In an interleaved scan, an MCU row is the same as an iMCU row. + In a noninterleaved scan, an iMCU row has v_samp_factor MCU rows. + But at the bottom of the image, process only what's left. } + + if (cinfo^.comps_in_scan > 1) then + begin + coef^.MCU_rows_per_iMCU_row := 1; + end + else + begin + if (cinfo^.input_iMCU_row < (cinfo^.total_iMCU_rows-1)) then + coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.v_samp_factor + else + coef^.MCU_rows_per_iMCU_row := cinfo^.cur_comp_info[0]^.last_row_height; + end; + + coef^.MCU_ctr := 0; + coef^.MCU_vert_offset := 0; +end; + + +{ Initialize for an input processing pass. } + +{METHODDEF} +procedure start_input_pass (cinfo : j_decompress_ptr); +begin + cinfo^.input_iMCU_row := 0; + start_iMCU_row(cinfo); +end; + + +{ Initialize for an output processing pass. } + +{METHODDEF} +procedure start_output_pass (cinfo : j_decompress_ptr); +var + coef : my_coef_ptr; +begin +{$ifdef BLOCK_SMOOTHING_SUPPORTED} + coef := my_coef_ptr (cinfo^.coef); + + { If multipass, check to see whether to use block smoothing on this pass } + if (coef^.pub.coef_arrays <> NIL) then + begin + if (cinfo^.do_block_smoothing) and smoothing_ok(cinfo) then + coef^.pub.decompress_data := decompress_smooth_data + else + coef^.pub.decompress_data := decompress_data; + end; +{$endif} + cinfo^.output_iMCU_row := 0; +end; + + +{ Decompress and return some data in the single-pass case. + Always attempts to emit one fully interleaved MCU row ("iMCU" row). + Input and output must run in lockstep since we have only a one-MCU buffer. + Return value is JPEG_ROW_COMPLETED, JPEG_SCAN_COMPLETED, or JPEG_SUSPENDED. + + NB: output_buf contains a plane for each component in image, + which we index according to the component's SOF position.} + +{METHODDEF} +function decompress_onepass (cinfo : j_decompress_ptr; + output_buf : JSAMPIMAGE) : int; +var + coef : my_coef_ptr; + MCU_col_num : JDIMENSION; { index of current MCU within row } + last_MCU_col : JDIMENSION; + last_iMCU_row : JDIMENSION; + blkn, ci, xindex, yindex, yoffset, useful_width : int; + output_ptr : JSAMPARRAY; + start_col, output_col : JDIMENSION; + compptr : jpeg_component_info_ptr; + inverse_DCT : inverse_DCT_method_ptr; +begin + coef := my_coef_ptr (cinfo^.coef); + last_MCU_col := cinfo^.MCUs_per_row - 1; + last_iMCU_row := cinfo^.total_iMCU_rows - 1; + + { Loop to process as much as one whole iMCU row } + for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do + begin + for MCU_col_num := coef^.MCU_ctr to last_MCU_col do + begin + { Try to fetch an MCU. Entropy decoder expects buffer to be zeroed. } + jzero_far( coef^.MCU_buffer[0], + size_t (cinfo^.blocks_in_MCU * SIZEOF(JBLOCK))); + if (not cinfo^.entropy^.decode_mcu (cinfo, coef^.MCU_buffer)) then + begin + { Suspension forced; update state counters and exit } + coef^.MCU_vert_offset := yoffset; + coef^.MCU_ctr := MCU_col_num; + decompress_onepass := JPEG_SUSPENDED; + exit; + end; + { Determine where data should go in output_buf and do the IDCT thing. + We skip dummy blocks at the right and bottom edges (but blkn gets + incremented past them!). Note the inner loop relies on having + allocated the MCU_buffer[] blocks sequentially. } + + blkn := 0; { index of current DCT block within MCU } + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + { Don't bother to IDCT an uninteresting component. } + if (not compptr^.component_needed) then + begin + Inc(blkn, compptr^.MCU_blocks); + continue; + end; + inverse_DCT := cinfo^.idct^.inverse_DCT[compptr^.component_index]; + if (MCU_col_num < last_MCU_col) then + useful_width := compptr^.MCU_width + else + useful_width := compptr^.last_col_width; + + output_ptr := JSAMPARRAY(@ output_buf^[compptr^.component_index]^ + [yoffset * compptr^.DCT_scaled_size]); + start_col := LongInt(MCU_col_num) * compptr^.MCU_sample_width; + for yindex := 0 to pred(compptr^.MCU_height) do + begin + if (cinfo^.input_iMCU_row < last_iMCU_row) or + (yoffset+yindex < compptr^.last_row_height) then + begin + output_col := start_col; + for xindex := 0 to pred(useful_width) do + begin + inverse_DCT (cinfo, compptr, + JCOEFPTR(coef^.MCU_buffer[blkn+xindex]), + output_ptr, output_col); + Inc(output_col, compptr^.DCT_scaled_size); + end; + end; + Inc(blkn, compptr^.MCU_width); + Inc(JSAMPROW_PTR(output_ptr), compptr^.DCT_scaled_size); + end; + end; + end; + { Completed an MCU row, but perhaps not an iMCU row } + coef^.MCU_ctr := 0; + end; + { Completed the iMCU row, advance counters for next one } + Inc(cinfo^.output_iMCU_row); + + Inc(cinfo^.input_iMCU_row); + if (cinfo^.input_iMCU_row < cinfo^.total_iMCU_rows) then + begin + start_iMCU_row(cinfo); + decompress_onepass := JPEG_ROW_COMPLETED; + exit; + end; + { Completed the scan } + cinfo^.inputctl^.finish_input_pass (cinfo); + decompress_onepass := JPEG_SCAN_COMPLETED; +end; + +{ Dummy consume-input routine for single-pass operation. } + +{METHODDEF} +function dummy_consume_data (cinfo : j_decompress_ptr) : int; +begin + dummy_consume_data := JPEG_SUSPENDED; { Always indicate nothing was done } +end; + + +{$ifdef D_MULTISCAN_FILES_SUPPORTED} + +{ Consume input data and store it in the full-image coefficient buffer. + We read as much as one fully interleaved MCU row ("iMCU" row) per call, + ie, v_samp_factor block rows for each component in the scan. + Return value is JPEG_ROW_COMPLETED, JPEG_SCAN_COMPLETED, or JPEG_SUSPENDED.} + +{METHODDEF} +function consume_data (cinfo : j_decompress_ptr) : int; +var + coef : my_coef_ptr; + MCU_col_num : JDIMENSION; { index of current MCU within row } + blkn, ci, xindex, yindex, yoffset : int; + start_col : JDIMENSION; + buffer : array[0..MAX_COMPS_IN_SCAN-1] of JBLOCKARRAY; + buffer_ptr : JBLOCKROW; + compptr : jpeg_component_info_ptr; +begin + coef := my_coef_ptr (cinfo^.coef); + + { Align the virtual buffers for the components used in this scan. } + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + buffer[ci] := cinfo^.mem^.access_virt_barray + (j_common_ptr (cinfo), coef^.whole_image[compptr^.component_index], + LongInt(cinfo^.input_iMCU_row) * compptr^.v_samp_factor, + JDIMENSION (compptr^.v_samp_factor), TRUE); + { Note: entropy decoder expects buffer to be zeroed, + but this is handled automatically by the memory manager + because we requested a pre-zeroed array. } + + end; + + { Loop to process one whole iMCU row } + for yoffset := coef^.MCU_vert_offset to pred(coef^.MCU_rows_per_iMCU_row) do + begin + for MCU_col_num := coef^.MCU_ctr to pred(cinfo^.MCUs_per_row) do + begin + { Construct list of pointers to DCT blocks belonging to this MCU } + blkn := 0; { index of current DCT block within MCU } + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + start_col := LongInt(MCU_col_num) * compptr^.MCU_width; + for yindex := 0 to pred(compptr^.MCU_height) do + begin + buffer_ptr := JBLOCKROW(@ buffer[ci]^[yindex+yoffset]^[start_col]); + for xindex := 0 to pred(compptr^.MCU_width) do + begin + coef^.MCU_buffer[blkn] := buffer_ptr; + Inc(blkn); + Inc(JBLOCK_PTR(buffer_ptr)); + end; + end; + end; + { Try to fetch the MCU. } + if (not cinfo^.entropy^.decode_mcu (cinfo, coef^.MCU_buffer)) then + begin + { Suspension forced; update state counters and exit } + coef^.MCU_vert_offset := yoffset; + coef^.MCU_ctr := MCU_col_num; + consume_data := JPEG_SUSPENDED; + exit; + end; + end; + { Completed an MCU row, but perhaps not an iMCU row } + coef^.MCU_ctr := 0; + end; + { Completed the iMCU row, advance counters for next one } + Inc(cinfo^.input_iMCU_row); + if (cinfo^.input_iMCU_row < cinfo^.total_iMCU_rows) then + begin + start_iMCU_row(cinfo); + consume_data := JPEG_ROW_COMPLETED; + exit; + end; + { Completed the scan } + cinfo^.inputctl^.finish_input_pass (cinfo); + consume_data := JPEG_SCAN_COMPLETED; +end; + + +{ Decompress and return some data in the multi-pass case. + Always attempts to emit one fully interleaved MCU row ("iMCU" row). + Return value is JPEG_ROW_COMPLETED, JPEG_SCAN_COMPLETED, or JPEG_SUSPENDED. + + NB: output_buf contains a plane for each component in image. } + +{METHODDEF} +function decompress_data (cinfo : j_decompress_ptr; + output_buf : JSAMPIMAGE) : int; +var + coef : my_coef_ptr; + last_iMCU_row : JDIMENSION; + block_num : JDIMENSION; + ci, block_row, block_rows : int; + buffer : JBLOCKARRAY; + buffer_ptr : JBLOCKROW; + output_ptr : JSAMPARRAY; + output_col : JDIMENSION; + compptr : jpeg_component_info_ptr; + inverse_DCT : inverse_DCT_method_ptr; +begin + coef := my_coef_ptr (cinfo^.coef); + last_iMCU_row := cinfo^.total_iMCU_rows - 1; + + { Force some input to be done if we are getting ahead of the input. } + while (cinfo^.input_scan_number < cinfo^.output_scan_number) or + ((cinfo^.input_scan_number = cinfo^.output_scan_number) and + (LongInt(cinfo^.input_iMCU_row) <= cinfo^.output_iMCU_row)) do + begin + if (cinfo^.inputctl^.consume_input(cinfo) = JPEG_SUSPENDED) then + begin + decompress_data := JPEG_SUSPENDED; + exit; + end; + end; + + { OK, output from the virtual arrays. } + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + { Don't bother to IDCT an uninteresting component. } + if (not compptr^.component_needed) then + continue; + { Align the virtual buffer for this component. } + buffer := cinfo^.mem^.access_virt_barray + (j_common_ptr (cinfo), coef^.whole_image[ci], + cinfo^.output_iMCU_row * compptr^.v_samp_factor, + JDIMENSION (compptr^.v_samp_factor), FALSE); + { Count non-dummy DCT block rows in this iMCU row. } + if (cinfo^.output_iMCU_row < LongInt(last_iMCU_row)) then + block_rows := compptr^.v_samp_factor + else + begin + { NB: can't use last_row_height here; it is input-side-dependent! } + block_rows := int(LongInt(compptr^.height_in_blocks) mod compptr^.v_samp_factor); + if (block_rows = 0) then + block_rows := compptr^.v_samp_factor; + end; + inverse_DCT := cinfo^.idct^.inverse_DCT[ci]; + output_ptr := output_buf^[ci]; + { Loop over all DCT blocks to be processed. } + for block_row := 0 to pred(block_rows) do + begin + buffer_ptr := buffer^[block_row]; + output_col := 0; + for block_num := 0 to pred(compptr^.width_in_blocks) do + begin + inverse_DCT (cinfo, compptr, JCOEFPTR (buffer_ptr), + output_ptr, output_col); + Inc(JBLOCK_PTR(buffer_ptr)); + Inc(output_col, compptr^.DCT_scaled_size); + end; + Inc(JSAMPROW_PTR(output_ptr), compptr^.DCT_scaled_size); + end; + Inc(compptr); + end; + + Inc(cinfo^.output_iMCU_row); + if (cinfo^.output_iMCU_row < LongInt(cinfo^.total_iMCU_rows)) then + begin + decompress_data := JPEG_ROW_COMPLETED; + exit; + end; + decompress_data := JPEG_SCAN_COMPLETED; +end; + +{$endif} { D_MULTISCAN_FILES_SUPPORTED } + + +{$ifdef BLOCK_SMOOTHING_SUPPORTED} + +{ This code applies interblock smoothing as described by section K.8 + of the JPEG standard: the first 5 AC coefficients are estimated from + the DC values of a DCT block and its 8 neighboring blocks. + We apply smoothing only for progressive JPEG decoding, and only if + the coefficients it can estimate are not yet known to full precision. } + +{ Natural-order array positions of the first 5 zigzag-order coefficients } +const + Q01_POS = 1; + Q10_POS = 8; + Q20_POS = 16; + Q11_POS = 9; + Q02_POS = 2; + +{ Determine whether block smoothing is applicable and safe. + We also latch the current states of the coef_bits[] entries for the + AC coefficients; otherwise, if the input side of the decompressor + advances into a new scan, we might think the coefficients are known + more accurately than they really are. } + +{LOCAL} +function smoothing_ok (cinfo : j_decompress_ptr) : boolean; +var + coef : my_coef_ptr; + smoothing_useful : boolean; + ci, coefi : int; + compptr : jpeg_component_info_ptr; + qtable : JQUANT_TBL_PTR; + coef_bits : coef_bits_ptr; + coef_bits_latch : Latch_Ptr; +begin + coef := my_coef_ptr (cinfo^.coef); + smoothing_useful := FALSE; + + if (not cinfo^.progressive_mode) or (cinfo^.coef_bits = NIL) then + begin + smoothing_ok := FALSE; + exit; + end; + + { Allocate latch area if not already done } + if (coef^.coef_bits_latch = NIL) then + coef^.coef_bits_latch := Latch_Ptr( + cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, + cinfo^.num_components * + (SAVED_COEFS * SIZEOF(int))) ); + coef_bits_latch := (coef^.coef_bits_latch); + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + { All components' quantization values must already be latched. } + qtable := compptr^.quant_table; + if (qtable = NIL) then + begin + smoothing_ok := FALSE; + exit; + end; + { Verify DC & first 5 AC quantizers are nonzero to avoid zero-divide. } + if (qtable^.quantval[0] = 0) or + (qtable^.quantval[Q01_POS] = 0) or + (qtable^.quantval[Q10_POS] = 0) or + (qtable^.quantval[Q20_POS] = 0) or + (qtable^.quantval[Q11_POS] = 0) or + (qtable^.quantval[Q02_POS] = 0) then + begin + smoothing_ok := FALSE; + exit; + end; + { DC values must be at least partly known for all components. } + coef_bits := @cinfo^.coef_bits^[ci]; { Nomssi } + if (coef_bits^[0] < 0) then + begin + smoothing_ok := FALSE; + exit; + end; + { Block smoothing is helpful if some AC coefficients remain inaccurate. } + for coefi := 1 to 5 do + begin + coef_bits_latch^[coefi] := coef_bits^[coefi]; + if (coef_bits^[coefi] <> 0) then + smoothing_useful := TRUE; + end; + Inc(coef_bits_latch {SAVED_COEFS}); + Inc(compptr); + end; + + smoothing_ok := smoothing_useful; +end; + + +{ Variant of decompress_data for use when doing block smoothing. } + +{METHODDEF} +function decompress_smooth_data (cinfo : j_decompress_ptr; + output_buf : JSAMPIMAGE) : int; +var + coef : my_coef_ptr; + last_iMCU_row : JDIMENSION; + block_num, last_block_column : JDIMENSION; + ci, block_row, block_rows, access_rows : int; + buffer : JBLOCKARRAY; + buffer_ptr, prev_block_row, next_block_row : JBLOCKROW; + output_ptr : JSAMPARRAY; + output_col : JDIMENSION; + compptr : jpeg_component_info_ptr; + inverse_DCT : inverse_DCT_method_ptr; + first_row, last_row : boolean; + workspace : JBLOCK; + coef_bits : Latch_Ptr; { coef_bits_ptr; } + quanttbl : JQUANT_TBL_PTR; + Q00,Q01,Q02,Q10,Q11,Q20, num : INT32; + DC1,DC2,DC3,DC4,DC5,DC6,DC7,DC8,DC9 : int; + Al, pred : int; +var + delta : JDIMENSION; +begin + coef := my_coef_ptr (cinfo^.coef); + last_iMCU_row := cinfo^.total_iMCU_rows - 1; + + { Force some input to be done if we are getting ahead of the input. } + while (cinfo^.input_scan_number <= cinfo^.output_scan_number) and + (not cinfo^.inputctl^.eoi_reached) do + begin + if (cinfo^.input_scan_number = cinfo^.output_scan_number) then + begin + { If input is working on current scan, we ordinarily want it to + have completed the current row. But if input scan is DC, + we want it to keep one row ahead so that next block row's DC + values are up to date. } + + if (cinfo^.Ss = 0) then + delta := 1 + else + delta := 0; + if (LongInt(cinfo^.input_iMCU_row) > cinfo^.output_iMCU_row+LongInt(delta)) then + break; + end; + if (cinfo^.inputctl^.consume_input(cinfo) = JPEG_SUSPENDED) then + begin + decompress_smooth_data := JPEG_SUSPENDED; + exit; + end; + end; + + { OK, output from the virtual arrays. } + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to (cinfo^.num_components-1) do + begin + { Don't bother to IDCT an uninteresting component. } + if (not compptr^.component_needed) then + continue; + { Count non-dummy DCT block rows in this iMCU row. } + if (cinfo^.output_iMCU_row < LongInt(last_iMCU_row)) then + begin + block_rows := compptr^.v_samp_factor; + access_rows := block_rows * 2; { this and next iMCU row } + last_row := FALSE; + end + else + begin + { NB: can't use last_row_height here; it is input-side-dependent! } + block_rows := int (compptr^.height_in_blocks) mod compptr^.v_samp_factor; + if (block_rows = 0) then + block_rows := compptr^.v_samp_factor; + access_rows := block_rows; { this iMCU row only } + last_row := TRUE; + end; + { Align the virtual buffer for this component. } + if (cinfo^.output_iMCU_row > 0) then + begin + Inc(access_rows, compptr^.v_samp_factor); { prior iMCU row too } + buffer := cinfo^.mem^.access_virt_barray + (j_common_ptr (cinfo), coef^.whole_image[ci], + (cinfo^.output_iMCU_row - 1) * compptr^.v_samp_factor, + JDIMENSION (access_rows), FALSE); + Inc(JBLOCKROW_PTR(buffer), compptr^.v_samp_factor); { point to current iMCU row } + first_row := FALSE; + end + else + begin + buffer := cinfo^.mem^.access_virt_barray + (j_common_ptr (cinfo), coef^.whole_image[ci], + JDIMENSION (0), JDIMENSION (access_rows), FALSE); + first_row := TRUE; + end; + { Fetch component-dependent info } + coef_bits := coef^.coef_bits_latch; + Inc(coef_bits, ci); { ci * SAVED_COEFS} + quanttbl := compptr^.quant_table; + Q00 := quanttbl^.quantval[0]; + Q01 := quanttbl^.quantval[Q01_POS]; + Q10 := quanttbl^.quantval[Q10_POS]; + Q20 := quanttbl^.quantval[Q20_POS]; + Q11 := quanttbl^.quantval[Q11_POS]; + Q02 := quanttbl^.quantval[Q02_POS]; + inverse_DCT := cinfo^.idct^.inverse_DCT[ci]; + output_ptr := output_buf^[ci]; + { Loop over all DCT blocks to be processed. } + for block_row := 0 to (block_rows-1) do + begin + buffer_ptr := buffer^[block_row]; + if (first_row) and (block_row = 0) then + prev_block_row := buffer_ptr + else + prev_block_row := buffer^[block_row-1]; + if (last_row) and (block_row = block_rows-1) then + next_block_row := buffer_ptr + else + next_block_row := buffer^[block_row+1]; + { We fetch the surrounding DC values using a sliding-register approach. + Initialize all nine here so as to do the right thing on narrow pics.} + + DC3 := int(prev_block_row^[0][0]); + DC2 := DC3; + DC1 := DC2; + DC6 := int(buffer_ptr^[0][0]); + DC5 := DC6; + DC4 := DC5; + DC9 := int(next_block_row^[0][0]); + DC8 := DC9; + DC7 := DC8 ; + output_col := 0; + last_block_column := compptr^.width_in_blocks - 1; + for block_num := 0 to last_block_column do + begin + { Fetch current DCT block into workspace so we can modify it. } + jcopy_block_row(buffer_ptr, JBLOCKROW (@workspace), JDIMENSION(1)); + { Update DC values } + if (block_num < last_block_column) then + begin + DC3 := int (prev_block_row^[1][0]); + DC6 := int (buffer_ptr^[1][0]); + DC9 := int (next_block_row^[1][0]); + end; + { Compute coefficient estimates per K.8. + An estimate is applied only if coefficient is still zero, + and is not known to be fully accurate. } + + { AC01 } + Al := coef_bits^[1]; + if (Al <> 0) and (workspace[1] = 0) then + begin + num := 36 * Q00 * (DC4 - DC6); + if (num >= 0) then + begin + pred := int (((Q01 shl 7) + num) div (Q01 shl 8)); + if (Al > 0) and (pred >= (1 shl Al)) then + pred := (1 shl Al)-1; + end + else + begin + pred := int (((Q01 shl 7) - num) div (Q01 shl 8)); + if (Al > 0) and (pred >= (1 shl Al)) then + pred := (1 shl Al)-1; + pred := -pred; + end; + workspace[1] := JCOEF (pred); + end; + { AC10 } + Al := coef_bits^[2]; + if (Al <> 0) and (workspace[8] = 0) then + begin + num := 36 * Q00 * (DC2 - DC8); + if (num >= 0) then + begin + pred := int (((Q10 shl 7) + num) div (Q10 shl 8)); + if (Al > 0) and (pred >= (1 shl Al)) then + pred := (1 shl Al)-1; + end + else + begin + pred := int (((Q10 shl 7) - num) div (Q10 shl 8)); + if (Al > 0) and (pred >= (1 shl Al)) then + pred := (1 shl Al)-1; + pred := -pred; + end; + workspace[8] := JCOEF (pred); + end; + { AC20 } + Al := coef_bits^[3]; + if (Al <> 0) and (workspace[16] = 0) then + begin + num := 9 * Q00 * (DC2 + DC8 - 2*DC5); + if (num >= 0) then + begin + pred := int (((Q20 shl 7) + num) div (Q20 shl 8)); + if (Al > 0) and (pred >= (1 shl Al)) then + pred := (1 shl Al)-1; + end + else + begin + pred := int (((Q20 shl 7) - num) div (Q20 shl 8)); + if (Al > 0) and (pred >= (1 shl Al)) then + pred := (1 shl Al)-1; + pred := -pred; + end; + workspace[16] := JCOEF (pred); + end; + { AC11 } + Al := coef_bits^[4]; + if (Al <> 0) and (workspace[9] = 0) then + begin + num := 5 * Q00 * (DC1 - DC3 - DC7 + DC9); + if (num >= 0) then + begin + pred := int (((Q11 shl 7) + num) div (Q11 shl 8)); + if (Al > 0) and (pred >= (1 shl Al)) then + pred := (1 shl Al)-1; + end + else + begin + pred := int (((Q11 shl 7) - num) div (Q11 shl 8)); + if (Al > 0) and (pred >= (1 shl Al)) then + pred := (1 shl Al)-1; + pred := -pred; + end; + workspace[9] := JCOEF (pred); + end; + { AC02 } + Al := coef_bits^[5]; + if (Al <> 0) and (workspace[2] = 0) then + begin + num := 9 * Q00 * (DC4 + DC6 - 2*DC5); + if (num >= 0) then + begin + pred := int (((Q02 shl 7) + num) div (Q02 shl 8)); + if (Al > 0) and (pred >= (1 shl Al)) then + pred := (1 shl Al)-1; + end + else + begin + pred := int (((Q02 shl 7) - num) div (Q02 shl 8)); + if (Al > 0) and (pred >= (1 shl Al)) then + pred := (1 shl Al)-1; + pred := -pred; + end; + workspace[2] := JCOEF (pred); + end; + { OK, do the IDCT } + inverse_DCT (cinfo, compptr, JCOEFPTR (@workspace), + output_ptr, output_col); + { Advance for next column } + DC1 := DC2; DC2 := DC3; + DC4 := DC5; DC5 := DC6; + DC7 := DC8; DC8 := DC9; + Inc(JBLOCK_PTR(buffer_ptr)); + Inc(JBLOCK_PTR(prev_block_row)); + Inc(JBLOCK_PTR(next_block_row)); + Inc(output_col, compptr^.DCT_scaled_size); + end; + Inc(JSAMPROW_PTR(output_ptr), compptr^.DCT_scaled_size); + end; + Inc(compptr); + end; + + Inc(cinfo^.output_iMCU_row); + if (cinfo^.output_iMCU_row < LongInt(cinfo^.total_iMCU_rows)) then + begin + decompress_smooth_data := JPEG_ROW_COMPLETED; + exit; + end; + decompress_smooth_data := JPEG_SCAN_COMPLETED; +end; + +{$endif} { BLOCK_SMOOTHING_SUPPORTED } + + +{ Initialize coefficient buffer controller. } + +{GLOBAL} +procedure jinit_d_coef_controller (cinfo : j_decompress_ptr; + need_full_buffer : boolean); +var + coef : my_coef_ptr; +{$ifdef D_MULTISCAN_FILES_SUPPORTED} +var + ci, access_rows : int; + compptr : jpeg_component_info_ptr; +{$endif} +var + buffer : JBLOCK_PTR; + i : int; +begin + coef := my_coef_ptr( + cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, + SIZEOF(my_coef_controller)) ); + cinfo^.coef := jpeg_d_coef_controller_ptr(coef); + coef^.pub.start_input_pass := start_input_pass; + coef^.pub.start_output_pass := start_output_pass; +{$ifdef BLOCK_SMOOTHING_SUPPORTED} + coef^.coef_bits_latch := NIL; +{$endif} + + { Create the coefficient buffer. } + if (need_full_buffer) then + begin +{$ifdef D_MULTISCAN_FILES_SUPPORTED} + { Allocate a full-image virtual array for each component, } + { padded to a multiple of samp_factor DCT blocks in each direction. } + { Note we ask for a pre-zeroed array. } + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + access_rows := compptr^.v_samp_factor; +{$ifdef BLOCK_SMOOTHING_SUPPORTED} + { If block smoothing could be used, need a bigger window } + if (cinfo^.progressive_mode) then + access_rows := access_rows * 3; +{$endif} + coef^.whole_image[ci] := cinfo^.mem^.request_virt_barray + (j_common_ptr (cinfo), JPOOL_IMAGE, TRUE, + JDIMENSION (jround_up( long(compptr^.width_in_blocks), + long(compptr^.h_samp_factor) )), + JDIMENSION (jround_up( long(compptr^.height_in_blocks), + long(compptr^.v_samp_factor) )), + JDIMENSION (access_rows)); + Inc(compptr); + end; + coef^.pub.consume_data := consume_data; + coef^.pub.decompress_data := decompress_data; + coef^.pub.coef_arrays := @(coef^.whole_image); + { link to virtual arrays } +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} + end + else + begin + { We only need a single-MCU buffer. } + buffer := JBLOCK_PTR ( + cinfo^.mem^.alloc_large (j_common_ptr (cinfo), JPOOL_IMAGE, + D_MAX_BLOCKS_IN_MCU * SIZEOF(JBLOCK)) ); + for i := 0 to pred(D_MAX_BLOCKS_IN_MCU) do + begin + coef^.MCU_buffer[i] := JBLOCKROW(buffer); + Inc(buffer); + end; + coef^.pub.consume_data := dummy_consume_data; + coef^.pub.decompress_data := decompress_onepass; + coef^.pub.coef_arrays := NIL; { flag for no virtual arrays } + end; +end; + +end. diff --git a/Imaging/JpegLib/imjdcolor.pas b/Imaging/JpegLib/imjdcolor.pas index 64c5f41..2eec9d3 100644 --- a/Imaging/JpegLib/imjdcolor.pas +++ b/Imaging/JpegLib/imjdcolor.pas @@ -1,501 +1,501 @@ -unit imjdcolor; - -{ This file contains output colorspace conversion routines. } - -{ Original: jdcolor.c ; Copyright (C) 1991-1997, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjutils, - imjdeferr, - imjerror, - imjpeglib; - -{ Module initialization routine for output colorspace conversion. } - -{GLOBAL} -procedure jinit_color_deconverter (cinfo : j_decompress_ptr); - -implementation - -{ Private subobject } -type - int_Color_Table = array[0..MAXJSAMPLE+1-1] of int; - int_table_ptr = ^int_Color_Table; - INT32_Color_Table = array[0..MAXJSAMPLE+1-1] of INT32; - INT32_table_ptr = ^INT32_Color_Table; -type - my_cconvert_ptr = ^my_color_deconverter; - my_color_deconverter = record - pub : jpeg_color_deconverter; { public fields } - - { Private state for YCC^.RGB conversion } - Cr_r_tab : int_table_ptr; { => table for Cr to R conversion } - Cb_b_tab : int_table_ptr; { => table for Cb to B conversion } - Cr_g_tab : INT32_table_ptr; { => table for Cr to G conversion } - Cb_g_tab : INT32_table_ptr; { => table for Cb to G conversion } - end; - - - - -{*************** YCbCr ^. RGB conversion: most common case *************} - -{ YCbCr is defined per CCIR 601-1, except that Cb and Cr are - normalized to the range 0..MAXJSAMPLE rather than -0.5 .. 0.5. - The conversion equations to be implemented are therefore - R = Y + 1.40200 * Cr - G = Y - 0.34414 * Cb - 0.71414 * Cr - B = Y + 1.77200 * Cb - where Cb and Cr represent the incoming values less CENTERJSAMPLE. - (These numbers are derived from TIFF 6.0 section 21, dated 3-June-92.) - - To avoid floating-point arithmetic, we represent the fractional constants - as integers scaled up by 2^16 (about 4 digits precision); we have to divide - the products by 2^16, with appropriate rounding, to get the correct answer. - Notice that Y, being an integral input, does not contribute any fraction - so it need not participate in the rounding. - - For even more speed, we avoid doing any multiplications in the inner loop - by precalculating the constants times Cb and Cr for all possible values. - For 8-bit JSAMPLEs this is very reasonable (only 256 entries per table); - for 12-bit samples it is still acceptable. It's not very reasonable for - 16-bit samples, but if you want lossless storage you shouldn't be changing - colorspace anyway. - The Cr=>R and Cb=>B values can be rounded to integers in advance; the - values for the G calculation are left scaled up, since we must add them - together before rounding. } - -const - SCALEBITS = 16; { speediest right-shift on some machines } - ONE_HALF = (INT32(1) shl (SCALEBITS-1)); - - -{ Initialize tables for YCC->RGB colorspace conversion. } - -{LOCAL} -procedure build_ycc_rgb_table (cinfo : j_decompress_ptr); -const - FIX_1_40200 = INT32(Round( 1.40200 * (1 shl SCALEBITS))); - FIX_1_77200 = INT32(Round( 1.77200 * (1 shl SCALEBITS))); - FIX_0_71414 = INT32(Round( 0.71414 * (1 shl SCALEBITS))); - FIX_0_34414 = INT32(Round( 0.34414 * (1 shl SCALEBITS))); - -var - cconvert : my_cconvert_ptr; - i : int; - x : INT32; -var - shift_temp : INT32; -begin - cconvert := my_cconvert_ptr (cinfo^.cconvert); - - - cconvert^.Cr_r_tab := int_table_ptr( - cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE, - (MAXJSAMPLE+1) * SIZEOF(int)) ); - cconvert^.Cb_b_tab := int_table_ptr ( - cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE, - (MAXJSAMPLE+1) * SIZEOF(int)) ); - cconvert^.Cr_g_tab := INT32_table_ptr ( - cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE, - (MAXJSAMPLE+1) * SIZEOF(INT32)) ); - cconvert^.Cb_g_tab := INT32_table_ptr ( - cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE, - (MAXJSAMPLE+1) * SIZEOF(INT32)) ); - - - x := -CENTERJSAMPLE; - for i := 0 to MAXJSAMPLE do - begin - { i is the actual input pixel value, in the range 0..MAXJSAMPLE } - { The Cb or Cr value we are thinking of is x := i - CENTERJSAMPLE } - { Cr=>R value is nearest int to 1.40200 * x } - - shift_temp := FIX_1_40200 * x + ONE_HALF; - if shift_temp < 0 then { SHIFT arithmetic RIGHT } - cconvert^.Cr_r_tab^[i] := int((shift_temp shr SCALEBITS) - or ( (not INT32(0)) shl (32-SCALEBITS))) - else - cconvert^.Cr_r_tab^[i] := int(shift_temp shr SCALEBITS); - - { Cb=>B value is nearest int to 1.77200 * x } - shift_temp := FIX_1_77200 * x + ONE_HALF; - if shift_temp < 0 then { SHIFT arithmetic RIGHT } - cconvert^.Cb_b_tab^[i] := int((shift_temp shr SCALEBITS) - or ( (not INT32(0)) shl (32-SCALEBITS))) - else - cconvert^.Cb_b_tab^[i] := int(shift_temp shr SCALEBITS); - - { Cr=>G value is scaled-up -0.71414 * x } - cconvert^.Cr_g_tab^[i] := (- FIX_0_71414 ) * x; - { Cb=>G value is scaled-up -0.34414 * x } - { We also add in ONE_HALF so that need not do it in inner loop } - cconvert^.Cb_g_tab^[i] := (- FIX_0_34414 ) * x + ONE_HALF; - Inc(x); - end; -end; - - -{ Convert some rows of samples to the output colorspace. - - Note that we change from noninterleaved, one-plane-per-component format - to interleaved-pixel format. The output buffer is therefore three times - as wide as the input buffer. - A starting row offset is provided only for the input buffer. The caller - can easily adjust the passed output_buf value to accommodate any row - offset required on that side. } - -{METHODDEF} -procedure ycc_rgb_convert (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - input_row : JDIMENSION; - output_buf : JSAMPARRAY; - num_rows : int); -var - cconvert : my_cconvert_ptr; - {register} y, cb, cr : int; - {register} outptr : JSAMPROW; - {register} inptr0, inptr1, inptr2 : JSAMPROW; - {register} col : JDIMENSION; - num_cols : JDIMENSION; - { copy these pointers into registers if possible } - {register} range_limit : range_limit_table_ptr; - {register} Crrtab : int_table_ptr; - {register} Cbbtab : int_table_ptr; - {register} Crgtab : INT32_table_ptr; - {register} Cbgtab : INT32_table_ptr; -var - shift_temp : INT32; -begin - cconvert := my_cconvert_ptr (cinfo^.cconvert); - num_cols := cinfo^.output_width; - range_limit := cinfo^.sample_range_limit; - Crrtab := cconvert^.Cr_r_tab; - Cbbtab := cconvert^.Cb_b_tab; - Crgtab := cconvert^.Cr_g_tab; - Cbgtab := cconvert^.Cb_g_tab; - - while (num_rows > 0) do - begin - Dec(num_rows); - inptr0 := input_buf^[0]^[input_row]; - inptr1 := input_buf^[1]^[input_row]; - inptr2 := input_buf^[2]^[input_row]; - Inc(input_row); - outptr := output_buf^[0]; - Inc(JSAMPROW_PTR(output_buf)); - for col := 0 to pred(num_cols) do - begin - y := GETJSAMPLE(inptr0^[col]); - cb := GETJSAMPLE(inptr1^[col]); - cr := GETJSAMPLE(inptr2^[col]); - { Range-limiting is essential due to noise introduced by DCT losses. } - outptr^[RGB_RED] := range_limit^[y + Crrtab^[cr]]; - shift_temp := Cbgtab^[cb] + Crgtab^[cr]; - if shift_temp < 0 then { SHIFT arithmetic RIGHT } - outptr^[RGB_GREEN] := range_limit^[y + int((shift_temp shr SCALEBITS) - or ( (not INT32(0)) shl (32-SCALEBITS)))] - else - outptr^[RGB_GREEN] := range_limit^[y + int(shift_temp shr SCALEBITS)]; - - outptr^[RGB_BLUE] := range_limit^[y + Cbbtab^[cb]]; - Inc(JSAMPLE_PTR(outptr), RGB_PIXELSIZE); - end; - end; -end; - - -{*************** Cases other than YCbCr -> RGB *************} - - -{ Color conversion for no colorspace change: just copy the data, - converting from separate-planes to interleaved representation. } - -{METHODDEF} -procedure null_convert (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - input_row : JDIMENSION; - output_buf : JSAMPARRAY; - num_rows : int); -var - {register} inptr, - outptr : JSAMPLE_PTR; - {register} count : JDIMENSION; - {register} num_components : int; - num_cols : JDIMENSION; - ci : int; -begin - num_components := cinfo^.num_components; - num_cols := cinfo^.output_width; - - while (num_rows > 0) do - begin - Dec(num_rows); - for ci := 0 to pred(num_components) do - begin - inptr := JSAMPLE_PTR(input_buf^[ci]^[input_row]); - outptr := JSAMPLE_PTR(@(output_buf^[0]^[ci])); - - for count := pred(num_cols) downto 0 do - begin - outptr^ := inptr^; { needn't bother with GETJSAMPLE() here } - Inc(inptr); - Inc(outptr, num_components); - end; - end; - Inc(input_row); - Inc(JSAMPROW_PTR(output_buf)); - end; -end; - - -{ Color conversion for grayscale: just copy the data. - This also works for YCbCr -> grayscale conversion, in which - we just copy the Y (luminance) component and ignore chrominance. } - -{METHODDEF} -procedure grayscale_convert (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - input_row : JDIMENSION; - output_buf : JSAMPARRAY; - num_rows : int); -begin - jcopy_sample_rows(input_buf^[0], int(input_row), output_buf, 0, - num_rows, cinfo^.output_width); -end; - -{ Convert grayscale to RGB: just duplicate the graylevel three times. - This is provided to support applications that don't want to cope - with grayscale as a separate case. } - -{METHODDEF} -procedure gray_rgb_convert (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - input_row : JDIMENSION; - output_buf : JSAMPARRAY; - num_rows : int); -var - {register} inptr, outptr : JSAMPLE_PTR; - {register} col : JDIMENSION; - num_cols : JDIMENSION; -begin - num_cols := cinfo^.output_width; - while (num_rows > 0) do - begin - inptr := JSAMPLE_PTR(input_buf^[0]^[input_row]); - Inc(input_row); - outptr := JSAMPLE_PTR(@output_buf^[0]); - Inc(JSAMPROW_PTR(output_buf)); - for col := 0 to pred(num_cols) do - begin - { We can dispense with GETJSAMPLE() here } - JSAMPROW(outptr)^[RGB_RED] := inptr^; - JSAMPROW(outptr)^[RGB_GREEN] := inptr^; - JSAMPROW(outptr)^[RGB_BLUE] := inptr^; - Inc(inptr); - Inc(outptr, RGB_PIXELSIZE); - end; - Dec(num_rows); - end; -end; - - -{ Adobe-style YCCK -> CMYK conversion. - We convert YCbCr to R=1-C, G=1-M, and B=1-Y using the same - conversion as above, while passing K (black) unchanged. - We assume build_ycc_rgb_table has been called. } - -{METHODDEF} -procedure ycck_cmyk_convert (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - input_row : JDIMENSION; - output_buf : JSAMPARRAY; - num_rows : int); -var - cconvert : my_cconvert_ptr; - {register} y, cb, cr : int; - {register} outptr : JSAMPROW; - {register} inptr0, inptr1, inptr2, inptr3 : JSAMPROW; - {register} col : JDIMENSION; - num_cols : JDIMENSION; - { copy these pointers into registers if possible } - {register} range_limit : range_limit_table_ptr; - {register} Crrtab : int_table_ptr; - {register} Cbbtab : int_table_ptr; - {register} Crgtab : INT32_table_ptr; - {register} Cbgtab : INT32_table_ptr; -var - shift_temp : INT32; -begin - cconvert := my_cconvert_ptr (cinfo^.cconvert); - num_cols := cinfo^.output_width; - { copy these pointers into registers if possible } - range_limit := cinfo^.sample_range_limit; - Crrtab := cconvert^.Cr_r_tab; - Cbbtab := cconvert^.Cb_b_tab; - Crgtab := cconvert^.Cr_g_tab; - Cbgtab := cconvert^.Cb_g_tab; - - while (num_rows > 0) do - begin - Dec(num_rows); - inptr0 := input_buf^[0]^[input_row]; - inptr1 := input_buf^[1]^[input_row]; - inptr2 := input_buf^[2]^[input_row]; - inptr3 := input_buf^[3]^[input_row]; - Inc(input_row); - outptr := output_buf^[0]; - Inc(JSAMPROW_PTR(output_buf)); - for col := 0 to pred(num_cols) do - begin - y := GETJSAMPLE(inptr0^[col]); - cb := GETJSAMPLE(inptr1^[col]); - cr := GETJSAMPLE(inptr2^[col]); - { Range-limiting is essential due to noise introduced by DCT losses. } - outptr^[0] := range_limit^[MAXJSAMPLE - (y + Crrtab^[cr])]; { red } - shift_temp := Cbgtab^[cb] + Crgtab^[cr]; - if shift_temp < 0 then - outptr^[1] := range_limit^[MAXJSAMPLE - (y + int( - (shift_temp shr SCALEBITS) or ((not INT32(0)) shl (32-SCALEBITS)) - ) )] - else - outptr^[1] := range_limit^[MAXJSAMPLE - { green } - (y + int(shift_temp shr SCALEBITS) )]; - outptr^[2] := range_limit^[MAXJSAMPLE - (y + Cbbtab^[cb])]; { blue } - { K passes through unchanged } - outptr^[3] := inptr3^[col]; { don't need GETJSAMPLE here } - Inc(JSAMPLE_PTR(outptr), 4); - end; - end; -end; - - -{ Empty method for start_pass. } - -{METHODDEF} -procedure start_pass_dcolor (cinfo : j_decompress_ptr); -begin - { no work needed } -end; - - -{ Module initialization routine for output colorspace conversion. } - -{GLOBAL} -procedure jinit_color_deconverter (cinfo : j_decompress_ptr); -var - cconvert : my_cconvert_ptr; - ci : int; -begin - cconvert := my_cconvert_ptr ( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_color_deconverter)) ); - cinfo^.cconvert := jpeg_color_deconverter_ptr (cconvert); - cconvert^.pub.start_pass := start_pass_dcolor; - - { Make sure num_components agrees with jpeg_color_space } - case (cinfo^.jpeg_color_space) of - JCS_GRAYSCALE: - if (cinfo^.num_components <> 1) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); - - JCS_RGB, - JCS_YCbCr: - if (cinfo^.num_components <> 3) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); - - JCS_CMYK, - JCS_YCCK: - if (cinfo^.num_components <> 4) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); - - else { JCS_UNKNOWN can be anything } - if (cinfo^.num_components < 1) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); - end; - - { Set out_color_components and conversion method based on requested space. - Also clear the component_needed flags for any unused components, - so that earlier pipeline stages can avoid useless computation. } - - case (cinfo^.out_color_space) of - JCS_GRAYSCALE: - begin - cinfo^.out_color_components := 1; - if (cinfo^.jpeg_color_space = JCS_GRAYSCALE) - or (cinfo^.jpeg_color_space = JCS_YCbCr) then - begin - cconvert^.pub.color_convert := grayscale_convert; - { For color -> grayscale conversion, only the - Y (0) component is needed } - for ci := 1 to pred(cinfo^.num_components) do - cinfo^.comp_info^[ci].component_needed := FALSE; - end - else - ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); - end; - - JCS_RGB: - begin - cinfo^.out_color_components := RGB_PIXELSIZE; - if (cinfo^.jpeg_color_space = JCS_YCbCr) then - begin - cconvert^.pub.color_convert := ycc_rgb_convert; - build_ycc_rgb_table(cinfo); - end - else - if (cinfo^.jpeg_color_space = JCS_GRAYSCALE) then - begin - cconvert^.pub.color_convert := gray_rgb_convert; - end - else - if (cinfo^.jpeg_color_space = JCS_RGB) and (RGB_PIXELSIZE = 3) then - begin - cconvert^.pub.color_convert := null_convert; - end - else - ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); - end; - - JCS_CMYK: - begin - cinfo^.out_color_components := 4; - if (cinfo^.jpeg_color_space = JCS_YCCK) then - begin - cconvert^.pub.color_convert := ycck_cmyk_convert; - build_ycc_rgb_table(cinfo); - end - else - if (cinfo^.jpeg_color_space = JCS_CMYK) then - begin - cconvert^.pub.color_convert := null_convert; - end - else - ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); - end; - - else - begin { Permit null conversion to same output space } - if (cinfo^.out_color_space = cinfo^.jpeg_color_space) then - begin - cinfo^.out_color_components := cinfo^.num_components; - cconvert^.pub.color_convert := null_convert; - end - else { unsupported non-null conversion } - ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); - end; - end; - - if (cinfo^.quantize_colors) then - cinfo^.output_components := 1 { single colormapped output component } - else - cinfo^.output_components := cinfo^.out_color_components; -end; - -end. +unit imjdcolor; + +{ This file contains output colorspace conversion routines. } + +{ Original: jdcolor.c ; Copyright (C) 1991-1997, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjutils, + imjdeferr, + imjerror, + imjpeglib; + +{ Module initialization routine for output colorspace conversion. } + +{GLOBAL} +procedure jinit_color_deconverter (cinfo : j_decompress_ptr); + +implementation + +{ Private subobject } +type + int_Color_Table = array[0..MAXJSAMPLE+1-1] of int; + int_table_ptr = ^int_Color_Table; + INT32_Color_Table = array[0..MAXJSAMPLE+1-1] of INT32; + INT32_table_ptr = ^INT32_Color_Table; +type + my_cconvert_ptr = ^my_color_deconverter; + my_color_deconverter = record + pub : jpeg_color_deconverter; { public fields } + + { Private state for YCC^.RGB conversion } + Cr_r_tab : int_table_ptr; { => table for Cr to R conversion } + Cb_b_tab : int_table_ptr; { => table for Cb to B conversion } + Cr_g_tab : INT32_table_ptr; { => table for Cr to G conversion } + Cb_g_tab : INT32_table_ptr; { => table for Cb to G conversion } + end; + + + + +{*************** YCbCr ^. RGB conversion: most common case *************} + +{ YCbCr is defined per CCIR 601-1, except that Cb and Cr are + normalized to the range 0..MAXJSAMPLE rather than -0.5 .. 0.5. + The conversion equations to be implemented are therefore + R = Y + 1.40200 * Cr + G = Y - 0.34414 * Cb - 0.71414 * Cr + B = Y + 1.77200 * Cb + where Cb and Cr represent the incoming values less CENTERJSAMPLE. + (These numbers are derived from TIFF 6.0 section 21, dated 3-June-92.) + + To avoid floating-point arithmetic, we represent the fractional constants + as integers scaled up by 2^16 (about 4 digits precision); we have to divide + the products by 2^16, with appropriate rounding, to get the correct answer. + Notice that Y, being an integral input, does not contribute any fraction + so it need not participate in the rounding. + + For even more speed, we avoid doing any multiplications in the inner loop + by precalculating the constants times Cb and Cr for all possible values. + For 8-bit JSAMPLEs this is very reasonable (only 256 entries per table); + for 12-bit samples it is still acceptable. It's not very reasonable for + 16-bit samples, but if you want lossless storage you shouldn't be changing + colorspace anyway. + The Cr=>R and Cb=>B values can be rounded to integers in advance; the + values for the G calculation are left scaled up, since we must add them + together before rounding. } + +const + SCALEBITS = 16; { speediest right-shift on some machines } + ONE_HALF = (INT32(1) shl (SCALEBITS-1)); + + +{ Initialize tables for YCC->RGB colorspace conversion. } + +{LOCAL} +procedure build_ycc_rgb_table (cinfo : j_decompress_ptr); +const + FIX_1_40200 = INT32(Round( 1.40200 * (1 shl SCALEBITS))); + FIX_1_77200 = INT32(Round( 1.77200 * (1 shl SCALEBITS))); + FIX_0_71414 = INT32(Round( 0.71414 * (1 shl SCALEBITS))); + FIX_0_34414 = INT32(Round( 0.34414 * (1 shl SCALEBITS))); + +var + cconvert : my_cconvert_ptr; + i : int; + x : INT32; +var + shift_temp : INT32; +begin + cconvert := my_cconvert_ptr (cinfo^.cconvert); + + + cconvert^.Cr_r_tab := int_table_ptr( + cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE, + (MAXJSAMPLE+1) * SIZEOF(int)) ); + cconvert^.Cb_b_tab := int_table_ptr ( + cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE, + (MAXJSAMPLE+1) * SIZEOF(int)) ); + cconvert^.Cr_g_tab := INT32_table_ptr ( + cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE, + (MAXJSAMPLE+1) * SIZEOF(INT32)) ); + cconvert^.Cb_g_tab := INT32_table_ptr ( + cinfo^.mem^.alloc_small ( j_common_ptr(cinfo), JPOOL_IMAGE, + (MAXJSAMPLE+1) * SIZEOF(INT32)) ); + + + x := -CENTERJSAMPLE; + for i := 0 to MAXJSAMPLE do + begin + { i is the actual input pixel value, in the range 0..MAXJSAMPLE } + { The Cb or Cr value we are thinking of is x := i - CENTERJSAMPLE } + { Cr=>R value is nearest int to 1.40200 * x } + + shift_temp := FIX_1_40200 * x + ONE_HALF; + if shift_temp < 0 then { SHIFT arithmetic RIGHT } + cconvert^.Cr_r_tab^[i] := int((shift_temp shr SCALEBITS) + or ( (not INT32(0)) shl (32-SCALEBITS))) + else + cconvert^.Cr_r_tab^[i] := int(shift_temp shr SCALEBITS); + + { Cb=>B value is nearest int to 1.77200 * x } + shift_temp := FIX_1_77200 * x + ONE_HALF; + if shift_temp < 0 then { SHIFT arithmetic RIGHT } + cconvert^.Cb_b_tab^[i] := int((shift_temp shr SCALEBITS) + or ( (not INT32(0)) shl (32-SCALEBITS))) + else + cconvert^.Cb_b_tab^[i] := int(shift_temp shr SCALEBITS); + + { Cr=>G value is scaled-up -0.71414 * x } + cconvert^.Cr_g_tab^[i] := (- FIX_0_71414 ) * x; + { Cb=>G value is scaled-up -0.34414 * x } + { We also add in ONE_HALF so that need not do it in inner loop } + cconvert^.Cb_g_tab^[i] := (- FIX_0_34414 ) * x + ONE_HALF; + Inc(x); + end; +end; + + +{ Convert some rows of samples to the output colorspace. + + Note that we change from noninterleaved, one-plane-per-component format + to interleaved-pixel format. The output buffer is therefore three times + as wide as the input buffer. + A starting row offset is provided only for the input buffer. The caller + can easily adjust the passed output_buf value to accommodate any row + offset required on that side. } + +{METHODDEF} +procedure ycc_rgb_convert (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + input_row : JDIMENSION; + output_buf : JSAMPARRAY; + num_rows : int); +var + cconvert : my_cconvert_ptr; + {register} y, cb, cr : int; + {register} outptr : JSAMPROW; + {register} inptr0, inptr1, inptr2 : JSAMPROW; + {register} col : JDIMENSION; + num_cols : JDIMENSION; + { copy these pointers into registers if possible } + {register} range_limit : range_limit_table_ptr; + {register} Crrtab : int_table_ptr; + {register} Cbbtab : int_table_ptr; + {register} Crgtab : INT32_table_ptr; + {register} Cbgtab : INT32_table_ptr; +var + shift_temp : INT32; +begin + cconvert := my_cconvert_ptr (cinfo^.cconvert); + num_cols := cinfo^.output_width; + range_limit := cinfo^.sample_range_limit; + Crrtab := cconvert^.Cr_r_tab; + Cbbtab := cconvert^.Cb_b_tab; + Crgtab := cconvert^.Cr_g_tab; + Cbgtab := cconvert^.Cb_g_tab; + + while (num_rows > 0) do + begin + Dec(num_rows); + inptr0 := input_buf^[0]^[input_row]; + inptr1 := input_buf^[1]^[input_row]; + inptr2 := input_buf^[2]^[input_row]; + Inc(input_row); + outptr := output_buf^[0]; + Inc(JSAMPROW_PTR(output_buf)); + for col := 0 to pred(num_cols) do + begin + y := GETJSAMPLE(inptr0^[col]); + cb := GETJSAMPLE(inptr1^[col]); + cr := GETJSAMPLE(inptr2^[col]); + { Range-limiting is essential due to noise introduced by DCT losses. } + outptr^[RGB_RED] := range_limit^[y + Crrtab^[cr]]; + shift_temp := Cbgtab^[cb] + Crgtab^[cr]; + if shift_temp < 0 then { SHIFT arithmetic RIGHT } + outptr^[RGB_GREEN] := range_limit^[y + int((shift_temp shr SCALEBITS) + or ( (not INT32(0)) shl (32-SCALEBITS)))] + else + outptr^[RGB_GREEN] := range_limit^[y + int(shift_temp shr SCALEBITS)]; + + outptr^[RGB_BLUE] := range_limit^[y + Cbbtab^[cb]]; + Inc(JSAMPLE_PTR(outptr), RGB_PIXELSIZE); + end; + end; +end; + + +{*************** Cases other than YCbCr -> RGB *************} + + +{ Color conversion for no colorspace change: just copy the data, + converting from separate-planes to interleaved representation. } + +{METHODDEF} +procedure null_convert (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + input_row : JDIMENSION; + output_buf : JSAMPARRAY; + num_rows : int); +var + {register} inptr, + outptr : JSAMPLE_PTR; + {register} count : JDIMENSION; + {register} num_components : int; + num_cols : JDIMENSION; + ci : int; +begin + num_components := cinfo^.num_components; + num_cols := cinfo^.output_width; + + while (num_rows > 0) do + begin + Dec(num_rows); + for ci := 0 to pred(num_components) do + begin + inptr := JSAMPLE_PTR(input_buf^[ci]^[input_row]); + outptr := JSAMPLE_PTR(@(output_buf^[0]^[ci])); + + for count := pred(num_cols) downto 0 do + begin + outptr^ := inptr^; { needn't bother with GETJSAMPLE() here } + Inc(inptr); + Inc(outptr, num_components); + end; + end; + Inc(input_row); + Inc(JSAMPROW_PTR(output_buf)); + end; +end; + + +{ Color conversion for grayscale: just copy the data. + This also works for YCbCr -> grayscale conversion, in which + we just copy the Y (luminance) component and ignore chrominance. } + +{METHODDEF} +procedure grayscale_convert (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + input_row : JDIMENSION; + output_buf : JSAMPARRAY; + num_rows : int); +begin + jcopy_sample_rows(input_buf^[0], int(input_row), output_buf, 0, + num_rows, cinfo^.output_width); +end; + +{ Convert grayscale to RGB: just duplicate the graylevel three times. + This is provided to support applications that don't want to cope + with grayscale as a separate case. } + +{METHODDEF} +procedure gray_rgb_convert (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + input_row : JDIMENSION; + output_buf : JSAMPARRAY; + num_rows : int); +var + {register} inptr, outptr : JSAMPLE_PTR; + {register} col : JDIMENSION; + num_cols : JDIMENSION; +begin + num_cols := cinfo^.output_width; + while (num_rows > 0) do + begin + inptr := JSAMPLE_PTR(input_buf^[0]^[input_row]); + Inc(input_row); + outptr := JSAMPLE_PTR(@output_buf^[0]); + Inc(JSAMPROW_PTR(output_buf)); + for col := 0 to pred(num_cols) do + begin + { We can dispense with GETJSAMPLE() here } + JSAMPROW(outptr)^[RGB_RED] := inptr^; + JSAMPROW(outptr)^[RGB_GREEN] := inptr^; + JSAMPROW(outptr)^[RGB_BLUE] := inptr^; + Inc(inptr); + Inc(outptr, RGB_PIXELSIZE); + end; + Dec(num_rows); + end; +end; + + +{ Adobe-style YCCK -> CMYK conversion. + We convert YCbCr to R=1-C, G=1-M, and B=1-Y using the same + conversion as above, while passing K (black) unchanged. + We assume build_ycc_rgb_table has been called. } + +{METHODDEF} +procedure ycck_cmyk_convert (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + input_row : JDIMENSION; + output_buf : JSAMPARRAY; + num_rows : int); +var + cconvert : my_cconvert_ptr; + {register} y, cb, cr : int; + {register} outptr : JSAMPROW; + {register} inptr0, inptr1, inptr2, inptr3 : JSAMPROW; + {register} col : JDIMENSION; + num_cols : JDIMENSION; + { copy these pointers into registers if possible } + {register} range_limit : range_limit_table_ptr; + {register} Crrtab : int_table_ptr; + {register} Cbbtab : int_table_ptr; + {register} Crgtab : INT32_table_ptr; + {register} Cbgtab : INT32_table_ptr; +var + shift_temp : INT32; +begin + cconvert := my_cconvert_ptr (cinfo^.cconvert); + num_cols := cinfo^.output_width; + { copy these pointers into registers if possible } + range_limit := cinfo^.sample_range_limit; + Crrtab := cconvert^.Cr_r_tab; + Cbbtab := cconvert^.Cb_b_tab; + Crgtab := cconvert^.Cr_g_tab; + Cbgtab := cconvert^.Cb_g_tab; + + while (num_rows > 0) do + begin + Dec(num_rows); + inptr0 := input_buf^[0]^[input_row]; + inptr1 := input_buf^[1]^[input_row]; + inptr2 := input_buf^[2]^[input_row]; + inptr3 := input_buf^[3]^[input_row]; + Inc(input_row); + outptr := output_buf^[0]; + Inc(JSAMPROW_PTR(output_buf)); + for col := 0 to pred(num_cols) do + begin + y := GETJSAMPLE(inptr0^[col]); + cb := GETJSAMPLE(inptr1^[col]); + cr := GETJSAMPLE(inptr2^[col]); + { Range-limiting is essential due to noise introduced by DCT losses. } + outptr^[0] := range_limit^[MAXJSAMPLE - (y + Crrtab^[cr])]; { red } + shift_temp := Cbgtab^[cb] + Crgtab^[cr]; + if shift_temp < 0 then + outptr^[1] := range_limit^[MAXJSAMPLE - (y + int( + (shift_temp shr SCALEBITS) or ((not INT32(0)) shl (32-SCALEBITS)) + ) )] + else + outptr^[1] := range_limit^[MAXJSAMPLE - { green } + (y + int(shift_temp shr SCALEBITS) )]; + outptr^[2] := range_limit^[MAXJSAMPLE - (y + Cbbtab^[cb])]; { blue } + { K passes through unchanged } + outptr^[3] := inptr3^[col]; { don't need GETJSAMPLE here } + Inc(JSAMPLE_PTR(outptr), 4); + end; + end; +end; + + +{ Empty method for start_pass. } + +{METHODDEF} +procedure start_pass_dcolor (cinfo : j_decompress_ptr); +begin + { no work needed } +end; + + +{ Module initialization routine for output colorspace conversion. } + +{GLOBAL} +procedure jinit_color_deconverter (cinfo : j_decompress_ptr); +var + cconvert : my_cconvert_ptr; + ci : int; +begin + cconvert := my_cconvert_ptr ( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_color_deconverter)) ); + cinfo^.cconvert := jpeg_color_deconverter_ptr (cconvert); + cconvert^.pub.start_pass := start_pass_dcolor; + + { Make sure num_components agrees with jpeg_color_space } + case (cinfo^.jpeg_color_space) of + JCS_GRAYSCALE: + if (cinfo^.num_components <> 1) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); + + JCS_RGB, + JCS_YCbCr: + if (cinfo^.num_components <> 3) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); + + JCS_CMYK, + JCS_YCCK: + if (cinfo^.num_components <> 4) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); + + else { JCS_UNKNOWN can be anything } + if (cinfo^.num_components < 1) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE); + end; + + { Set out_color_components and conversion method based on requested space. + Also clear the component_needed flags for any unused components, + so that earlier pipeline stages can avoid useless computation. } + + case (cinfo^.out_color_space) of + JCS_GRAYSCALE: + begin + cinfo^.out_color_components := 1; + if (cinfo^.jpeg_color_space = JCS_GRAYSCALE) + or (cinfo^.jpeg_color_space = JCS_YCbCr) then + begin + cconvert^.pub.color_convert := grayscale_convert; + { For color -> grayscale conversion, only the + Y (0) component is needed } + for ci := 1 to pred(cinfo^.num_components) do + cinfo^.comp_info^[ci].component_needed := FALSE; + end + else + ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); + end; + + JCS_RGB: + begin + cinfo^.out_color_components := RGB_PIXELSIZE; + if (cinfo^.jpeg_color_space = JCS_YCbCr) then + begin + cconvert^.pub.color_convert := ycc_rgb_convert; + build_ycc_rgb_table(cinfo); + end + else + if (cinfo^.jpeg_color_space = JCS_GRAYSCALE) then + begin + cconvert^.pub.color_convert := gray_rgb_convert; + end + else + if (cinfo^.jpeg_color_space = JCS_RGB) and (RGB_PIXELSIZE = 3) then + begin + cconvert^.pub.color_convert := null_convert; + end + else + ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); + end; + + JCS_CMYK: + begin + cinfo^.out_color_components := 4; + if (cinfo^.jpeg_color_space = JCS_YCCK) then + begin + cconvert^.pub.color_convert := ycck_cmyk_convert; + build_ycc_rgb_table(cinfo); + end + else + if (cinfo^.jpeg_color_space = JCS_CMYK) then + begin + cconvert^.pub.color_convert := null_convert; + end + else + ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); + end; + + else + begin { Permit null conversion to same output space } + if (cinfo^.out_color_space = cinfo^.jpeg_color_space) then + begin + cinfo^.out_color_components := cinfo^.num_components; + cconvert^.pub.color_convert := null_convert; + end + else { unsupported non-null conversion } + ERREXIT(j_common_ptr(cinfo), JERR_CONVERSION_NOTIMPL); + end; + end; + + if (cinfo^.quantize_colors) then + cinfo^.output_components := 1 { single colormapped output component } + else + cinfo^.output_components := cinfo^.out_color_components; +end; + +end. diff --git a/Imaging/JpegLib/imjdct.pas b/Imaging/JpegLib/imjdct.pas index 30d3356..63e83c1 100644 --- a/Imaging/JpegLib/imjdct.pas +++ b/Imaging/JpegLib/imjdct.pas @@ -1,109 +1,109 @@ -unit imjdct; - -{ Orignal: jdct.h; Copyright (C) 1994-1996, Thomas G. Lane. } - -{ This include file contains common declarations for the forward and - inverse DCT modules. These declarations are private to the DCT managers - (jcdctmgr.c, jddctmgr.c) and the individual DCT algorithms. - The individual DCT algorithms are kept in separate files to ease - machine-dependent tuning (e.g., assembly coding). } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg; - - -{ A forward DCT routine is given a pointer to a work area of type DCTELEM[]; - the DCT is to be performed in-place in that buffer. Type DCTELEM is int - for 8-bit samples, INT32 for 12-bit samples. (NOTE: Floating-point DCT - implementations use an array of type FAST_FLOAT, instead.) - The DCT inputs are expected to be signed (range +-CENTERJSAMPLE). - The DCT outputs are returned scaled up by a factor of 8; they therefore - have a range of +-8K for 8-bit data, +-128K for 12-bit data. This - convention improves accuracy in integer implementations and saves some - work in floating-point ones. - Quantization of the output coefficients is done by jcdctmgr.c. } - - -{$ifdef BITS_IN_JSAMPLE_IS_8} -type - DCTELEM = int; { 16 or 32 bits is fine } -{$else} -type { must have 32 bits } - DCTELEM = INT32; -{$endif} -type - jTDctElem = 0..(MaxInt div SizeOf(DCTELEM))-1; - DCTELEM_FIELD = array[jTDctElem] of DCTELEM; - DCTELEM_FIELD_PTR = ^DCTELEM_FIELD; - DCTELEMPTR = ^DCTELEM; - -type - forward_DCT_method_ptr = procedure(var data : array of DCTELEM); - float_DCT_method_ptr = procedure(var data : array of FAST_FLOAT); - - -{ An inverse DCT routine is given a pointer to the input JBLOCK and a pointer - to an output sample array. The routine must dequantize the input data as - well as perform the IDCT; for dequantization, it uses the multiplier table - pointed to by compptr->dct_table. The output data is to be placed into the - sample array starting at a specified column. (Any row offset needed will - be applied to the array pointer before it is passed to the IDCT code.) - Note that the number of samples emitted by the IDCT routine is - DCT_scaled_size * DCT_scaled_size. } - - -{ typedef inverse_DCT_method_ptr is declared in jpegint.h } - - -{ Each IDCT routine has its own ideas about the best dct_table element type. } - - -type - ISLOW_MULT_TYPE = MULTIPLIER; { short or int, whichever is faster } - -{$ifdef BITS_IN_JSAMPLE_IS_8} -type - IFAST_MULT_TYPE = MULTIPLIER; { 16 bits is OK, use short if faster } -const - IFAST_SCALE_BITS = 2; { fractional bits in scale factors } -{$else} -type - IFAST_MULT_TYPE = INT32; { need 32 bits for scaled quantizers } -const - IFAST_SCALE_BITS = 13; { fractional bits in scale factors } -{$endif} -type - FLOAT_MULT_TYPE = FAST_FLOAT; { preferred floating type } - -const - RANGE_MASK = (MAXJSAMPLE * 4 + 3); { 2 bits wider than legal samples } - -type - jTMultType = 0..(MaxInt div SizeOf(ISLOW_MULT_TYPE))-1; - ISLOW_MULT_TYPE_FIELD = array[jTMultType] of ISLOW_MULT_TYPE; - ISLOW_MULT_TYPE_FIELD_PTR = ^ISLOW_MULT_TYPE_FIELD; - ISLOW_MULT_TYPE_PTR = ^ISLOW_MULT_TYPE; - - jTFloatType = 0..(MaxInt div SizeOf(FLOAT_MULT_TYPE))-1; - FLOAT_MULT_TYPE_FIELD = array[jTFloatType] of FLOAT_MULT_TYPE; - FLOAT_MULT_TYPE_FIELD_PTR = ^FLOAT_MULT_TYPE_FIELD; - FLOAT_MULT_TYPE_PTR = ^FLOAT_MULT_TYPE; - - jTFastType = 0..(MaxInt div SizeOf(IFAST_MULT_TYPE))-1; - IFAST_MULT_TYPE_FIELD = array[jTFastType] of IFAST_MULT_TYPE; - IFAST_MULT_TYPE_FIELD_PTR = ^IFAST_MULT_TYPE_FIELD; - IFAST_MULT_TYPE_PTR = ^IFAST_MULT_TYPE; - -type - jTFastFloat = 0..(MaxInt div SizeOf(FAST_FLOAT))-1; - FAST_FLOAT_FIELD = array[jTFastFloat] of FAST_FLOAT; - FAST_FLOAT_FIELD_PTR = ^FAST_FLOAT_FIELD; - FAST_FLOAT_PTR = ^FAST_FLOAT; - -implementation - -end. +unit imjdct; + +{ Orignal: jdct.h; Copyright (C) 1994-1996, Thomas G. Lane. } + +{ This include file contains common declarations for the forward and + inverse DCT modules. These declarations are private to the DCT managers + (jcdctmgr.c, jddctmgr.c) and the individual DCT algorithms. + The individual DCT algorithms are kept in separate files to ease + machine-dependent tuning (e.g., assembly coding). } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg; + + +{ A forward DCT routine is given a pointer to a work area of type DCTELEM[]; + the DCT is to be performed in-place in that buffer. Type DCTELEM is int + for 8-bit samples, INT32 for 12-bit samples. (NOTE: Floating-point DCT + implementations use an array of type FAST_FLOAT, instead.) + The DCT inputs are expected to be signed (range +-CENTERJSAMPLE). + The DCT outputs are returned scaled up by a factor of 8; they therefore + have a range of +-8K for 8-bit data, +-128K for 12-bit data. This + convention improves accuracy in integer implementations and saves some + work in floating-point ones. + Quantization of the output coefficients is done by jcdctmgr.c. } + + +{$ifdef BITS_IN_JSAMPLE_IS_8} +type + DCTELEM = int; { 16 or 32 bits is fine } +{$else} +type { must have 32 bits } + DCTELEM = INT32; +{$endif} +type + jTDctElem = 0..(MaxInt div SizeOf(DCTELEM))-1; + DCTELEM_FIELD = array[jTDctElem] of DCTELEM; + DCTELEM_FIELD_PTR = ^DCTELEM_FIELD; + DCTELEMPTR = ^DCTELEM; + +type + forward_DCT_method_ptr = procedure(var data : array of DCTELEM); + float_DCT_method_ptr = procedure(var data : array of FAST_FLOAT); + + +{ An inverse DCT routine is given a pointer to the input JBLOCK and a pointer + to an output sample array. The routine must dequantize the input data as + well as perform the IDCT; for dequantization, it uses the multiplier table + pointed to by compptr->dct_table. The output data is to be placed into the + sample array starting at a specified column. (Any row offset needed will + be applied to the array pointer before it is passed to the IDCT code.) + Note that the number of samples emitted by the IDCT routine is + DCT_scaled_size * DCT_scaled_size. } + + +{ typedef inverse_DCT_method_ptr is declared in jpegint.h } + + +{ Each IDCT routine has its own ideas about the best dct_table element type. } + + +type + ISLOW_MULT_TYPE = MULTIPLIER; { short or int, whichever is faster } + +{$ifdef BITS_IN_JSAMPLE_IS_8} +type + IFAST_MULT_TYPE = MULTIPLIER; { 16 bits is OK, use short if faster } +const + IFAST_SCALE_BITS = 2; { fractional bits in scale factors } +{$else} +type + IFAST_MULT_TYPE = INT32; { need 32 bits for scaled quantizers } +const + IFAST_SCALE_BITS = 13; { fractional bits in scale factors } +{$endif} +type + FLOAT_MULT_TYPE = FAST_FLOAT; { preferred floating type } + +const + RANGE_MASK = (MAXJSAMPLE * 4 + 3); { 2 bits wider than legal samples } + +type + jTMultType = 0..(MaxInt div SizeOf(ISLOW_MULT_TYPE))-1; + ISLOW_MULT_TYPE_FIELD = array[jTMultType] of ISLOW_MULT_TYPE; + ISLOW_MULT_TYPE_FIELD_PTR = ^ISLOW_MULT_TYPE_FIELD; + ISLOW_MULT_TYPE_PTR = ^ISLOW_MULT_TYPE; + + jTFloatType = 0..(MaxInt div SizeOf(FLOAT_MULT_TYPE))-1; + FLOAT_MULT_TYPE_FIELD = array[jTFloatType] of FLOAT_MULT_TYPE; + FLOAT_MULT_TYPE_FIELD_PTR = ^FLOAT_MULT_TYPE_FIELD; + FLOAT_MULT_TYPE_PTR = ^FLOAT_MULT_TYPE; + + jTFastType = 0..(MaxInt div SizeOf(IFAST_MULT_TYPE))-1; + IFAST_MULT_TYPE_FIELD = array[jTFastType] of IFAST_MULT_TYPE; + IFAST_MULT_TYPE_FIELD_PTR = ^IFAST_MULT_TYPE_FIELD; + IFAST_MULT_TYPE_PTR = ^IFAST_MULT_TYPE; + +type + jTFastFloat = 0..(MaxInt div SizeOf(FAST_FLOAT))-1; + FAST_FLOAT_FIELD = array[jTFastFloat] of FAST_FLOAT; + FAST_FLOAT_FIELD_PTR = ^FAST_FLOAT_FIELD; + FAST_FLOAT_PTR = ^FAST_FLOAT; + +implementation + +end. diff --git a/Imaging/JpegLib/imjddctmgr.pas b/Imaging/JpegLib/imjddctmgr.pas index 5e62b3a..b7d9b6a 100644 --- a/Imaging/JpegLib/imjddctmgr.pas +++ b/Imaging/JpegLib/imjddctmgr.pas @@ -1,330 +1,328 @@ -unit imjddctmgr; - -{ Original : jddctmgr.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - -{ This file contains the inverse-DCT management logic. - This code selects a particular IDCT implementation to be used, - and it performs related housekeeping chores. No code in this file - is executed per IDCT step, only during output pass setup. - - Note that the IDCT routines are responsible for performing coefficient - dequantization as well as the IDCT proper. This module sets up the - dequantization multiplier table needed by the IDCT routine. } - -interface - -{$I imjconfig.inc} - -{$N+} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjpeglib, - imjdct, { Private declarations for DCT subsystem } - imjidctfst, - {$IFDEF BASM} - imjidctasm, - {$ELSE} - imjidctint, - {$ENDIF} - imjidctflt, - imjidctred; - - - -{ Initialize IDCT manager. } - -{GLOBAL} -procedure jinit_inverse_dct (cinfo : j_decompress_ptr); - - -implementation - -{ The decompressor input side (jdinput.c) saves away the appropriate - quantization table for each component at the start of the first scan - involving that component. (This is necessary in order to correctly - decode files that reuse Q-table slots.) - When we are ready to make an output pass, the saved Q-table is converted - to a multiplier table that will actually be used by the IDCT routine. - The multiplier table contents are IDCT-method-dependent. To support - application changes in IDCT method between scans, we can remake the - multiplier tables if necessary. - In buffered-image mode, the first output pass may occur before any data - has been seen for some components, and thus before their Q-tables have - been saved away. To handle this case, multiplier tables are preset - to zeroes; the result of the IDCT will be a neutral gray level. } - - -{ Private subobject for this module } - -type - my_idct_ptr = ^my_idct_controller; - my_idct_controller = record - pub : jpeg_inverse_dct; { public fields } - - { This array contains the IDCT method code that each multiplier table - is currently set up for, or -1 if it's not yet set up. - The actual multiplier tables are pointed to by dct_table in the - per-component comp_info structures. } - - cur_method : array[0..MAX_COMPONENTS-1] of int; - end; {my_idct_controller;} - - -{ Allocated multiplier tables: big enough for any supported variant } - -type - multiplier_table = record - case byte of - 0:(islow_array : array[0..DCTSIZE2-1] of ISLOW_MULT_TYPE); - {$ifdef DCT_IFAST_SUPPORTED} - 1:(ifast_array : array[0..DCTSIZE2-1] of IFAST_MULT_TYPE); - {$endif} - {$ifdef DCT_FLOAT_SUPPORTED} - 2:(float_array : array[0..DCTSIZE2-1] of FLOAT_MULT_TYPE); - {$endif} - end; - - -{ The current scaled-IDCT routines require ISLOW-style multiplier tables, - so be sure to compile that code if either ISLOW or SCALING is requested. } - -{$ifdef DCT_ISLOW_SUPPORTED} - {$define PROVIDE_ISLOW_TABLES} -{$else} - {$ifdef IDCT_SCALING_SUPPORTED} - {$define PROVIDE_ISLOW_TABLES} - {$endif} -{$endif} - - -{ Prepare for an output pass. - Here we select the proper IDCT routine for each component and build - a matching multiplier table. } - -{METHODDEF} -procedure start_pass (cinfo : j_decompress_ptr); -var - idct : my_idct_ptr; - ci, i : int; - compptr : jpeg_component_info_ptr; - method : J_DCT_METHOD; - method_ptr : inverse_DCT_method_ptr; - qtbl : JQUANT_TBL_PTR; -{$ifdef PROVIDE_ISLOW_TABLES} -var - ismtbl : ISLOW_MULT_TYPE_FIELD_PTR; -{$endif} -{$ifdef DCT_IFAST_SUPPORTED} -const - CONST_BITS = 14; -const - aanscales : array[0..DCTSIZE2-1] of INT16 = - ({ precomputed values scaled up by 14 bits } - 16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520, - 22725, 31521, 29692, 26722, 22725, 17855, 12299, 6270, - 21407, 29692, 27969, 25172, 21407, 16819, 11585, 5906, - 19266, 26722, 25172, 22654, 19266, 15137, 10426, 5315, - 16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520, - 12873, 17855, 16819, 15137, 12873, 10114, 6967, 3552, - 8867, 12299, 11585, 10426, 8867, 6967, 4799, 2446, - 4520, 6270, 5906, 5315, 4520, 3552, 2446, 1247); -var - ifmtbl : IFAST_MULT_TYPE_FIELD_PTR; - {SHIFT_TEMPS} - - { Descale and correctly round an INT32 value that's scaled by N bits. - We assume RIGHT_SHIFT rounds towards minus infinity, so adding - the fudge factor is correct for either sign of X. } - - function DESCALE(x : INT32; n : int) : INT32; - var - shift_temp : INT32; - begin - {$ifdef RIGHT_SHIFT_IS_UNSIGNED} - shift_temp := x + (INT32(1) shl (n-1)); - if shift_temp < 0 then - Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) - else - Descale := (shift_temp shr n); - {$else} - Descale := (x + (INT32(1) shl (n-1)) shr n; - {$endif} - end; - -{$endif} -{$ifdef DCT_FLOAT_SUPPORTED} -const - aanscalefactor : array[0..DCTSIZE-1] of double = - (1.0, 1.387039845, 1.306562965, 1.175875602, - 1.0, 0.785694958, 0.541196100, 0.275899379); -var - fmtbl : FLOAT_MULT_TYPE_FIELD_PTR; - row, col : int; -{$endif} -begin - idct := my_idct_ptr (cinfo^.idct); - method := J_DCT_METHOD(0); - method_ptr := NIL; - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - - for ci := 0 to pred(cinfo^.num_components) do - begin - { Select the proper IDCT routine for this component's scaling } - case (compptr^.DCT_scaled_size) of -{$ifdef IDCT_SCALING_SUPPORTED} - 1:begin - method_ptr := jpeg_idct_1x1; - method := JDCT_ISLOW; { jidctred uses islow-style table } - end; - 2:begin - method_ptr := jpeg_idct_2x2; - method := JDCT_ISLOW; { jidctred uses islow-style table } - end; - 4:begin - method_ptr := jpeg_idct_4x4; - method := JDCT_ISLOW; { jidctred uses islow-style table } - end; -{$endif} - DCTSIZE: - case (cinfo^.dct_method) of -{$ifdef DCT_ISLOW_SUPPORTED} - JDCT_ISLOW: - begin - method_ptr := @jpeg_idct_islow; - method := JDCT_ISLOW; - end; -{$endif} -{$ifdef DCT_IFAST_SUPPORTED} - JDCT_IFAST: - begin - method_ptr := @jpeg_idct_ifast; - method := JDCT_IFAST; - end; -{$endif} -{$ifdef DCT_FLOAT_SUPPORTED} - JDCT_FLOAT: - begin - method_ptr := @jpeg_idct_float; - method := JDCT_FLOAT; - end; -{$endif} - else - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); - end; - else - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_DCTSIZE, compptr^.DCT_scaled_size); - end; - idct^.pub.inverse_DCT[ci] := method_ptr; - { Create multiplier table from quant table. - However, we can skip this if the component is uninteresting - or if we already built the table. Also, if no quant table - has yet been saved for the component, we leave the - multiplier table all-zero; we'll be reading zeroes from the - coefficient controller's buffer anyway. } - - if (not compptr^.component_needed) or (idct^.cur_method[ci] = int(method)) then - continue; - qtbl := compptr^.quant_table; - if (qtbl = NIL) then { happens if no data yet for component } - continue; - idct^.cur_method[ci] := int(method); - case (method) of -{$ifdef PROVIDE_ISLOW_TABLES} - JDCT_ISLOW: - begin - { For LL&M IDCT method, multipliers are equal to raw quantization - coefficients, but are stored as ints to ensure access efficiency. } - - ismtbl := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); - for i := 0 to pred(DCTSIZE2) do - begin - ismtbl^[i] := ISLOW_MULT_TYPE (qtbl^.quantval[i]); - end; - end; -{$endif} -{$ifdef DCT_IFAST_SUPPORTED} - JDCT_IFAST: - begin - { For AA&N IDCT method, multipliers are equal to quantization - coefficients scaled by scalefactor[row]*scalefactor[col], where - scalefactor[0] := 1 - scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 - For integer operation, the multiplier table is to be scaled by - IFAST_SCALE_BITS. } - - ifmtbl := IFAST_MULT_TYPE_FIELD_PTR (compptr^.dct_table); - - for i := 0 to pred(DCTSIZE2) do - begin - ifmtbl^[i] := IFAST_MULT_TYPE( - DESCALE( INT32 (qtbl^.quantval[i]) * INT32 (aanscales[i]), - CONST_BITS-IFAST_SCALE_BITS) ); - end; - end; -{$endif} -{$ifdef DCT_FLOAT_SUPPORTED} - JDCT_FLOAT: - begin - { For float AA&N IDCT method, multipliers are equal to quantization - coefficients scaled by scalefactor[row]*scalefactor[col], where - scalefactor[0] := 1 - scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 } - - fmtbl := FLOAT_MULT_TYPE_FIELD_PTR(compptr^.dct_table); - - i := 0; - for row := 0 to pred(DCTSIZE) do - begin - for col := 0 to pred(DCTSIZE) do - begin - fmtbl^[i] := {FLOAT_MULT_TYPE} ( - {double} qtbl^.quantval[i] * - aanscalefactor[row] * aanscalefactor[col] ); - Inc(i); - end; - end; - end; -{$endif} - else - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); - break; - end; - Inc(compptr); - end; -end; - - -{ Initialize IDCT manager. } - -{GLOBAL} -procedure jinit_inverse_dct (cinfo : j_decompress_ptr); -var - idct : my_idct_ptr; - ci : int; - compptr : jpeg_component_info_ptr; -begin - idct := my_idct_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_idct_controller)) ); - cinfo^.idct := jpeg_inverse_dct_ptr (idct); - idct^.pub.start_pass := start_pass; - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - { Allocate and pre-zero a multiplier table for each component } - compptr^.dct_table := - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(multiplier_table)); - MEMZERO(compptr^.dct_table, SIZEOF(multiplier_table)); - { Mark multiplier table not yet set up for any method } - idct^.cur_method[ci] := -1; - Inc(compptr); - end; -end; - -end. +unit imjddctmgr; + +{ Original : jddctmgr.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + +{ This file contains the inverse-DCT management logic. + This code selects a particular IDCT implementation to be used, + and it performs related housekeeping chores. No code in this file + is executed per IDCT step, only during output pass setup. + + Note that the IDCT routines are responsible for performing coefficient + dequantization as well as the IDCT proper. This module sets up the + dequantization multiplier table needed by the IDCT routine. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjpeglib, + imjdct, { Private declarations for DCT subsystem } + imjidctfst, + {$IFDEF BASM} + imjidctasm, + {$ELSE} + imjidctint, + {$ENDIF} + imjidctflt, + imjidctred; + + + +{ Initialize IDCT manager. } + +{GLOBAL} +procedure jinit_inverse_dct (cinfo : j_decompress_ptr); + + +implementation + +{ The decompressor input side (jdinput.c) saves away the appropriate + quantization table for each component at the start of the first scan + involving that component. (This is necessary in order to correctly + decode files that reuse Q-table slots.) + When we are ready to make an output pass, the saved Q-table is converted + to a multiplier table that will actually be used by the IDCT routine. + The multiplier table contents are IDCT-method-dependent. To support + application changes in IDCT method between scans, we can remake the + multiplier tables if necessary. + In buffered-image mode, the first output pass may occur before any data + has been seen for some components, and thus before their Q-tables have + been saved away. To handle this case, multiplier tables are preset + to zeroes; the result of the IDCT will be a neutral gray level. } + + +{ Private subobject for this module } + +type + my_idct_ptr = ^my_idct_controller; + my_idct_controller = record + pub : jpeg_inverse_dct; { public fields } + + { This array contains the IDCT method code that each multiplier table + is currently set up for, or -1 if it's not yet set up. + The actual multiplier tables are pointed to by dct_table in the + per-component comp_info structures. } + + cur_method : array[0..MAX_COMPONENTS-1] of int; + end; {my_idct_controller;} + + +{ Allocated multiplier tables: big enough for any supported variant } + +type + multiplier_table = record + case byte of + 0:(islow_array : array[0..DCTSIZE2-1] of ISLOW_MULT_TYPE); + {$ifdef DCT_IFAST_SUPPORTED} + 1:(ifast_array : array[0..DCTSIZE2-1] of IFAST_MULT_TYPE); + {$endif} + {$ifdef DCT_FLOAT_SUPPORTED} + 2:(float_array : array[0..DCTSIZE2-1] of FLOAT_MULT_TYPE); + {$endif} + end; + + +{ The current scaled-IDCT routines require ISLOW-style multiplier tables, + so be sure to compile that code if either ISLOW or SCALING is requested. } + +{$ifdef DCT_ISLOW_SUPPORTED} + {$define PROVIDE_ISLOW_TABLES} +{$else} + {$ifdef IDCT_SCALING_SUPPORTED} + {$define PROVIDE_ISLOW_TABLES} + {$endif} +{$endif} + + +{ Prepare for an output pass. + Here we select the proper IDCT routine for each component and build + a matching multiplier table. } + +{METHODDEF} +procedure start_pass (cinfo : j_decompress_ptr); +var + idct : my_idct_ptr; + ci, i : int; + compptr : jpeg_component_info_ptr; + method : J_DCT_METHOD; + method_ptr : inverse_DCT_method_ptr; + qtbl : JQUANT_TBL_PTR; +{$ifdef PROVIDE_ISLOW_TABLES} +var + ismtbl : ISLOW_MULT_TYPE_FIELD_PTR; +{$endif} +{$ifdef DCT_IFAST_SUPPORTED} +const + CONST_BITS = 14; +const + aanscales : array[0..DCTSIZE2-1] of INT16 = + ({ precomputed values scaled up by 14 bits } + 16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520, + 22725, 31521, 29692, 26722, 22725, 17855, 12299, 6270, + 21407, 29692, 27969, 25172, 21407, 16819, 11585, 5906, + 19266, 26722, 25172, 22654, 19266, 15137, 10426, 5315, + 16384, 22725, 21407, 19266, 16384, 12873, 8867, 4520, + 12873, 17855, 16819, 15137, 12873, 10114, 6967, 3552, + 8867, 12299, 11585, 10426, 8867, 6967, 4799, 2446, + 4520, 6270, 5906, 5315, 4520, 3552, 2446, 1247); +var + ifmtbl : IFAST_MULT_TYPE_FIELD_PTR; + {SHIFT_TEMPS} + + { Descale and correctly round an INT32 value that's scaled by N bits. + We assume RIGHT_SHIFT rounds towards minus infinity, so adding + the fudge factor is correct for either sign of X. } + + function DESCALE(x : INT32; n : int) : INT32; + var + shift_temp : INT32; + begin + {$ifdef RIGHT_SHIFT_IS_UNSIGNED} + shift_temp := x + (INT32(1) shl (n-1)); + if shift_temp < 0 then + Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) + else + Descale := (shift_temp shr n); + {$else} + Descale := (x + (INT32(1) shl (n-1)) shr n; + {$endif} + end; + +{$endif} +{$ifdef DCT_FLOAT_SUPPORTED} +const + aanscalefactor : array[0..DCTSIZE-1] of double = + (1.0, 1.387039845, 1.306562965, 1.175875602, + 1.0, 0.785694958, 0.541196100, 0.275899379); +var + fmtbl : FLOAT_MULT_TYPE_FIELD_PTR; + row, col : int; +{$endif} +begin + idct := my_idct_ptr (cinfo^.idct); + method := J_DCT_METHOD(0); + method_ptr := NIL; + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + + for ci := 0 to pred(cinfo^.num_components) do + begin + { Select the proper IDCT routine for this component's scaling } + case (compptr^.DCT_scaled_size) of +{$ifdef IDCT_SCALING_SUPPORTED} + 1:begin + method_ptr := jpeg_idct_1x1; + method := JDCT_ISLOW; { jidctred uses islow-style table } + end; + 2:begin + method_ptr := jpeg_idct_2x2; + method := JDCT_ISLOW; { jidctred uses islow-style table } + end; + 4:begin + method_ptr := jpeg_idct_4x4; + method := JDCT_ISLOW; { jidctred uses islow-style table } + end; +{$endif} + DCTSIZE: + case (cinfo^.dct_method) of +{$ifdef DCT_ISLOW_SUPPORTED} + JDCT_ISLOW: + begin + method_ptr := @jpeg_idct_islow; + method := JDCT_ISLOW; + end; +{$endif} +{$ifdef DCT_IFAST_SUPPORTED} + JDCT_IFAST: + begin + method_ptr := @jpeg_idct_ifast; + method := JDCT_IFAST; + end; +{$endif} +{$ifdef DCT_FLOAT_SUPPORTED} + JDCT_FLOAT: + begin + method_ptr := @jpeg_idct_float; + method := JDCT_FLOAT; + end; +{$endif} + else + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); + end; + else + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_DCTSIZE, compptr^.DCT_scaled_size); + end; + idct^.pub.inverse_DCT[ci] := method_ptr; + { Create multiplier table from quant table. + However, we can skip this if the component is uninteresting + or if we already built the table. Also, if no quant table + has yet been saved for the component, we leave the + multiplier table all-zero; we'll be reading zeroes from the + coefficient controller's buffer anyway. } + + if (not compptr^.component_needed) or (idct^.cur_method[ci] = int(method)) then + continue; + qtbl := compptr^.quant_table; + if (qtbl = NIL) then { happens if no data yet for component } + continue; + idct^.cur_method[ci] := int(method); + case (method) of +{$ifdef PROVIDE_ISLOW_TABLES} + JDCT_ISLOW: + begin + { For LL&M IDCT method, multipliers are equal to raw quantization + coefficients, but are stored as ints to ensure access efficiency. } + + ismtbl := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); + for i := 0 to pred(DCTSIZE2) do + begin + ismtbl^[i] := ISLOW_MULT_TYPE (qtbl^.quantval[i]); + end; + end; +{$endif} +{$ifdef DCT_IFAST_SUPPORTED} + JDCT_IFAST: + begin + { For AA&N IDCT method, multipliers are equal to quantization + coefficients scaled by scalefactor[row]*scalefactor[col], where + scalefactor[0] := 1 + scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 + For integer operation, the multiplier table is to be scaled by + IFAST_SCALE_BITS. } + + ifmtbl := IFAST_MULT_TYPE_FIELD_PTR (compptr^.dct_table); + + for i := 0 to pred(DCTSIZE2) do + begin + ifmtbl^[i] := IFAST_MULT_TYPE( + DESCALE( INT32 (qtbl^.quantval[i]) * INT32 (aanscales[i]), + CONST_BITS-IFAST_SCALE_BITS) ); + end; + end; +{$endif} +{$ifdef DCT_FLOAT_SUPPORTED} + JDCT_FLOAT: + begin + { For float AA&N IDCT method, multipliers are equal to quantization + coefficients scaled by scalefactor[row]*scalefactor[col], where + scalefactor[0] := 1 + scalefactor[k] := cos(k*PI/16) * sqrt(2) for k=1..7 } + + fmtbl := FLOAT_MULT_TYPE_FIELD_PTR(compptr^.dct_table); + + i := 0; + for row := 0 to pred(DCTSIZE) do + begin + for col := 0 to pred(DCTSIZE) do + begin + fmtbl^[i] := {FLOAT_MULT_TYPE} ( + {double} qtbl^.quantval[i] * + aanscalefactor[row] * aanscalefactor[col] ); + Inc(i); + end; + end; + end; +{$endif} + else + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); + break; + end; + Inc(compptr); + end; +end; + + +{ Initialize IDCT manager. } + +{GLOBAL} +procedure jinit_inverse_dct (cinfo : j_decompress_ptr); +var + idct : my_idct_ptr; + ci : int; + compptr : jpeg_component_info_ptr; +begin + idct := my_idct_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_idct_controller)) ); + cinfo^.idct := jpeg_inverse_dct_ptr (idct); + idct^.pub.start_pass := start_pass; + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + { Allocate and pre-zero a multiplier table for each component } + compptr^.dct_table := + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(multiplier_table)); + MEMZERO(compptr^.dct_table, SIZEOF(multiplier_table)); + { Mark multiplier table not yet set up for any method } + idct^.cur_method[ci] := -1; + Inc(compptr); + end; +end; + +end. diff --git a/Imaging/JpegLib/imjdeferr.pas b/Imaging/JpegLib/imjdeferr.pas index eeaf6f6..3c960e0 100644 --- a/Imaging/JpegLib/imjdeferr.pas +++ b/Imaging/JpegLib/imjdeferr.pas @@ -1,497 +1,497 @@ -unit imjdeferr; - -{ This file defines the error and message codes for the cjpeg/djpeg - applications. These strings are not needed as part of the JPEG library - proper. - Edit this file to add new codes, or to translate the message strings to - some other language. } - -{ Original cderror.h ; Copyright (C) 1994, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -{ To define the enum list of message codes, include this file without - defining macro JMESSAGE. To create a message string table, include it - again with a suitable JMESSAGE definition (see jerror.c for an example). } - - -{ Original: jversion.h ; Copyright (C) 1991-1996, Thomas G. Lane. } -{ This file contains software version identification. } - -const - JVERSION = '6a 7-Feb-96'; - - JCOPYRIGHT = 'Copyright (C) 1996, Thomas G. Lane'; - - JNOTICE = 'Pascal Translation, Copyright (C) 1996, Jacques Nomssi Nzali'; - -{ Create the message string table. - We do this from the master message list in jerror.h by re-reading - jerror.h with a suitable definition for macro JMESSAGE. - The message table is made an external symbol just in case any applications - want to refer to it directly. } - -type - J_MESSAGE_CODE =( - JMSG_NOMESSAGE, - JERR_ARITH_NOTIMPL, - JERR_BAD_ALIGN_TYPE, - JERR_BAD_ALLOC_CHUNK, - JERR_BAD_BUFFER_MODE, - JERR_BAD_COMPONENT_ID, - JERR_BAD_DCT_COEF, - JERR_BAD_DCTSIZE, - JERR_BAD_HUFF_TABLE, - JERR_BAD_IN_COLORSPACE, - JERR_BAD_J_COLORSPACE, - JERR_BAD_LENGTH, - JERR_BAD_LIB_VERSION, - JERR_BAD_MCU_SIZE, - JERR_BAD_POOL_ID, - JERR_BAD_PRECISION, - JERR_BAD_PROGRESSION, - JERR_BAD_PROG_SCRIPT, - JERR_BAD_SAMPLING, - JERR_BAD_SCAN_SCRIPT, - JERR_BAD_STATE, - JERR_BAD_STRUCT_SIZE, - JERR_BAD_VIRTUAL_ACCESS, - JERR_BUFFER_SIZE, - JERR_CANT_SUSPEND, - JERR_CCIR601_NOTIMPL, - JERR_COMPONENT_COUNT, - JERR_CONVERSION_NOTIMPL, - JERR_DAC_INDEX, - JERR_DAC_VALUE, - JERR_DHT_COUNTS, - JERR_DHT_INDEX, - JERR_DQT_INDEX, - JERR_EMPTY_IMAGE, - JERR_EMS_READ, - JERR_EMS_WRITE, - JERR_EOI_EXPECTED, - JERR_FILE_READ, - JERR_FILE_WRITE, - JERR_FRACT_SAMPLE_NOTIMPL, - JERR_HUFF_CLEN_OVERFLOW, - JERR_HUFF_MISSING_CODE, - JERR_IMAGE_TOO_BIG, - JERR_INPUT_EMPTY, - JERR_INPUT_EOF, - JERR_MISMATCHED_QUANT_TABLE, - JERR_MISSING_DATA, - JERR_MODE_CHANGE, - JERR_NOTIMPL, - JERR_NOT_COMPILED, - JERR_NO_BACKING_STORE, - JERR_NO_HUFF_TABLE, - JERR_NO_IMAGE, - JERR_NO_QUANT_TABLE, - JERR_NO_SOI, - JERR_OUT_OF_MEMORY, - JERR_QUANT_COMPONENTS, - JERR_QUANT_FEW_COLORS, - JERR_QUANT_MANY_COLORS, - JERR_SOF_DUPLICATE, - JERR_SOF_NO_SOS, - JERR_SOF_UNSUPPORTED, - JERR_SOI_DUPLICATE, - JERR_SOS_NO_SOF, - JERR_TFILE_CREATE, - JERR_TFILE_READ, - JERR_TFILE_SEEK, - JERR_TFILE_WRITE, - JERR_TOO_LITTLE_DATA, - JERR_UNKNOWN_MARKER, - JERR_VIRTUAL_BUG, - JERR_WIDTH_OVERFLOW, - JERR_XMS_READ, - JERR_XMS_WRITE, - JMSG_COPYRIGHT, - JMSG_VERSION, - JTRC_16BIT_TABLES, - JTRC_ADOBE, - JTRC_APP0, - JTRC_APP14, - JTRC_DAC, - JTRC_DHT, - JTRC_DQT, - JTRC_DRI, - JTRC_EMS_CLOSE, - JTRC_EMS_OPEN, - JTRC_EOI, - JTRC_HUFFBITS, - JTRC_JFIF, - JTRC_JFIF_BADTHUMBNAILSIZE, - JTRC_JFIF_EXTENSION, - JTRC_JFIF_THUMBNAIL, - JTRC_MISC_MARKER, - JTRC_PARMLESS_MARKER, - JTRC_QUANTVALS, - JTRC_QUANT_3_NCOLORS, - JTRC_QUANT_NCOLORS, - JTRC_QUANT_SELECTED, - JTRC_RECOVERY_ACTION, - JTRC_RST, - JTRC_SMOOTH_NOTIMPL, - JTRC_SOF, - JTRC_SOF_COMPONENT, - JTRC_SOI, - JTRC_SOS, - JTRC_SOS_COMPONENT, - JTRC_SOS_PARAMS, - JTRC_TFILE_CLOSE, - JTRC_TFILE_OPEN, - JTRC_THUMB_JPEG, - JTRC_THUMB_PALETTE, - JTRC_THUMB_RGB, - JTRC_UNKNOWN_IDS, - JTRC_XMS_CLOSE, - JTRC_XMS_OPEN, - JWRN_ADOBE_XFORM, - JWRN_BOGUS_PROGRESSION, - JWRN_EXTRANEOUS_DATA, - JWRN_HIT_MARKER, - JWRN_HUFF_BAD_CODE, - JWRN_JFIF_MAJOR, - JWRN_JPEG_EOF, - JWRN_MUST_RESYNC, - JWRN_NOT_SEQUENTIAL, - JWRN_TOO_MUCH_DATA, - - - JMSG_FIRSTADDONCODE, { Must be first entry! } - - {$ifdef BMP_SUPPORTED} - JERR_BMP_BADCMAP, { Unsupported BMP colormap format } - JERR_BMP_BADDEPTH, { Only 8- and 24-bit BMP files are supported } - JERR_BMP_BADHEADER, { Invalid BMP file: bad header length } - JERR_BMP_BADPLANES, { Invalid BMP file: biPlanes not equal to 1 } - JERR_BMP_COLORSPACE, { BMP output must be grayscale or RGB } - JERR_BMP_COMPRESSED, { Sorry, compressed BMPs not yet supported } - JERR_BMP_NOT, { Not a BMP file - does not start with BM } - JTRC_BMP, { %dx%d 24-bit BMP image } - JTRC_BMP_MAPPED, { %dx%d 8-bit colormapped BMP image } - JTRC_BMP_OS2, { %dx%d 24-bit OS2 BMP image } - JTRC_BMP_OS2_MAPPED, { %dx%d 8-bit colormapped OS2 BMP image } - {$endif} { BMP_SUPPORTED } - - {$ifdef GIF_SUPPORTED} - JERR_GIF_BUG, { GIF output got confused } - JERR_GIF_CODESIZE, { Bogus GIF codesize %d } - JERR_GIF_COLORSPACE, { GIF output must be grayscale or RGB } - JERR_GIF_IMAGENOTFOUND, { Too few images in GIF file } - JERR_GIF_NOT, { Not a GIF file } - JTRC_GIF, { %dx%dx%d GIF image } - JTRC_GIF_BADVERSION, - { Warning: unexpected GIF version number '%c%c%c' } - JTRC_GIF_EXTENSION, { Ignoring GIF extension block of type 0x%02x } - JTRC_GIF_NONSQUARE, { Caution: nonsquare pixels in input } - JWRN_GIF_BADDATA, { Corrupt data in GIF file } - JWRN_GIF_CHAR, { Bogus char 0x%02x in GIF file, ignoring } - JWRN_GIF_ENDCODE, { Premature end of GIF image } - JWRN_GIF_NOMOREDATA, { Ran out of GIF bits } - {$endif} { GIF_SUPPORTED } - - {$ifdef PPM_SUPPORTED} - JERR_PPM_COLORSPACE, { PPM output must be grayscale or RGB } - JERR_PPM_NONNUMERIC, { Nonnumeric data in PPM file } - JERR_PPM_NOT, { Not a PPM file } - JTRC_PGM, { %dx%d PGM image } - JTRC_PGM_TEXT, { %dx%d text PGM image } - JTRC_PPM, { %dx%d PPM image } - JTRC_PPM_TEXT, { %dx%d text PPM image } - {$endif} { PPM_SUPPORTED } - - {$ifdef RLE_SUPPORTED} - JERR_RLE_BADERROR, { Bogus error code from RLE library } - JERR_RLE_COLORSPACE, { RLE output must be grayscale or RGB } - JERR_RLE_DIMENSIONS, { Image dimensions (%dx%d) too large for RLE } - JERR_RLE_EMPTY, { Empty RLE file } - JERR_RLE_EOF, { Premature EOF in RLE header } - JERR_RLE_MEM, { Insufficient memory for RLE header } - JERR_RLE_NOT, { Not an RLE file } - JERR_RLE_TOOMANYCHANNELS, { Cannot handle %d output channels for RLE } - JERR_RLE_UNSUPPORTED, { Cannot handle this RLE setup } - JTRC_RLE, { %dx%d full-color RLE file } - JTRC_RLE_FULLMAP, { %dx%d full-color RLE file with map of length %d } - JTRC_RLE_GRAY, { %dx%d grayscale RLE file } - JTRC_RLE_MAPGRAY, { %dx%d grayscale RLE file with map of length %d } - JTRC_RLE_MAPPED, { %dx%d colormapped RLE file with map of length %d } - {$endif} { RLE_SUPPORTED } - - {$ifdef TARGA_SUPPORTED} - JERR_TGA_BADCMAP, { Unsupported Targa colormap format } - JERR_TGA_BADPARMS, { Invalid or unsupported Targa file } - JERR_TGA_COLORSPACE, { Targa output must be grayscale or RGB } - JTRC_TGA, { %dx%d RGB Targa image } - JTRC_TGA_GRAY, { %dx%d grayscale Targa image } - JTRC_TGA_MAPPED, { %dx%d colormapped Targa image } - {$else} - JERR_TGA_NOTCOMP, { Targa support was not compiled } - {$endif} { TARGA_SUPPORTED } - - JERR_BAD_CMAP_FILE, - { Color map file is invalid or of unsupported format } - JERR_TOO_MANY_COLORS, - { Output file format cannot handle %d colormap entries } - JERR_UNGETC_FAILED, { ungetc failed } - {$ifdef TARGA_SUPPORTED} - JERR_UNKNOWN_FORMAT, - { Unrecognized input file format --- perhaps you need -targa } - {$else} - JERR_UNKNOWN_FORMAT, { Unrecognized input file format } - {$endif} - JERR_UNSUPPORTED_FORMAT, { Unsupported output file format } - - JMSG_LASTADDONCODE - ); - - -const - JMSG_LASTMSGCODE : J_MESSAGE_CODE = JMSG_LASTADDONCODE; - -type - msg_table = Array[J_MESSAGE_CODE] of string[80]; -const - jpeg_std_message_table : msg_table = ( - - { JMSG_NOMESSAGE } 'Bogus message code %d', { Must be first entry! } - -{ For maintenance convenience, list is alphabetical by message code name } - { JERR_ARITH_NOTIMPL } - 'Sorry, there are legal restrictions on arithmetic coding', - { JERR_BAD_ALIGN_TYPE } 'ALIGN_TYPE is wrong, please fix', - { JERR_BAD_ALLOC_CHUNK } 'MAX_ALLOC_CHUNK is wrong, please fix', - { JERR_BAD_BUFFER_MODE } 'Bogus buffer control mode', - { JERR_BAD_COMPONENT_ID } 'Invalid component ID %d in SOS', - { JERR_BAD_DCT_COEF } 'DCT coefficient out of range', - { JERR_BAD_DCTSIZE } 'IDCT output block size %d not supported', - { JERR_BAD_HUFF_TABLE } 'Bogus Huffman table definition', - { JERR_BAD_IN_COLORSPACE } 'Bogus input colorspace', - { JERR_BAD_J_COLORSPACE } 'Bogus JPEG colorspace', - { JERR_BAD_LENGTH } 'Bogus marker length', - { JERR_BAD_LIB_VERSION } - 'Wrong JPEG library version: library is %d, caller expects %d', - { JERR_BAD_MCU_SIZE } 'Sampling factors too large for interleaved scan', - { JERR_BAD_POOL_ID } 'Invalid memory pool code %d', - { JERR_BAD_PRECISION } 'Unsupported JPEG data precision %d', - { JERR_BAD_PROGRESSION } - 'Invalid progressive parameters Ss=%d Se=%d Ah=%d Al=%d', - { JERR_BAD_PROG_SCRIPT } - 'Invalid progressive parameters at scan script entry %d', - { JERR_BAD_SAMPLING } 'Bogus sampling factors', - { JERR_BAD_SCAN_SCRIPT } 'Invalid scan script at entry %d', - { JERR_BAD_STATE } 'Improper call to JPEG library in state %d', - { JERR_BAD_STRUCT_SIZE } - 'JPEG parameter struct mismatch: library thinks size is %d, caller expects %d', - { JERR_BAD_VIRTUAL_ACCESS } 'Bogus virtual array access', - { JERR_BUFFER_SIZE } 'Buffer passed to JPEG library is too small', - { JERR_CANT_SUSPEND } 'Suspension not allowed here', - { JERR_CCIR601_NOTIMPL } 'CCIR601 sampling not implemented yet', - { JERR_COMPONENT_COUNT } 'Too many color components: %d, max %d', - { JERR_CONVERSION_NOTIMPL } 'Unsupported color conversion request', - { JERR_DAC_INDEX } 'Bogus DAC index %d', - { JERR_DAC_VALUE } 'Bogus DAC value $%x', - { JERR_DHT_COUNTS } 'Bogus DHT counts', - { JERR_DHT_INDEX } 'Bogus DHT index %d', - { JERR_DQT_INDEX } 'Bogus DQT index %d', - { JERR_EMPTY_IMAGE } 'Empty JPEG image (DNL not supported)', - { JERR_EMS_READ } 'Read from EMS failed', - { JERR_EMS_WRITE } 'Write to EMS failed', - { JERR_EOI_EXPECTED } 'Didn''t expect more than one scan', - { JERR_FILE_READ } 'Input file read error', - { JERR_FILE_WRITE } 'Output file write error --- out of disk space?', - { JERR_FRACT_SAMPLE_NOTIMPL } 'Fractional sampling not implemented yet', - { JERR_HUFF_CLEN_OVERFLOW } 'Huffman code size table overflow', - { JERR_HUFF_MISSING_CODE } 'Missing Huffman code table entry', - { JERR_IMAGE_TOO_BIG } 'Maximum supported image dimension is %d pixels', - { JERR_INPUT_EMPTY } 'Empty input file', - { JERR_INPUT_EOF } 'Premature end of input file', - { JERR_MISMATCHED_QUANT_TABLE } - 'Cannot transcode due to multiple use of quantization table %d', - { JERR_MISSING_DATA } 'Scan script does not transmit all data', - { JERR_MODE_CHANGE } 'Invalid color quantization mode change', - { JERR_NOTIMPL } 'Not implemented yet', - { JERR_NOT_COMPILED } 'Requested feature was omitted at compile time', - { JERR_NO_BACKING_STORE } 'Backing store not supported', - { JERR_NO_HUFF_TABLE } 'Huffman table $%02x was not defined', - { JERR_NO_IMAGE } 'JPEG datastream contains no image', - { JERR_NO_QUANT_TABLE } 'Quantization table $%02x was not defined', - { JERR_NO_SOI } 'Not a JPEG file: starts with $%02x $%02x', - { JERR_OUT_OF_MEMORY } 'Insufficient memory (case %d)', - { JERR_QUANT_COMPONENTS } - 'Cannot quantize more than %d color components', - { JERR_QUANT_FEW_COLORS } 'Cannot quantize to fewer than %d colors', - { JERR_QUANT_MANY_COLORS } 'Cannot quantize to more than %d colors', - { JERR_SOF_DUPLICATE } 'Invalid JPEG file structure: two SOF markers', - { JERR_SOF_NO_SOS } 'Invalid JPEG file structure: missing SOS marker', - { JERR_SOF_UNSUPPORTED } 'Unsupported JPEG process: SOF type $%02x', - { JERR_SOI_DUPLICATE } 'Invalid JPEG file structure: two SOI markers', - { JERR_SOS_NO_SOF } 'Invalid JPEG file structure: SOS before SOF', - { JERR_TFILE_CREATE } 'Failed to create temporary file %s', - { JERR_TFILE_READ } 'Read failed on temporary file', - { JERR_TFILE_SEEK } 'Seek failed on temporary file', - { JERR_TFILE_WRITE } - 'Write failed on temporary file --- out of disk space?', - { JERR_TOO_LITTLE_DATA } 'Application transferred too few scanlines', - { JERR_UNKNOWN_MARKER } 'Unsupported marker type $%02x', - { JERR_VIRTUAL_BUG } 'Virtual array controller messed up', - { JERR_WIDTH_OVERFLOW } 'Image too wide for this implementation', - { JERR_XMS_READ } 'Read from XMS failed', - { JERR_XMS_WRITE } 'Write to XMS failed', - { JMSG_COPYRIGHT } JCOPYRIGHT, - { JMSG_VERSION } JVERSION, - { JTRC_16BIT_TABLES } - 'Caution: quantization tables are too coarse for baseline JPEG', - { JTRC_ADOBE } - 'Adobe APP14 marker: version %d, flags $%04x $%04x, transform %d', - { JTRC_APP0 } 'Unknown APP0 marker (not JFIF), length %d', - { JTRC_APP14 } 'Unknown APP14 marker (not Adobe), length %d', - { JTRC_DAC } 'Define Arithmetic Table $%02x: $%02x', - { JTRC_DHT } 'Define Huffman Table $%02x', - { JTRC_DQT } 'Define Quantization Table %d precision %d', - { JTRC_DRI } 'Define Restart Interval %d', - { JTRC_EMS_CLOSE } 'Freed EMS handle %d', - { JTRC_EMS_OPEN } 'Obtained EMS handle %d', - { JTRC_EOI } 'End Of Image', - { JTRC_HUFFBITS } ' %3d %3d %3d %3d %3d %3d %3d %3d', - { JTRC_JFIF } 'JFIF APP0 marker, density %dx%d %d', - { JTRC_JFIF_BADTHUMBNAILSIZE } - 'Warning: thumbnail image size does not match data length %d', - { JTRC_JFIF_EXTENSION } 'JFIF extension marker: type 0x%02x, length %u', - { JTRC_JFIF_THUMBNAIL } ' with %d x %d thumbnail image', - { JTRC_MISC_MARKER } 'Skipping marker $%02x, length %d', - { JTRC_PARMLESS_MARKER } 'Unexpected marker $%02x', - { JTRC_QUANTVALS } ' %4d %4d %4d %4d %4d %4d %4d %4d', - { JTRC_QUANT_3_NCOLORS } 'Quantizing to %d = %d*%d*%d colors', - { JTRC_QUANT_NCOLORS } 'Quantizing to %d colors', - { JTRC_QUANT_SELECTED } 'Selected %d colors for quantization', - { JTRC_RECOVERY_ACTION } 'At marker $%02x, recovery action %d', - { JTRC_RST } 'RST%d', - { JTRC_SMOOTH_NOTIMPL } - 'Smoothing not supported with nonstandard sampling ratios', - { JTRC_SOF } 'Start Of Frame $%02x: width=%d, height=%d, components=%d', - { JTRC_SOF_COMPONENT } ' Component %d: %dhx%dv q=%d', - { JTRC_SOI } 'Start of Image', - { JTRC_SOS } 'Start Of Scan: %d components', - { JTRC_SOS_COMPONENT } ' Component %d: dc=%d ac=%d', - { JTRC_SOS_PARAMS } ' Ss=%d, Se=%d, Ah=%d, Al=%d', - { JTRC_TFILE_CLOSE } 'Closed temporary file %s', - { JTRC_TFILE_OPEN } 'Opened temporary file %s', - { JTRC_THUMB_JPEG } - 'JFIF extension marker: JPEG-compressed thumbnail image, length %u', - { JMESSAGE(JTRC_THUMB_PALETTE } - 'JFIF extension marker: palette thumbnail image, length %u', - { JMESSAGE(JTRC_THUMB_RGB } - 'JFIF extension marker: RGB thumbnail image, length %u', - { JTRC_UNKNOWN_IDS } - 'Unrecognized component IDs %d %d %d, assuming YCbCr', - { JTRC_XMS_CLOSE } 'Freed XMS handle %d', - { JTRC_XMS_OPEN } 'Obtained XMS handle %d', - { JWRN_ADOBE_XFORM } 'Unknown Adobe color transform code %d', - { JWRN_BOGUS_PROGRESSION } - 'Inconsistent progression sequence for component %d coefficient %d', - { JWRN_EXTRANEOUS_DATA } - 'Corrupt JPEG data: %d extraneous bytes before marker $%02x', - { JWRN_HIT_MARKER } 'Corrupt JPEG data: premature end of data segment', - { JWRN_HUFF_BAD_CODE } 'Corrupt JPEG data: bad Huffman code', - { JWRN_JFIF_MAJOR } 'Warning: unknown JFIF revision number %d.%02d', - { JWRN_JPEG_EOF } 'Premature end of JPEG file', - { JWRN_MUST_RESYNC } - 'Corrupt JPEG data: found marker $%02x instead of RST%d', - { JWRN_NOT_SEQUENTIAL } 'Invalid SOS parameters for sequential JPEG', - { JWRN_TOO_MUCH_DATA } 'Application transferred too many scanlines', - - { JMSG_FIRSTADDONCODE } '', { Must be first entry! } - -{$ifdef BMP_SUPPORTED} - { JERR_BMP_BADCMAP } 'Unsupported BMP colormap format', - { JERR_BMP_BADDEPTH } 'Only 8- and 24-bit BMP files are supported', - { JERR_BMP_BADHEADER } 'Invalid BMP file: bad header length', - { JERR_BMP_BADPLANES } 'Invalid BMP file: biPlanes not equal to 1', - { JERR_BMP_COLORSPACE } 'BMP output must be grayscale or RGB', - { JERR_BMP_COMPRESSED } 'Sorry, compressed BMPs not yet supported', - { JERR_BMP_NOT } 'Not a BMP file - does not start with BM', - { JTRC_BMP } '%dx%d 24-bit BMP image', - { JTRC_BMP_MAPPED } '%dx%d 8-bit colormapped BMP image', - { JTRC_BMP_OS2 } '%dx%d 24-bit OS2 BMP image', - { JTRC_BMP_OS2_MAPPED } '%dx%d 8-bit colormapped OS2 BMP image', -{$endif} { BMP_SUPPORTED } - -{$ifdef GIF_SUPPORTED} - { JERR_GIF_BUG } 'GIF output got confused', - { JERR_GIF_CODESIZE } 'Bogus GIF codesize %d', - { JERR_GIF_COLORSPACE } 'GIF output must be grayscale or RGB', - { JERR_GIF_IMAGENOTFOUND } 'Too few images in GIF file', - { JERR_GIF_NOT } 'Not a GIF file', - { JTRC_GIF } '%dx%dx%d GIF image', - { JTRC_GIF_BADVERSION } - 'Warning: unexpected GIF version number "%c%c%c"', - { JTRC_GIF_EXTENSION } 'Ignoring GIF extension block of type 0x%02x', - { JTRC_GIF_NONSQUARE } 'Caution: nonsquare pixels in input', - { JWRN_GIF_BADDATA } 'Corrupt data in GIF file', - { JWRN_GIF_CHAR } 'Bogus char 0x%02x in GIF file, ignoring', - { JWRN_GIF_ENDCODE } 'Premature end of GIF image', - { JWRN_GIF_NOMOREDATA } 'Ran out of GIF bits', -{$endif} { GIF_SUPPORTED } - -{$ifdef PPM_SUPPORTED} - { JERR_PPM_COLORSPACE } 'PPM output must be grayscale or RGB', - { JERR_PPM_NONNUMERIC } 'Nonnumeric data in PPM file', - { JERR_PPM_NOT } 'Not a PPM file', - { JTRC_PGM } '%dx%d PGM image', - { JTRC_PGM_TEXT } '%dx%d text PGM image', - { JTRC_PPM } '%dx%d PPM image', - { JTRC_PPM_TEXT } '%dx%d text PPM image', -{$endif} { PPM_SUPPORTED } - -{$ifdef RLE_SUPPORTED} - { JERR_RLE_BADERROR } 'Bogus error code from RLE library', - { JERR_RLE_COLORSPACE } 'RLE output must be grayscale or RGB', - { JERR_RLE_DIMENSIONS } 'Image dimensions (%dx%d) too large for RLE', - { JERR_RLE_EMPTY } 'Empty RLE file', - { JERR_RLE_EOF } 'Premature EOF in RLE header', - { JERR_RLE_MEM } 'Insufficient memory for RLE header', - { JERR_RLE_NOT } 'Not an RLE file', - { JERR_RLE_TOOMANYCHANNELS } 'Cannot handle %d output channels for RLE', - { JERR_RLE_UNSUPPORTED } 'Cannot handle this RLE setup', - { JTRC_RLE } '%dx%d full-color RLE file', - { JTRC_RLE_FULLMAP } '%dx%d full-color RLE file with map of length %d', - { JTRC_RLE_GRAY } '%dx%d grayscale RLE file', - { JTRC_RLE_MAPGRAY } '%dx%d grayscale RLE file with map of length %d', - { JTRC_RLE_MAPPED } '%dx%d colormapped RLE file with map of length %d', -{$endif} { RLE_SUPPORTED } - -{$ifdef TARGA_SUPPORTED} - { JERR_TGA_BADCMAP } 'Unsupported Targa colormap format', - { JERR_TGA_BADPARMS } 'Invalid or unsupported Targa file', - { JERR_TGA_COLORSPACE } 'Targa output must be grayscale or RGB', - { JTRC_TGA } '%dx%d RGB Targa image', - { JTRC_TGA_GRAY } '%dx%d grayscale Targa image', - { JTRC_TGA_MAPPED } '%dx%d colormapped Targa image', -{$else} - { JERR_TGA_NOTCOMP } 'Targa support was not compiled', -{$endif} { TARGA_SUPPORTED } - - { JERR_BAD_CMAP_FILE } - 'Color map file is invalid or of unsupported format', - { JERR_TOO_MANY_COLORS } - 'Output file format cannot handle %d colormap entries', - { JERR_UNGETC_FAILED } 'ungetc failed', -{$ifdef TARGA_SUPPORTED} - { JERR_UNKNOWN_FORMAT } - 'Unrecognized input file format --- perhaps you need -targa', -{$else} - { JERR_UNKNOWN_FORMAT } 'Unrecognized input file format', -{$endif} - { JERR_UNSUPPORTED_FORMAT } 'Unsupported output file format', - - - { JMSG_LASTADDONCODE } ''); - -implementation - -end. +unit imjdeferr; + +{ This file defines the error and message codes for the cjpeg/djpeg + applications. These strings are not needed as part of the JPEG library + proper. + Edit this file to add new codes, or to translate the message strings to + some other language. } + +{ Original cderror.h ; Copyright (C) 1994, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +{ To define the enum list of message codes, include this file without + defining macro JMESSAGE. To create a message string table, include it + again with a suitable JMESSAGE definition (see jerror.c for an example). } + + +{ Original: jversion.h ; Copyright (C) 1991-1996, Thomas G. Lane. } +{ This file contains software version identification. } + +const + JVERSION = '6a 7-Feb-96'; + + JCOPYRIGHT = 'Copyright (C) 1996, Thomas G. Lane'; + + JNOTICE = 'Pascal Translation, Copyright (C) 1996, Jacques Nomssi Nzali'; + +{ Create the message string table. + We do this from the master message list in jerror.h by re-reading + jerror.h with a suitable definition for macro JMESSAGE. + The message table is made an external symbol just in case any applications + want to refer to it directly. } + +type + J_MESSAGE_CODE =( + JMSG_NOMESSAGE, + JERR_ARITH_NOTIMPL, + JERR_BAD_ALIGN_TYPE, + JERR_BAD_ALLOC_CHUNK, + JERR_BAD_BUFFER_MODE, + JERR_BAD_COMPONENT_ID, + JERR_BAD_DCT_COEF, + JERR_BAD_DCTSIZE, + JERR_BAD_HUFF_TABLE, + JERR_BAD_IN_COLORSPACE, + JERR_BAD_J_COLORSPACE, + JERR_BAD_LENGTH, + JERR_BAD_LIB_VERSION, + JERR_BAD_MCU_SIZE, + JERR_BAD_POOL_ID, + JERR_BAD_PRECISION, + JERR_BAD_PROGRESSION, + JERR_BAD_PROG_SCRIPT, + JERR_BAD_SAMPLING, + JERR_BAD_SCAN_SCRIPT, + JERR_BAD_STATE, + JERR_BAD_STRUCT_SIZE, + JERR_BAD_VIRTUAL_ACCESS, + JERR_BUFFER_SIZE, + JERR_CANT_SUSPEND, + JERR_CCIR601_NOTIMPL, + JERR_COMPONENT_COUNT, + JERR_CONVERSION_NOTIMPL, + JERR_DAC_INDEX, + JERR_DAC_VALUE, + JERR_DHT_COUNTS, + JERR_DHT_INDEX, + JERR_DQT_INDEX, + JERR_EMPTY_IMAGE, + JERR_EMS_READ, + JERR_EMS_WRITE, + JERR_EOI_EXPECTED, + JERR_FILE_READ, + JERR_FILE_WRITE, + JERR_FRACT_SAMPLE_NOTIMPL, + JERR_HUFF_CLEN_OVERFLOW, + JERR_HUFF_MISSING_CODE, + JERR_IMAGE_TOO_BIG, + JERR_INPUT_EMPTY, + JERR_INPUT_EOF, + JERR_MISMATCHED_QUANT_TABLE, + JERR_MISSING_DATA, + JERR_MODE_CHANGE, + JERR_NOTIMPL, + JERR_NOT_COMPILED, + JERR_NO_BACKING_STORE, + JERR_NO_HUFF_TABLE, + JERR_NO_IMAGE, + JERR_NO_QUANT_TABLE, + JERR_NO_SOI, + JERR_OUT_OF_MEMORY, + JERR_QUANT_COMPONENTS, + JERR_QUANT_FEW_COLORS, + JERR_QUANT_MANY_COLORS, + JERR_SOF_DUPLICATE, + JERR_SOF_NO_SOS, + JERR_SOF_UNSUPPORTED, + JERR_SOI_DUPLICATE, + JERR_SOS_NO_SOF, + JERR_TFILE_CREATE, + JERR_TFILE_READ, + JERR_TFILE_SEEK, + JERR_TFILE_WRITE, + JERR_TOO_LITTLE_DATA, + JERR_UNKNOWN_MARKER, + JERR_VIRTUAL_BUG, + JERR_WIDTH_OVERFLOW, + JERR_XMS_READ, + JERR_XMS_WRITE, + JMSG_COPYRIGHT, + JMSG_VERSION, + JTRC_16BIT_TABLES, + JTRC_ADOBE, + JTRC_APP0, + JTRC_APP14, + JTRC_DAC, + JTRC_DHT, + JTRC_DQT, + JTRC_DRI, + JTRC_EMS_CLOSE, + JTRC_EMS_OPEN, + JTRC_EOI, + JTRC_HUFFBITS, + JTRC_JFIF, + JTRC_JFIF_BADTHUMBNAILSIZE, + JTRC_JFIF_EXTENSION, + JTRC_JFIF_THUMBNAIL, + JTRC_MISC_MARKER, + JTRC_PARMLESS_MARKER, + JTRC_QUANTVALS, + JTRC_QUANT_3_NCOLORS, + JTRC_QUANT_NCOLORS, + JTRC_QUANT_SELECTED, + JTRC_RECOVERY_ACTION, + JTRC_RST, + JTRC_SMOOTH_NOTIMPL, + JTRC_SOF, + JTRC_SOF_COMPONENT, + JTRC_SOI, + JTRC_SOS, + JTRC_SOS_COMPONENT, + JTRC_SOS_PARAMS, + JTRC_TFILE_CLOSE, + JTRC_TFILE_OPEN, + JTRC_THUMB_JPEG, + JTRC_THUMB_PALETTE, + JTRC_THUMB_RGB, + JTRC_UNKNOWN_IDS, + JTRC_XMS_CLOSE, + JTRC_XMS_OPEN, + JWRN_ADOBE_XFORM, + JWRN_BOGUS_PROGRESSION, + JWRN_EXTRANEOUS_DATA, + JWRN_HIT_MARKER, + JWRN_HUFF_BAD_CODE, + JWRN_JFIF_MAJOR, + JWRN_JPEG_EOF, + JWRN_MUST_RESYNC, + JWRN_NOT_SEQUENTIAL, + JWRN_TOO_MUCH_DATA, + + + JMSG_FIRSTADDONCODE, { Must be first entry! } + + {$ifdef BMP_SUPPORTED} + JERR_BMP_BADCMAP, { Unsupported BMP colormap format } + JERR_BMP_BADDEPTH, { Only 8- and 24-bit BMP files are supported } + JERR_BMP_BADHEADER, { Invalid BMP file: bad header length } + JERR_BMP_BADPLANES, { Invalid BMP file: biPlanes not equal to 1 } + JERR_BMP_COLORSPACE, { BMP output must be grayscale or RGB } + JERR_BMP_COMPRESSED, { Sorry, compressed BMPs not yet supported } + JERR_BMP_NOT, { Not a BMP file - does not start with BM } + JTRC_BMP, { %dx%d 24-bit BMP image } + JTRC_BMP_MAPPED, { %dx%d 8-bit colormapped BMP image } + JTRC_BMP_OS2, { %dx%d 24-bit OS2 BMP image } + JTRC_BMP_OS2_MAPPED, { %dx%d 8-bit colormapped OS2 BMP image } + {$endif} { BMP_SUPPORTED } + + {$ifdef GIF_SUPPORTED} + JERR_GIF_BUG, { GIF output got confused } + JERR_GIF_CODESIZE, { Bogus GIF codesize %d } + JERR_GIF_COLORSPACE, { GIF output must be grayscale or RGB } + JERR_GIF_IMAGENOTFOUND, { Too few images in GIF file } + JERR_GIF_NOT, { Not a GIF file } + JTRC_GIF, { %dx%dx%d GIF image } + JTRC_GIF_BADVERSION, + { Warning: unexpected GIF version number '%c%c%c' } + JTRC_GIF_EXTENSION, { Ignoring GIF extension block of type 0x%02x } + JTRC_GIF_NONSQUARE, { Caution: nonsquare pixels in input } + JWRN_GIF_BADDATA, { Corrupt data in GIF file } + JWRN_GIF_CHAR, { Bogus char 0x%02x in GIF file, ignoring } + JWRN_GIF_ENDCODE, { Premature end of GIF image } + JWRN_GIF_NOMOREDATA, { Ran out of GIF bits } + {$endif} { GIF_SUPPORTED } + + {$ifdef PPM_SUPPORTED} + JERR_PPM_COLORSPACE, { PPM output must be grayscale or RGB } + JERR_PPM_NONNUMERIC, { Nonnumeric data in PPM file } + JERR_PPM_NOT, { Not a PPM file } + JTRC_PGM, { %dx%d PGM image } + JTRC_PGM_TEXT, { %dx%d text PGM image } + JTRC_PPM, { %dx%d PPM image } + JTRC_PPM_TEXT, { %dx%d text PPM image } + {$endif} { PPM_SUPPORTED } + + {$ifdef RLE_SUPPORTED} + JERR_RLE_BADERROR, { Bogus error code from RLE library } + JERR_RLE_COLORSPACE, { RLE output must be grayscale or RGB } + JERR_RLE_DIMENSIONS, { Image dimensions (%dx%d) too large for RLE } + JERR_RLE_EMPTY, { Empty RLE file } + JERR_RLE_EOF, { Premature EOF in RLE header } + JERR_RLE_MEM, { Insufficient memory for RLE header } + JERR_RLE_NOT, { Not an RLE file } + JERR_RLE_TOOMANYCHANNELS, { Cannot handle %d output channels for RLE } + JERR_RLE_UNSUPPORTED, { Cannot handle this RLE setup } + JTRC_RLE, { %dx%d full-color RLE file } + JTRC_RLE_FULLMAP, { %dx%d full-color RLE file with map of length %d } + JTRC_RLE_GRAY, { %dx%d grayscale RLE file } + JTRC_RLE_MAPGRAY, { %dx%d grayscale RLE file with map of length %d } + JTRC_RLE_MAPPED, { %dx%d colormapped RLE file with map of length %d } + {$endif} { RLE_SUPPORTED } + + {$ifdef TARGA_SUPPORTED} + JERR_TGA_BADCMAP, { Unsupported Targa colormap format } + JERR_TGA_BADPARMS, { Invalid or unsupported Targa file } + JERR_TGA_COLORSPACE, { Targa output must be grayscale or RGB } + JTRC_TGA, { %dx%d RGB Targa image } + JTRC_TGA_GRAY, { %dx%d grayscale Targa image } + JTRC_TGA_MAPPED, { %dx%d colormapped Targa image } + {$else} + JERR_TGA_NOTCOMP, { Targa support was not compiled } + {$endif} { TARGA_SUPPORTED } + + JERR_BAD_CMAP_FILE, + { Color map file is invalid or of unsupported format } + JERR_TOO_MANY_COLORS, + { Output file format cannot handle %d colormap entries } + JERR_UNGETC_FAILED, { ungetc failed } + {$ifdef TARGA_SUPPORTED} + JERR_UNKNOWN_FORMAT, + { Unrecognized input file format --- perhaps you need -targa } + {$else} + JERR_UNKNOWN_FORMAT, { Unrecognized input file format } + {$endif} + JERR_UNSUPPORTED_FORMAT, { Unsupported output file format } + + JMSG_LASTADDONCODE + ); + + +const + JMSG_LASTMSGCODE : J_MESSAGE_CODE = JMSG_LASTADDONCODE; + +type + msg_table = Array[J_MESSAGE_CODE] of string[80]; +const + jpeg_std_message_table : msg_table = ( + + { JMSG_NOMESSAGE } 'Bogus message code %d', { Must be first entry! } + +{ For maintenance convenience, list is alphabetical by message code name } + { JERR_ARITH_NOTIMPL } + 'Sorry, there are legal restrictions on arithmetic coding', + { JERR_BAD_ALIGN_TYPE } 'ALIGN_TYPE is wrong, please fix', + { JERR_BAD_ALLOC_CHUNK } 'MAX_ALLOC_CHUNK is wrong, please fix', + { JERR_BAD_BUFFER_MODE } 'Bogus buffer control mode', + { JERR_BAD_COMPONENT_ID } 'Invalid component ID %d in SOS', + { JERR_BAD_DCT_COEF } 'DCT coefficient out of range', + { JERR_BAD_DCTSIZE } 'IDCT output block size %d not supported', + { JERR_BAD_HUFF_TABLE } 'Bogus Huffman table definition', + { JERR_BAD_IN_COLORSPACE } 'Bogus input colorspace', + { JERR_BAD_J_COLORSPACE } 'Bogus JPEG colorspace', + { JERR_BAD_LENGTH } 'Bogus marker length', + { JERR_BAD_LIB_VERSION } + 'Wrong JPEG library version: library is %d, caller expects %d', + { JERR_BAD_MCU_SIZE } 'Sampling factors too large for interleaved scan', + { JERR_BAD_POOL_ID } 'Invalid memory pool code %d', + { JERR_BAD_PRECISION } 'Unsupported JPEG data precision %d', + { JERR_BAD_PROGRESSION } + 'Invalid progressive parameters Ss=%d Se=%d Ah=%d Al=%d', + { JERR_BAD_PROG_SCRIPT } + 'Invalid progressive parameters at scan script entry %d', + { JERR_BAD_SAMPLING } 'Bogus sampling factors', + { JERR_BAD_SCAN_SCRIPT } 'Invalid scan script at entry %d', + { JERR_BAD_STATE } 'Improper call to JPEG library in state %d', + { JERR_BAD_STRUCT_SIZE } + 'JPEG parameter struct mismatch: library thinks size is %d, caller expects %d', + { JERR_BAD_VIRTUAL_ACCESS } 'Bogus virtual array access', + { JERR_BUFFER_SIZE } 'Buffer passed to JPEG library is too small', + { JERR_CANT_SUSPEND } 'Suspension not allowed here', + { JERR_CCIR601_NOTIMPL } 'CCIR601 sampling not implemented yet', + { JERR_COMPONENT_COUNT } 'Too many color components: %d, max %d', + { JERR_CONVERSION_NOTIMPL } 'Unsupported color conversion request', + { JERR_DAC_INDEX } 'Bogus DAC index %d', + { JERR_DAC_VALUE } 'Bogus DAC value $%x', + { JERR_DHT_COUNTS } 'Bogus DHT counts', + { JERR_DHT_INDEX } 'Bogus DHT index %d', + { JERR_DQT_INDEX } 'Bogus DQT index %d', + { JERR_EMPTY_IMAGE } 'Empty JPEG image (DNL not supported)', + { JERR_EMS_READ } 'Read from EMS failed', + { JERR_EMS_WRITE } 'Write to EMS failed', + { JERR_EOI_EXPECTED } 'Didn''t expect more than one scan', + { JERR_FILE_READ } 'Input file read error', + { JERR_FILE_WRITE } 'Output file write error --- out of disk space?', + { JERR_FRACT_SAMPLE_NOTIMPL } 'Fractional sampling not implemented yet', + { JERR_HUFF_CLEN_OVERFLOW } 'Huffman code size table overflow', + { JERR_HUFF_MISSING_CODE } 'Missing Huffman code table entry', + { JERR_IMAGE_TOO_BIG } 'Maximum supported image dimension is %d pixels', + { JERR_INPUT_EMPTY } 'Empty input file', + { JERR_INPUT_EOF } 'Premature end of input file', + { JERR_MISMATCHED_QUANT_TABLE } + 'Cannot transcode due to multiple use of quantization table %d', + { JERR_MISSING_DATA } 'Scan script does not transmit all data', + { JERR_MODE_CHANGE } 'Invalid color quantization mode change', + { JERR_NOTIMPL } 'Not implemented yet', + { JERR_NOT_COMPILED } 'Requested feature was omitted at compile time', + { JERR_NO_BACKING_STORE } 'Backing store not supported', + { JERR_NO_HUFF_TABLE } 'Huffman table $%02x was not defined', + { JERR_NO_IMAGE } 'JPEG datastream contains no image', + { JERR_NO_QUANT_TABLE } 'Quantization table $%02x was not defined', + { JERR_NO_SOI } 'Not a JPEG file: starts with $%02x $%02x', + { JERR_OUT_OF_MEMORY } 'Insufficient memory (case %d)', + { JERR_QUANT_COMPONENTS } + 'Cannot quantize more than %d color components', + { JERR_QUANT_FEW_COLORS } 'Cannot quantize to fewer than %d colors', + { JERR_QUANT_MANY_COLORS } 'Cannot quantize to more than %d colors', + { JERR_SOF_DUPLICATE } 'Invalid JPEG file structure: two SOF markers', + { JERR_SOF_NO_SOS } 'Invalid JPEG file structure: missing SOS marker', + { JERR_SOF_UNSUPPORTED } 'Unsupported JPEG process: SOF type $%02x', + { JERR_SOI_DUPLICATE } 'Invalid JPEG file structure: two SOI markers', + { JERR_SOS_NO_SOF } 'Invalid JPEG file structure: SOS before SOF', + { JERR_TFILE_CREATE } 'Failed to create temporary file %s', + { JERR_TFILE_READ } 'Read failed on temporary file', + { JERR_TFILE_SEEK } 'Seek failed on temporary file', + { JERR_TFILE_WRITE } + 'Write failed on temporary file --- out of disk space?', + { JERR_TOO_LITTLE_DATA } 'Application transferred too few scanlines', + { JERR_UNKNOWN_MARKER } 'Unsupported marker type $%02x', + { JERR_VIRTUAL_BUG } 'Virtual array controller messed up', + { JERR_WIDTH_OVERFLOW } 'Image too wide for this implementation', + { JERR_XMS_READ } 'Read from XMS failed', + { JERR_XMS_WRITE } 'Write to XMS failed', + { JMSG_COPYRIGHT } JCOPYRIGHT, + { JMSG_VERSION } JVERSION, + { JTRC_16BIT_TABLES } + 'Caution: quantization tables are too coarse for baseline JPEG', + { JTRC_ADOBE } + 'Adobe APP14 marker: version %d, flags $%04x $%04x, transform %d', + { JTRC_APP0 } 'Unknown APP0 marker (not JFIF), length %d', + { JTRC_APP14 } 'Unknown APP14 marker (not Adobe), length %d', + { JTRC_DAC } 'Define Arithmetic Table $%02x: $%02x', + { JTRC_DHT } 'Define Huffman Table $%02x', + { JTRC_DQT } 'Define Quantization Table %d precision %d', + { JTRC_DRI } 'Define Restart Interval %d', + { JTRC_EMS_CLOSE } 'Freed EMS handle %d', + { JTRC_EMS_OPEN } 'Obtained EMS handle %d', + { JTRC_EOI } 'End Of Image', + { JTRC_HUFFBITS } ' %3d %3d %3d %3d %3d %3d %3d %3d', + { JTRC_JFIF } 'JFIF APP0 marker, density %dx%d %d', + { JTRC_JFIF_BADTHUMBNAILSIZE } + 'Warning: thumbnail image size does not match data length %d', + { JTRC_JFIF_EXTENSION } 'JFIF extension marker: type 0x%02x, length %u', + { JTRC_JFIF_THUMBNAIL } ' with %d x %d thumbnail image', + { JTRC_MISC_MARKER } 'Skipping marker $%02x, length %d', + { JTRC_PARMLESS_MARKER } 'Unexpected marker $%02x', + { JTRC_QUANTVALS } ' %4d %4d %4d %4d %4d %4d %4d %4d', + { JTRC_QUANT_3_NCOLORS } 'Quantizing to %d = %d*%d*%d colors', + { JTRC_QUANT_NCOLORS } 'Quantizing to %d colors', + { JTRC_QUANT_SELECTED } 'Selected %d colors for quantization', + { JTRC_RECOVERY_ACTION } 'At marker $%02x, recovery action %d', + { JTRC_RST } 'RST%d', + { JTRC_SMOOTH_NOTIMPL } + 'Smoothing not supported with nonstandard sampling ratios', + { JTRC_SOF } 'Start Of Frame $%02x: width=%d, height=%d, components=%d', + { JTRC_SOF_COMPONENT } ' Component %d: %dhx%dv q=%d', + { JTRC_SOI } 'Start of Image', + { JTRC_SOS } 'Start Of Scan: %d components', + { JTRC_SOS_COMPONENT } ' Component %d: dc=%d ac=%d', + { JTRC_SOS_PARAMS } ' Ss=%d, Se=%d, Ah=%d, Al=%d', + { JTRC_TFILE_CLOSE } 'Closed temporary file %s', + { JTRC_TFILE_OPEN } 'Opened temporary file %s', + { JTRC_THUMB_JPEG } + 'JFIF extension marker: JPEG-compressed thumbnail image, length %u', + { JMESSAGE(JTRC_THUMB_PALETTE } + 'JFIF extension marker: palette thumbnail image, length %u', + { JMESSAGE(JTRC_THUMB_RGB } + 'JFIF extension marker: RGB thumbnail image, length %u', + { JTRC_UNKNOWN_IDS } + 'Unrecognized component IDs %d %d %d, assuming YCbCr', + { JTRC_XMS_CLOSE } 'Freed XMS handle %d', + { JTRC_XMS_OPEN } 'Obtained XMS handle %d', + { JWRN_ADOBE_XFORM } 'Unknown Adobe color transform code %d', + { JWRN_BOGUS_PROGRESSION } + 'Inconsistent progression sequence for component %d coefficient %d', + { JWRN_EXTRANEOUS_DATA } + 'Corrupt JPEG data: %d extraneous bytes before marker $%02x', + { JWRN_HIT_MARKER } 'Corrupt JPEG data: premature end of data segment', + { JWRN_HUFF_BAD_CODE } 'Corrupt JPEG data: bad Huffman code', + { JWRN_JFIF_MAJOR } 'Warning: unknown JFIF revision number %d.%02d', + { JWRN_JPEG_EOF } 'Premature end of JPEG file', + { JWRN_MUST_RESYNC } + 'Corrupt JPEG data: found marker $%02x instead of RST%d', + { JWRN_NOT_SEQUENTIAL } 'Invalid SOS parameters for sequential JPEG', + { JWRN_TOO_MUCH_DATA } 'Application transferred too many scanlines', + + { JMSG_FIRSTADDONCODE } '', { Must be first entry! } + +{$ifdef BMP_SUPPORTED} + { JERR_BMP_BADCMAP } 'Unsupported BMP colormap format', + { JERR_BMP_BADDEPTH } 'Only 8- and 24-bit BMP files are supported', + { JERR_BMP_BADHEADER } 'Invalid BMP file: bad header length', + { JERR_BMP_BADPLANES } 'Invalid BMP file: biPlanes not equal to 1', + { JERR_BMP_COLORSPACE } 'BMP output must be grayscale or RGB', + { JERR_BMP_COMPRESSED } 'Sorry, compressed BMPs not yet supported', + { JERR_BMP_NOT } 'Not a BMP file - does not start with BM', + { JTRC_BMP } '%dx%d 24-bit BMP image', + { JTRC_BMP_MAPPED } '%dx%d 8-bit colormapped BMP image', + { JTRC_BMP_OS2 } '%dx%d 24-bit OS2 BMP image', + { JTRC_BMP_OS2_MAPPED } '%dx%d 8-bit colormapped OS2 BMP image', +{$endif} { BMP_SUPPORTED } + +{$ifdef GIF_SUPPORTED} + { JERR_GIF_BUG } 'GIF output got confused', + { JERR_GIF_CODESIZE } 'Bogus GIF codesize %d', + { JERR_GIF_COLORSPACE } 'GIF output must be grayscale or RGB', + { JERR_GIF_IMAGENOTFOUND } 'Too few images in GIF file', + { JERR_GIF_NOT } 'Not a GIF file', + { JTRC_GIF } '%dx%dx%d GIF image', + { JTRC_GIF_BADVERSION } + 'Warning: unexpected GIF version number "%c%c%c"', + { JTRC_GIF_EXTENSION } 'Ignoring GIF extension block of type 0x%02x', + { JTRC_GIF_NONSQUARE } 'Caution: nonsquare pixels in input', + { JWRN_GIF_BADDATA } 'Corrupt data in GIF file', + { JWRN_GIF_CHAR } 'Bogus char 0x%02x in GIF file, ignoring', + { JWRN_GIF_ENDCODE } 'Premature end of GIF image', + { JWRN_GIF_NOMOREDATA } 'Ran out of GIF bits', +{$endif} { GIF_SUPPORTED } + +{$ifdef PPM_SUPPORTED} + { JERR_PPM_COLORSPACE } 'PPM output must be grayscale or RGB', + { JERR_PPM_NONNUMERIC } 'Nonnumeric data in PPM file', + { JERR_PPM_NOT } 'Not a PPM file', + { JTRC_PGM } '%dx%d PGM image', + { JTRC_PGM_TEXT } '%dx%d text PGM image', + { JTRC_PPM } '%dx%d PPM image', + { JTRC_PPM_TEXT } '%dx%d text PPM image', +{$endif} { PPM_SUPPORTED } + +{$ifdef RLE_SUPPORTED} + { JERR_RLE_BADERROR } 'Bogus error code from RLE library', + { JERR_RLE_COLORSPACE } 'RLE output must be grayscale or RGB', + { JERR_RLE_DIMENSIONS } 'Image dimensions (%dx%d) too large for RLE', + { JERR_RLE_EMPTY } 'Empty RLE file', + { JERR_RLE_EOF } 'Premature EOF in RLE header', + { JERR_RLE_MEM } 'Insufficient memory for RLE header', + { JERR_RLE_NOT } 'Not an RLE file', + { JERR_RLE_TOOMANYCHANNELS } 'Cannot handle %d output channels for RLE', + { JERR_RLE_UNSUPPORTED } 'Cannot handle this RLE setup', + { JTRC_RLE } '%dx%d full-color RLE file', + { JTRC_RLE_FULLMAP } '%dx%d full-color RLE file with map of length %d', + { JTRC_RLE_GRAY } '%dx%d grayscale RLE file', + { JTRC_RLE_MAPGRAY } '%dx%d grayscale RLE file with map of length %d', + { JTRC_RLE_MAPPED } '%dx%d colormapped RLE file with map of length %d', +{$endif} { RLE_SUPPORTED } + +{$ifdef TARGA_SUPPORTED} + { JERR_TGA_BADCMAP } 'Unsupported Targa colormap format', + { JERR_TGA_BADPARMS } 'Invalid or unsupported Targa file', + { JERR_TGA_COLORSPACE } 'Targa output must be grayscale or RGB', + { JTRC_TGA } '%dx%d RGB Targa image', + { JTRC_TGA_GRAY } '%dx%d grayscale Targa image', + { JTRC_TGA_MAPPED } '%dx%d colormapped Targa image', +{$else} + { JERR_TGA_NOTCOMP } 'Targa support was not compiled', +{$endif} { TARGA_SUPPORTED } + + { JERR_BAD_CMAP_FILE } + 'Color map file is invalid or of unsupported format', + { JERR_TOO_MANY_COLORS } + 'Output file format cannot handle %d colormap entries', + { JERR_UNGETC_FAILED } 'ungetc failed', +{$ifdef TARGA_SUPPORTED} + { JERR_UNKNOWN_FORMAT } + 'Unrecognized input file format --- perhaps you need -targa', +{$else} + { JERR_UNKNOWN_FORMAT } 'Unrecognized input file format', +{$endif} + { JERR_UNSUPPORTED_FORMAT } 'Unsupported output file format', + + + { JMSG_LASTADDONCODE } ''); + +implementation + +end. diff --git a/Imaging/JpegLib/imjdhuff.pas b/Imaging/JpegLib/imjdhuff.pas index f11485c..481c350 100644 --- a/Imaging/JpegLib/imjdhuff.pas +++ b/Imaging/JpegLib/imjdhuff.pas @@ -1,1204 +1,1205 @@ -unit imjdhuff; - -{ This file contains declarations for Huffman entropy decoding routines - that are shared between the sequential decoder (jdhuff.c) and the - progressive decoder (jdphuff.c). No other modules need to see these. } - -{ This file contains Huffman entropy decoding routines. - - Much of the complexity here has to do with supporting input suspension. - If the data source module demands suspension, we want to be able to back - up to the start of the current MCU. To do this, we copy state variables - into local working storage, and update them back to the permanent - storage only upon successful completion of an MCU. } - -{ Original: jdhuff.h+jdhuff.c; Copyright (C) 1991-1997, Thomas G. Lane. } - - - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjutils, - imjpeglib; - - -{ Declarations shared with jdphuff.c } - - - -{ Derived data constructed for each Huffman table } - -const - HUFF_LOOKAHEAD = 8; { # of bits of lookahead } - -type - d_derived_tbl_ptr = ^d_derived_tbl; - d_derived_tbl = record - { Basic tables: (element [0] of each array is unused) } - maxcode : array[0..18-1] of INT32; { largest code of length k (-1 if none) } - { (maxcode[17] is a sentinel to ensure jpeg_huff_decode terminates) } - valoffset : array[0..17-1] of INT32; { huffval[] offset for codes of length k } - { valoffset[k] = huffval[] index of 1st symbol of code length k, less - the smallest code of length k; so given a code of length k, the - corresponding symbol is huffval[code + valoffset[k]] } - - { Link to public Huffman table (needed only in jpeg_huff_decode) } - pub : JHUFF_TBL_PTR; - - { Lookahead tables: indexed by the next HUFF_LOOKAHEAD bits of - the input data stream. If the next Huffman code is no more - than HUFF_LOOKAHEAD bits long, we can obtain its length and - the corresponding symbol directly from these tables. } - - look_nbits : array[0..(1 shl HUFF_LOOKAHEAD)-1] of int; - { # bits, or 0 if too long } - look_sym : array[0..(1 shl HUFF_LOOKAHEAD)-1] of UINT8; - { symbol, or unused } - end; - -{ Fetching the next N bits from the input stream is a time-critical operation - for the Huffman decoders. We implement it with a combination of inline - macros and out-of-line subroutines. Note that N (the number of bits - demanded at one time) never exceeds 15 for JPEG use. - - We read source bytes into get_buffer and dole out bits as needed. - If get_buffer already contains enough bits, they are fetched in-line - by the macros CHECK_BIT_BUFFER and GET_BITS. When there aren't enough - bits, jpeg_fill_bit_buffer is called; it will attempt to fill get_buffer - as full as possible (not just to the number of bits needed; this - prefetching reduces the overhead cost of calling jpeg_fill_bit_buffer). - Note that jpeg_fill_bit_buffer may return FALSE to indicate suspension. - On TRUE return, jpeg_fill_bit_buffer guarantees that get_buffer contains - at least the requested number of bits --- dummy zeroes are inserted if - necessary. } - - -type - bit_buf_type = INT32 ; { type of bit-extraction buffer } -const - BIT_BUF_SIZE = 32; { size of buffer in bits } - -{ If long is > 32 bits on your machine, and shifting/masking longs is - reasonably fast, making bit_buf_type be long and setting BIT_BUF_SIZE - appropriately should be a win. Unfortunately we can't define the size - with something like #define BIT_BUF_SIZE (sizeof(bit_buf_type)*8) - because not all machines measure sizeof in 8-bit bytes. } - -type - bitread_perm_state = record { Bitreading state saved across MCUs } - get_buffer : bit_buf_type; { current bit-extraction buffer } - bits_left : int; { # of unused bits in it } - end; - -type - bitread_working_state = record - { Bitreading working state within an MCU } - { current data source location } - { We need a copy, rather than munging the original, in case of suspension } - next_input_byte : JOCTETptr; { => next byte to read from source } - bytes_in_buffer : size_t; { # of bytes remaining in source buffer } - { Bit input buffer --- note these values are kept in register variables, - not in this struct, inside the inner loops. } - - get_buffer : bit_buf_type; { current bit-extraction buffer } - bits_left : int; { # of unused bits in it } - { Pointer needed by jpeg_fill_bit_buffer } - cinfo : j_decompress_ptr; { back link to decompress master record } - end; - -{ Module initialization routine for Huffman entropy decoding. } - -{GLOBAL} -procedure jinit_huff_decoder (cinfo : j_decompress_ptr); - -{GLOBAL} -function jpeg_huff_decode(var state : bitread_working_state; - get_buffer : bit_buf_type; {register} - bits_left : int; {register} - htbl : d_derived_tbl_ptr; - min_bits : int) : int; - -{ Compute the derived values for a Huffman table. - Note this is also used by jdphuff.c. } - -{GLOBAL} -procedure jpeg_make_d_derived_tbl (cinfo : j_decompress_ptr; - isDC : boolean; - tblno : int; - var pdtbl : d_derived_tbl_ptr); - -{ Load up the bit buffer to a depth of at least nbits } - -function jpeg_fill_bit_buffer (var state : bitread_working_state; - get_buffer : bit_buf_type; {register} - bits_left : int; {register} - nbits : int) : boolean; - -implementation - -{$IFDEF MACRO} - -{ Macros to declare and load/save bitread local variables. } -{$define BITREAD_STATE_VARS} - get_buffer : bit_buf_type ; {register} - bits_left : int; {register} - br_state : bitread_working_state; - -{$define BITREAD_LOAD_STATE(cinfop,permstate)} - br_state.cinfo := cinfop; - br_state.next_input_byte := cinfop^.src^.next_input_byte; - br_state.bytes_in_buffer := cinfop^.src^.bytes_in_buffer; - get_buffer := permstate.get_buffer; - bits_left := permstate.bits_left; - -{$define BITREAD_SAVE_STATE(cinfop,permstate) } - cinfop^.src^.next_input_byte := br_state.next_input_byte; - cinfop^.src^.bytes_in_buffer := br_state.bytes_in_buffer; - permstate.get_buffer := get_buffer; - permstate.bits_left := bits_left; - - -{ These macros provide the in-line portion of bit fetching. - Use CHECK_BIT_BUFFER to ensure there are N bits in get_buffer - before using GET_BITS, PEEK_BITS, or DROP_BITS. - The variables get_buffer and bits_left are assumed to be locals, - but the state struct might not be (jpeg_huff_decode needs this). - CHECK_BIT_BUFFER(state,n,action); - Ensure there are N bits in get_buffer; if suspend, take action. - val = GET_BITS(n); - Fetch next N bits. - val = PEEK_BITS(n); - Fetch next N bits without removing them from the buffer. - DROP_BITS(n); - Discard next N bits. - The value N should be a simple variable, not an expression, because it - is evaluated multiple times. } - - -{$define CHECK_BIT_BUFFER(state,nbits,action)} - if (bits_left < (nbits)) then - begin - if (not jpeg_fill_bit_buffer(&(state),get_buffer,bits_left,nbits)) then - begin - action; - exit; - end; - get_buffer := state.get_buffer; - bits_left := state.bits_left; - end; - - -{$define GET_BITS(nbits)} - Dec(bits_left, (nbits)); - ( (int(get_buffer shr bits_left)) and ( pred(1 shl (nbits)) ) ) - -{$define PEEK_BITS(nbits)} - int(get_buffer shr (bits_left - (nbits))) and pred(1 shl (nbits)) - -{$define DROP_BITS(nbits)} - Dec(bits_left, nbits); - - - - -{ Code for extracting next Huffman-coded symbol from input bit stream. - Again, this is time-critical and we make the main paths be macros. - - We use a lookahead table to process codes of up to HUFF_LOOKAHEAD bits - without looping. Usually, more than 95% of the Huffman codes will be 8 - or fewer bits long. The few overlength codes are handled with a loop, - which need not be inline code. - - Notes about the HUFF_DECODE macro: - 1. Near the end of the data segment, we may fail to get enough bits - for a lookahead. In that case, we do it the hard way. - 2. If the lookahead table contains no entry, the next code must be - more than HUFF_LOOKAHEAD bits long. - 3. jpeg_huff_decode returns -1 if forced to suspend. } - - - - -macro HUFF_DECODE(s,br_state,htbl,return FALSE,slowlabel); -label showlabel; -var - nb, look : int; {register} -begin - if (bits_left < HUFF_LOOKAHEAD) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then - begin - decode_mcu := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - if (bits_left < HUFF_LOOKAHEAD) then - begin - nb := 1; - goto slowlabel; - end; - end; - {look := PEEK_BITS(HUFF_LOOKAHEAD);} - look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and - pred(1 shl HUFF_LOOKAHEAD); - - nb := htbl^.look_nbits[look]; - if (nb <> 0) then - begin - {DROP_BITS(nb);} - Dec(bits_left, nb); - - s := htbl^.look_sym[look]; - end - else - begin - nb := HUFF_LOOKAHEAD+1; -slowlabel: - s := jpeg_huff_decode(br_state,get_buffer,bits_left,htbl,nb)); - if (s < 0) then - begin - result := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; -end; - - -{$ENDIF} {MACRO} - -{ Expanded entropy decoder object for Huffman decoding. - - The savable_state subrecord contains fields that change within an MCU, - but must not be updated permanently until we complete the MCU. } - -type - savable_state = record - last_dc_val : array[0..MAX_COMPS_IN_SCAN-1] of int; { last DC coef for each component } - end; - - -type - huff_entropy_ptr = ^huff_entropy_decoder; - huff_entropy_decoder = record - pub : jpeg_entropy_decoder; { public fields } - - { These fields are loaded into local variables at start of each MCU. - In case of suspension, we exit WITHOUT updating them. } - - bitstate : bitread_perm_state; { Bit buffer at start of MCU } - saved : savable_state; { Other state at start of MCU } - - { These fields are NOT loaded into local working state. } - restarts_to_go : uInt; { MCUs left in this restart interval } - - { Pointers to derived tables (these workspaces have image lifespan) } - dc_derived_tbls : array[0..NUM_HUFF_TBLS] of d_derived_tbl_ptr; - ac_derived_tbls : array[0..NUM_HUFF_TBLS] of d_derived_tbl_ptr; - - { Precalculated info set up by start_pass for use in decode_mcu: } - - { Pointers to derived tables to be used for each block within an MCU } - dc_cur_tbls : array[0..D_MAX_BLOCKS_IN_MCU-1] of d_derived_tbl_ptr; - ac_cur_tbls : array[0..D_MAX_BLOCKS_IN_MCU-1] of d_derived_tbl_ptr; - { Whether we care about the DC and AC coefficient values for each block } - dc_needed : array[0..D_MAX_BLOCKS_IN_MCU-1] of boolean; - ac_needed : array[0..D_MAX_BLOCKS_IN_MCU-1] of boolean; - end; - - - -{ Initialize for a Huffman-compressed scan. } - -{METHODDEF} -procedure start_pass_huff_decoder (cinfo : j_decompress_ptr); -var - entropy : huff_entropy_ptr; - ci, blkn, dctbl, actbl : int; - compptr : jpeg_component_info_ptr; -begin - entropy := huff_entropy_ptr (cinfo^.entropy); - - { Check that the scan parameters Ss, Se, Ah/Al are OK for sequential JPEG. - This ought to be an error condition, but we make it a warning because - there are some baseline files out there with all zeroes in these bytes. } - - if (cinfo^.Ss <> 0) or (cinfo^.Se <> DCTSIZE2-1) or - (cinfo^.Ah <> 0) or (cinfo^.Al <> 0) then - WARNMS(j_common_ptr(cinfo), JWRN_NOT_SEQUENTIAL); - - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - dctbl := compptr^.dc_tbl_no; - actbl := compptr^.ac_tbl_no; - { Compute derived values for Huffman tables } - { We may do this more than once for a table, but it's not expensive } - jpeg_make_d_derived_tbl(cinfo, TRUE, dctbl, - entropy^.dc_derived_tbls[dctbl]); - jpeg_make_d_derived_tbl(cinfo, FALSE, actbl, - entropy^.ac_derived_tbls[actbl]); - { Initialize DC predictions to 0 } - entropy^.saved.last_dc_val[ci] := 0; - end; - - { Precalculate decoding info for each block in an MCU of this scan } - for blkn := 0 to pred(cinfo^.blocks_in_MCU) do - begin - ci := cinfo^.MCU_membership[blkn]; - compptr := cinfo^.cur_comp_info[ci]; - { Precalculate which table to use for each block } - entropy^.dc_cur_tbls[blkn] := entropy^.dc_derived_tbls[compptr^.dc_tbl_no]; - entropy^.ac_cur_tbls[blkn] := entropy^.ac_derived_tbls[compptr^.ac_tbl_no]; - { Decide whether we really care about the coefficient values } - if (compptr^.component_needed) then - begin - entropy^.dc_needed[blkn] := TRUE; - { we don't need the ACs if producing a 1/8th-size image } - entropy^.ac_needed[blkn] := (compptr^.DCT_scaled_size > 1); - end - else - begin - entropy^.ac_needed[blkn] := FALSE; - entropy^.dc_needed[blkn] := FALSE; - end; - end; - - { Initialize bitread state variables } - entropy^.bitstate.bits_left := 0; - entropy^.bitstate.get_buffer := 0; { unnecessary, but keeps Purify quiet } - entropy^.pub.insufficient_data := FALSE; - - { Initialize restart counter } - entropy^.restarts_to_go := cinfo^.restart_interval; -end; - - -{ Compute the derived values for a Huffman table. - This routine also performs some validation checks on the table. - - Note this is also used by jdphuff.c. } - -{GLOBAL} -procedure jpeg_make_d_derived_tbl (cinfo : j_decompress_ptr; - isDC : boolean; - tblno : int; - var pdtbl : d_derived_tbl_ptr); -var - htbl : JHUFF_TBL_PTR; - dtbl : d_derived_tbl_ptr; - p, i, l, si, numsymbols : int; - lookbits, ctr : int; - huffsize : array[0..257-1] of byte; - huffcode : array[0..257-1] of uInt; - code : uInt; -var - sym : int; -begin - { Note that huffsize[] and huffcode[] are filled in code-length order, - paralleling the order of the symbols themselves in htbl^.huffval[]. } - - { Find the input Huffman table } - if (tblno < 0) or (tblno >= NUM_HUFF_TBLS) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno); - if isDC then - htbl := cinfo^.dc_huff_tbl_ptrs[tblno] - else - htbl := cinfo^.ac_huff_tbl_ptrs[tblno]; - if (htbl = NIL) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno); - - { Allocate a workspace if we haven't already done so. } - if (pdtbl = NIL) then - pdtbl := d_derived_tbl_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(d_derived_tbl)) ); - dtbl := pdtbl; - dtbl^.pub := htbl; { fill in back link } - - { Figure C.1: make table of Huffman code length for each symbol } - - p := 0; - for l := 1 to 16 do - begin - i := int(htbl^.bits[l]); - if (i < 0) or (p + i > 256) then { protect against table overrun } - ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); - while (i > 0) do - begin - huffsize[p] := byte(l); - Inc(p); - Dec(i); - end; - end; - huffsize[p] := 0; - numsymbols := p; - - { Figure C.2: generate the codes themselves } - { We also validate that the counts represent a legal Huffman code tree. } - - code := 0; - si := huffsize[0]; - p := 0; - while (huffsize[p] <> 0) do - begin - while (( int (huffsize[p]) ) = si) do - begin - huffcode[p] := code; - Inc(p); - Inc(code); - end; - { code is now 1 more than the last code used for codelength si; but - it must still fit in si bits, since no code is allowed to be all ones. } - - if (INT32(code) >= (INT32(1) shl si)) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); - - code := code shl 1; - Inc(si); - end; - - { Figure F.15: generate decoding tables for bit-sequential decoding } - - p := 0; - for l := 1 to 16 do - begin - if (htbl^.bits[l] <> 0) then - begin - { valoffset[l] = huffval[] index of 1st symbol of code length l, - minus the minimum code of length l } - - dtbl^.valoffset[l] := INT32(p) - INT32(huffcode[p]); - Inc(p, htbl^.bits[l]); - dtbl^.maxcode[l] := huffcode[p-1]; { maximum code of length l } - end - else - begin - dtbl^.maxcode[l] := -1; { -1 if no codes of this length } - end; - end; - dtbl^.maxcode[17] := long($FFFFF); { ensures jpeg_huff_decode terminates } - - { Compute lookahead tables to speed up decoding. - First we set all the table entries to 0, indicating "too long"; - then we iterate through the Huffman codes that are short enough and - fill in all the entries that correspond to bit sequences starting - with that code. } - - MEMZERO(@dtbl^.look_nbits, SIZEOF(dtbl^.look_nbits)); - - p := 0; - for l := 1 to HUFF_LOOKAHEAD do - begin - for i := 1 to int (htbl^.bits[l]) do - begin - { l := current code's length, p := its index in huffcode[] & huffval[]. } - { Generate left-justified code followed by all possible bit sequences } - lookbits := huffcode[p] shl (HUFF_LOOKAHEAD-l); - for ctr := pred(1 shl (HUFF_LOOKAHEAD-l)) downto 0 do - begin - dtbl^.look_nbits[lookbits] := l; - dtbl^.look_sym[lookbits] := htbl^.huffval[p]; - Inc(lookbits); - end; - Inc(p); - end; - end; - - { Validate symbols as being reasonable. - For AC tables, we make no check, but accept all byte values 0..255. - For DC tables, we require the symbols to be in range 0..15. - (Tighter bounds could be applied depending on the data depth and mode, - but this is sufficient to ensure safe decoding.) } - - if (isDC) then - begin - for i := 0 to pred(numsymbols) do - begin - sym := htbl^.huffval[i]; - if (sym < 0) or (sym > 15) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); - end; - end; -end; - - -{ Out-of-line code for bit fetching (shared with jdphuff.c). - See jdhuff.h for info about usage. - Note: current values of get_buffer and bits_left are passed as parameters, - but are returned in the corresponding fields of the state struct. - - On most machines MIN_GET_BITS should be 25 to allow the full 32-bit width - of get_buffer to be used. (On machines with wider words, an even larger - buffer could be used.) However, on some machines 32-bit shifts are - quite slow and take time proportional to the number of places shifted. - (This is true with most PC compilers, for instance.) In this case it may - be a win to set MIN_GET_BITS to the minimum value of 15. This reduces the - average shift distance at the cost of more calls to jpeg_fill_bit_buffer. } - -{$ifdef SLOW_SHIFT_32} -const - MIN_GET_BITS = 15; { minimum allowable value } -{$else} -const - MIN_GET_BITS = (BIT_BUF_SIZE-7); -{$endif} - - -{GLOBAL} -function jpeg_fill_bit_buffer (var state : bitread_working_state; - {register} get_buffer : bit_buf_type; - {register} bits_left : int; - nbits : int) : boolean; -label - no_more_bytes; -{ Load up the bit buffer to a depth of at least nbits } -var - { Copy heavily used state fields into locals (hopefully registers) } - {register} next_input_byte : {const} JOCTETptr; - {register} bytes_in_buffer : size_t; -var - {register} c : int; -var - cinfo : j_decompress_ptr; -begin - next_input_byte := state.next_input_byte; - bytes_in_buffer := state.bytes_in_buffer; - cinfo := state.cinfo; - - { Attempt to load at least MIN_GET_BITS bits into get_buffer. } - { (It is assumed that no request will be for more than that many bits.) } - { We fail to do so only if we hit a marker or are forced to suspend. } - - if (cinfo^.unread_marker = 0) then { cannot advance past a marker } - begin - while (bits_left < MIN_GET_BITS) do - begin - { Attempt to read a byte } - if (bytes_in_buffer = 0) then - begin - if not cinfo^.src^.fill_input_buffer(cinfo) then - begin - jpeg_fill_bit_buffer := FALSE; - exit; - end; - next_input_byte := cinfo^.src^.next_input_byte; - bytes_in_buffer := cinfo^.src^.bytes_in_buffer; - end; - Dec(bytes_in_buffer); - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - - { If it's $FF, check and discard stuffed zero byte } - if (c = $FF) then - begin - { Loop here to discard any padding FF's on terminating marker, - so that we can save a valid unread_marker value. NOTE: we will - accept multiple FF's followed by a 0 as meaning a single FF data - byte. This data pattern is not valid according to the standard. } - - repeat - if (bytes_in_buffer = 0) then - begin - if (not state.cinfo^.src^.fill_input_buffer (state.cinfo)) then - begin - jpeg_fill_bit_buffer := FALSE; - exit; - end; - next_input_byte := state.cinfo^.src^.next_input_byte; - bytes_in_buffer := state.cinfo^.src^.bytes_in_buffer; - end; - Dec(bytes_in_buffer); - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - Until (c <> $FF); - - if (c = 0) then - begin - { Found FF/00, which represents an FF data byte } - c := $FF; - end - else - begin - { Oops, it's actually a marker indicating end of compressed data. - Save the marker code for later use. - Fine point: it might appear that we should save the marker into - bitread working state, not straight into permanent state. But - once we have hit a marker, we cannot need to suspend within the - current MCU, because we will read no more bytes from the data - source. So it is OK to update permanent state right away. } - - cinfo^.unread_marker := c; - { See if we need to insert some fake zero bits. } - goto no_more_bytes; - end; - end; - - { OK, load c into get_buffer } - get_buffer := (get_buffer shl 8) or c; - Inc(bits_left, 8); - end { end while } - end - else - begin - no_more_bytes: - { We get here if we've read the marker that terminates the compressed - data segment. There should be enough bits in the buffer register - to satisfy the request; if so, no problem. } - - if (nbits > bits_left) then - begin - { Uh-oh. Report corrupted data to user and stuff zeroes into - the data stream, so that we can produce some kind of image. - We use a nonvolatile flag to ensure that only one warning message - appears per data segment. } - - if not cinfo^.entropy^.insufficient_data then - begin - WARNMS(j_common_ptr(cinfo), JWRN_HIT_MARKER); - cinfo^.entropy^.insufficient_data := TRUE; - end; - { Fill the buffer with zero bits } - get_buffer := get_buffer shl (MIN_GET_BITS - bits_left); - bits_left := MIN_GET_BITS; - end; - end; - - { Unload the local registers } - state.next_input_byte := next_input_byte; - state.bytes_in_buffer := bytes_in_buffer; - state.get_buffer := get_buffer; - state.bits_left := bits_left; - - jpeg_fill_bit_buffer := TRUE; -end; - - -{ Out-of-line code for Huffman code decoding. - See jdhuff.h for info about usage. } - -{GLOBAL} -function jpeg_huff_decode (var state : bitread_working_state; - {register} get_buffer : bit_buf_type; - {register} bits_left : int; - htbl : d_derived_tbl_ptr; - min_bits : int) : int; -var - {register} l : int; - {register} code : INT32; -begin - l := min_bits; - - { HUFF_DECODE has determined that the code is at least min_bits } - { bits long, so fetch that many bits in one swoop. } - - {CHECK_BIT_BUFFER(state, l, return -1);} - if (bits_left < l) then - begin - if (not jpeg_fill_bit_buffer(state, get_buffer, bits_left, l)) then - begin - jpeg_huff_decode := -1; - exit; - end; - get_buffer := state.get_buffer; - bits_left := state.bits_left; - end; - - {code := GET_BITS(l);} - Dec(bits_left, l); - code := (int(get_buffer shr bits_left)) and ( pred(1 shl l) ); - - { Collect the rest of the Huffman code one bit at a time. } - { This is per Figure F.16 in the JPEG spec. } - - while (code > htbl^.maxcode[l]) do - begin - code := code shl 1; - {CHECK_BIT_BUFFER(state, 1, return -1);} - if (bits_left < 1) then - begin - if (not jpeg_fill_bit_buffer(state, get_buffer, bits_left, 1)) then - begin - jpeg_huff_decode := -1; - exit; - end; - get_buffer := state.get_buffer; - bits_left := state.bits_left; - end; - - {code := code or GET_BITS(1);} - Dec(bits_left); - code := code or ( (int(get_buffer shr bits_left)) and pred(1 shl 1) ); - - Inc(l); - end; - - { Unload the local registers } - state.get_buffer := get_buffer; - state.bits_left := bits_left; - - { With garbage input we may reach the sentinel value l := 17. } - - if (l > 16) then - begin - WARNMS(j_common_ptr(state.cinfo), JWRN_HUFF_BAD_CODE); - jpeg_huff_decode := 0; { fake a zero as the safest result } - exit; - end; - - jpeg_huff_decode := htbl^.pub^.huffval[ int (code + htbl^.valoffset[l]) ]; -end; - - -{ Figure F.12: extend sign bit. - On some machines, a shift and add will be faster than a table lookup. } - -{$ifdef AVOID_TABLES} - -#define HUFF_EXTEND(x,s) ((x) < (1<<((s)-1)) ? (x) + (((-1)<<(s)) + 1) : (x)) - -{$else} - -{$define HUFF_EXTEND(x,s) - if (x < extend_test[s]) then - := x + extend_offset[s] - else - x;} - -const - extend_test : array[0..16-1] of int = { entry n is 2**(n-1) } - ($0000, $0001, $0002, $0004, $0008, $0010, $0020, $0040, - $0080, $0100, $0200, $0400, $0800, $1000, $2000, $4000); - -const - extend_offset : array[0..16-1] of int = { entry n is (-1 << n) + 1 } -(0, ((-1) shl 1) + 1, ((-1) shl 2) + 1, ((-1) shl 3) + 1, ((-1) shl 4) + 1, - ((-1) shl 5) + 1, ((-1) shl 6) + 1, ((-1) shl 7) + 1, ((-1) shl 8) + 1, - ((-1) shl 9) + 1, ((-1) shl 10) + 1, ((-1) shl 11) + 1,((-1) shl 12) + 1, - ((-1) shl 13) + 1, ((-1) shl 14) + 1, ((-1) shl 15) + 1); - -{$endif} { AVOID_TABLES } - - -{ Check for a restart marker & resynchronize decoder. - Returns FALSE if must suspend. } - -{LOCAL} -function process_restart (cinfo : j_decompress_ptr) : boolean; -var - entropy : huff_entropy_ptr; - ci : int; -begin - entropy := huff_entropy_ptr (cinfo^.entropy); - - { Throw away any unused bits remaining in bit buffer; } - { include any full bytes in next_marker's count of discarded bytes } - Inc(cinfo^.marker^.discarded_bytes, entropy^.bitstate.bits_left div 8); - entropy^.bitstate.bits_left := 0; - - { Advance past the RSTn marker } - if (not cinfo^.marker^.read_restart_marker (cinfo)) then - begin - process_restart := FALSE; - exit; - end; - - { Re-initialize DC predictions to 0 } - for ci := 0 to pred(cinfo^.comps_in_scan) do - entropy^.saved.last_dc_val[ci] := 0; - - { Reset restart counter } - entropy^.restarts_to_go := cinfo^.restart_interval; - - { Reset out-of-data flag, unless read_restart_marker left us smack up - against a marker. In that case we will end up treating the next data - segment as empty, and we can avoid producing bogus output pixels by - leaving the flag set. } - - if (cinfo^.unread_marker = 0) then - entropy^.pub.insufficient_data := FALSE; - - process_restart := TRUE; -end; - - -{ Decode and return one MCU's worth of Huffman-compressed coefficients. - The coefficients are reordered from zigzag order into natural array order, - but are not dequantized. - - The i'th block of the MCU is stored into the block pointed to by - MCU_data[i]. WE ASSUME THIS AREA HAS BEEN ZEROED BY THE CALLER. - (Wholesale zeroing is usually a little faster than retail...) - - Returns FALSE if data source requested suspension. In that case no - changes have been made to permanent state. (Exception: some output - coefficients may already have been assigned. This is harmless for - this module, since we'll just re-assign them on the next call.) } - -{METHODDEF} -function decode_mcu (cinfo : j_decompress_ptr; - var MCU_data : array of JBLOCKROW) : boolean; -label - label1, label2, label3; -var - entropy : huff_entropy_ptr; - {register} s, k, r : int; - blkn, ci : int; - block : JBLOCK_PTR; - {BITREAD_STATE_VARS} - get_buffer : bit_buf_type ; {register} - bits_left : int; {register} - br_state : bitread_working_state; - - state : savable_state; - dctbl : d_derived_tbl_ptr; - actbl : d_derived_tbl_ptr; -var - nb, look : int; {register} -begin - entropy := huff_entropy_ptr (cinfo^.entropy); - - { Process restart marker if needed; may have to suspend } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - if (not process_restart(cinfo)) then - begin - decode_mcu := FALSE; - exit; - end; - end; - - { If we've run out of data, just leave the MCU set to zeroes. - This way, we return uniform gray for the remainder of the segment. } - - if not entropy^.pub.insufficient_data then - begin - - { Load up working state } - {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);} - br_state.cinfo := cinfo; - br_state.next_input_byte := cinfo^.src^.next_input_byte; - br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer; - get_buffer := entropy^.bitstate.get_buffer; - bits_left := entropy^.bitstate.bits_left; - - {ASSIGN_STATE(state, entropy^.saved);} - state := entropy^.saved; - - { Outer loop handles each block in the MCU } - - for blkn := 0 to pred(cinfo^.blocks_in_MCU) do - begin - block := JBLOCK_PTR(MCU_data[blkn]); - dctbl := entropy^.dc_cur_tbls[blkn]; - actbl := entropy^.ac_cur_tbls[blkn]; - - { Decode a single block's worth of coefficients } - - { Section F.2.2.1: decode the DC coefficient difference } - {HUFF_DECODE(s, br_state, dctbl, return FALSE, label1);} - if (bits_left < HUFF_LOOKAHEAD) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then - begin - decode_mcu := False; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - if (bits_left < HUFF_LOOKAHEAD) then - begin - nb := 1; - goto label1; - end; - end; - {look := PEEK_BITS(HUFF_LOOKAHEAD);} - look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and - pred(1 shl HUFF_LOOKAHEAD); - - nb := dctbl^.look_nbits[look]; - if (nb <> 0) then - begin - {DROP_BITS(nb);} - Dec(bits_left, nb); - - s := dctbl^.look_sym[look]; - end - else - begin - nb := HUFF_LOOKAHEAD+1; - label1: - s := jpeg_huff_decode(br_state,get_buffer,bits_left,dctbl,nb); - if (s < 0) then - begin - decode_mcu := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - if (s <> 0) then - begin - {CHECK_BIT_BUFFER(br_state, s, return FALSE);} - if (bits_left < s) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then - begin - decode_mcu := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {r := GET_BITS(s);} - Dec(bits_left, s); - r := ( int(get_buffer shr bits_left)) and ( pred(1 shl s) ); - - {s := HUFF_EXTEND(r, s);} - if (r < extend_test[s]) then - s := r + extend_offset[s] - else - s := r; - end; - - if (entropy^.dc_needed[blkn]) then - begin - { Convert DC difference to actual value, update last_dc_val } - ci := cinfo^.MCU_membership[blkn]; - Inc(s, state.last_dc_val[ci]); - state.last_dc_val[ci] := s; - { Output the DC coefficient (assumes jpeg_natural_order[0] := 0) } - block^[0] := JCOEF (s); - end; - - if (entropy^.ac_needed[blkn]) then - begin - - { Section F.2.2.2: decode the AC coefficients } - { Since zeroes are skipped, output area must be cleared beforehand } - k := 1; - while (k < DCTSIZE2) do { Nomssi: k is incr. in the loop } - begin - {HUFF_DECODE(s, br_state, actbl, return FALSE, label2);} - if (bits_left < HUFF_LOOKAHEAD) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then - begin - decode_mcu := False; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - if (bits_left < HUFF_LOOKAHEAD) then - begin - nb := 1; - goto label2; - end; - end; - {look := PEEK_BITS(HUFF_LOOKAHEAD);} - look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and - pred(1 shl HUFF_LOOKAHEAD); - - nb := actbl^.look_nbits[look]; - if (nb <> 0) then - begin - {DROP_BITS(nb);} - Dec(bits_left, nb); - - s := actbl^.look_sym[look]; - end - else - begin - nb := HUFF_LOOKAHEAD+1; - label2: - s := jpeg_huff_decode(br_state,get_buffer,bits_left,actbl,nb); - if (s < 0) then - begin - decode_mcu := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - r := s shr 4; - s := s and 15; - - if (s <> 0) then - begin - Inc(k, r); - {CHECK_BIT_BUFFER(br_state, s, return FALSE);} - if (bits_left < s) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then - begin - decode_mcu := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {r := GET_BITS(s);} - Dec(bits_left, s); - r := (int(get_buffer shr bits_left)) and ( pred(1 shl s) ); - - {s := HUFF_EXTEND(r, s);} - if (r < extend_test[s]) then - s := r + extend_offset[s] - else - s := r; - { Output coefficient in natural (dezigzagged) order. - Note: the extra entries in jpeg_natural_order[] will save us - if k >= DCTSIZE2, which could happen if the data is corrupted. } - - block^[jpeg_natural_order[k]] := JCOEF (s); - end - else - begin - if (r <> 15) then - break; - Inc(k, 15); - end; - Inc(k); - end; - end - else - begin - - { Section F.2.2.2: decode the AC coefficients } - { In this path we just discard the values } - k := 1; - while (k < DCTSIZE2) do - begin - {HUFF_DECODE(s, br_state, actbl, return FALSE, label3);} - if (bits_left < HUFF_LOOKAHEAD) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then - begin - decode_mcu := False; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - if (bits_left < HUFF_LOOKAHEAD) then - begin - nb := 1; - goto label3; - end; - end; - {look := PEEK_BITS(HUFF_LOOKAHEAD);} - look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and - pred(1 shl HUFF_LOOKAHEAD); - - nb := actbl^.look_nbits[look]; - if (nb <> 0) then - begin - {DROP_BITS(nb);} - Dec(bits_left, nb); - - s := actbl^.look_sym[look]; - end - else - begin - nb := HUFF_LOOKAHEAD+1; - label3: - s := jpeg_huff_decode(br_state,get_buffer,bits_left,actbl,nb); - if (s < 0) then - begin - decode_mcu := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - r := s shr 4; - s := s and 15; - - if (s <> 0) then - begin - Inc(k, r); - {CHECK_BIT_BUFFER(br_state, s, return FALSE);} - if (bits_left < s) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then - begin - decode_mcu := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {DROP_BITS(s);} - Dec(bits_left, s); - end - else - begin - if (r <> 15) then - break; - Inc(k, 15); - end; - Inc(k); - end; - - end; - end; - - { Completed MCU, so update state } - {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);} - cinfo^.src^.next_input_byte := br_state.next_input_byte; - cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer; - entropy^.bitstate.get_buffer := get_buffer; - entropy^.bitstate.bits_left := bits_left; - - {ASSIGN_STATE(entropy^.saved, state);} - entropy^.saved := state; - - end; - - { Account for restart interval (no-op if not using restarts) } - Dec(entropy^.restarts_to_go); - - decode_mcu := TRUE; -end; - - -{ Module initialization routine for Huffman entropy decoding. } - -{GLOBAL} -procedure jinit_huff_decoder (cinfo : j_decompress_ptr); -var - entropy : huff_entropy_ptr; - i : int; -begin - entropy := huff_entropy_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(huff_entropy_decoder)) ); - cinfo^.entropy := jpeg_entropy_decoder_ptr (entropy); - entropy^.pub.start_pass := start_pass_huff_decoder; - entropy^.pub.decode_mcu := decode_mcu; - - { Mark tables unallocated } - for i := 0 to pred(NUM_HUFF_TBLS) do - begin - entropy^.dc_derived_tbls[i] := NIL; - entropy^.ac_derived_tbls[i] := NIL; - end; -end; - -end. +unit imjdhuff; + +{ This file contains declarations for Huffman entropy decoding routines + that are shared between the sequential decoder (jdhuff.c) and the + progressive decoder (jdphuff.c). No other modules need to see these. } + +{ This file contains Huffman entropy decoding routines. + + Much of the complexity here has to do with supporting input suspension. + If the data source module demands suspension, we want to be able to back + up to the start of the current MCU. To do this, we copy state variables + into local working storage, and update them back to the permanent + storage only upon successful completion of an MCU. } + +{ Original: jdhuff.h+jdhuff.c; Copyright (C) 1991-1997, Thomas G. Lane. } + + + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjutils, + imjpeglib; + + +{ Declarations shared with jdphuff.c } + + + +{ Derived data constructed for each Huffman table } + +const + HUFF_LOOKAHEAD = 8; { # of bits of lookahead } + +type + d_derived_tbl_ptr = ^d_derived_tbl; + d_derived_tbl = record + { Basic tables: (element [0] of each array is unused) } + maxcode : array[0..18-1] of INT32; { largest code of length k (-1 if none) } + { (maxcode[17] is a sentinel to ensure jpeg_huff_decode terminates) } + valoffset : array[0..17-1] of INT32; { huffval[] offset for codes of length k } + { valoffset[k] = huffval[] index of 1st symbol of code length k, less + the smallest code of length k; so given a code of length k, the + corresponding symbol is huffval[code + valoffset[k]] } + + { Link to public Huffman table (needed only in jpeg_huff_decode) } + pub : JHUFF_TBL_PTR; + + { Lookahead tables: indexed by the next HUFF_LOOKAHEAD bits of + the input data stream. If the next Huffman code is no more + than HUFF_LOOKAHEAD bits long, we can obtain its length and + the corresponding symbol directly from these tables. } + + look_nbits : array[0..(1 shl HUFF_LOOKAHEAD)-1] of int; + { # bits, or 0 if too long } + look_sym : array[0..(1 shl HUFF_LOOKAHEAD)-1] of UINT8; + { symbol, or unused } + end; + +{ Fetching the next N bits from the input stream is a time-critical operation + for the Huffman decoders. We implement it with a combination of inline + macros and out-of-line subroutines. Note that N (the number of bits + demanded at one time) never exceeds 15 for JPEG use. + + We read source bytes into get_buffer and dole out bits as needed. + If get_buffer already contains enough bits, they are fetched in-line + by the macros CHECK_BIT_BUFFER and GET_BITS. When there aren't enough + bits, jpeg_fill_bit_buffer is called; it will attempt to fill get_buffer + as full as possible (not just to the number of bits needed; this + prefetching reduces the overhead cost of calling jpeg_fill_bit_buffer). + Note that jpeg_fill_bit_buffer may return FALSE to indicate suspension. + On TRUE return, jpeg_fill_bit_buffer guarantees that get_buffer contains + at least the requested number of bits --- dummy zeroes are inserted if + necessary. } + + +type + bit_buf_type = INT32 ; { type of bit-extraction buffer } +const + BIT_BUF_SIZE = 32; { size of buffer in bits } + +{ If long is > 32 bits on your machine, and shifting/masking longs is + reasonably fast, making bit_buf_type be long and setting BIT_BUF_SIZE + appropriately should be a win. Unfortunately we can't define the size + with something like #define BIT_BUF_SIZE (sizeof(bit_buf_type)*8) + because not all machines measure sizeof in 8-bit bytes. } + +type + bitread_perm_state = record { Bitreading state saved across MCUs } + get_buffer : bit_buf_type; { current bit-extraction buffer } + bits_left : int; { # of unused bits in it } + end; + +type + bitread_working_state = record + { Bitreading working state within an MCU } + { current data source location } + { We need a copy, rather than munging the original, in case of suspension } + next_input_byte : JOCTETptr; { => next byte to read from source } + bytes_in_buffer : size_t; { # of bytes remaining in source buffer } + { Bit input buffer --- note these values are kept in register variables, + not in this struct, inside the inner loops. } + + get_buffer : bit_buf_type; { current bit-extraction buffer } + bits_left : int; { # of unused bits in it } + { Pointer needed by jpeg_fill_bit_buffer } + cinfo : j_decompress_ptr; { back link to decompress master record } + end; + +{ Module initialization routine for Huffman entropy decoding. } + +{GLOBAL} +procedure jinit_huff_decoder (cinfo : j_decompress_ptr); + +{GLOBAL} +function jpeg_huff_decode(var state : bitread_working_state; + get_buffer : bit_buf_type; {register} + bits_left : int; {register} + htbl : d_derived_tbl_ptr; + min_bits : int) : int; + +{ Compute the derived values for a Huffman table. + Note this is also used by jdphuff.c. } + +{GLOBAL} +procedure jpeg_make_d_derived_tbl (cinfo : j_decompress_ptr; + isDC : boolean; + tblno : int; + var pdtbl : d_derived_tbl_ptr); + +{ Load up the bit buffer to a depth of at least nbits } + +function jpeg_fill_bit_buffer (var state : bitread_working_state; + get_buffer : bit_buf_type; {register} + bits_left : int; {register} + nbits : int) : boolean; + +implementation + +{$IFDEF MACRO} + +{ Macros to declare and load/save bitread local variables. } +{$define BITREAD_STATE_VARS} + get_buffer : bit_buf_type ; {register} + bits_left : int; {register} + br_state : bitread_working_state; + +{$define BITREAD_LOAD_STATE(cinfop,permstate)} + br_state.cinfo := cinfop; + br_state.next_input_byte := cinfop^.src^.next_input_byte; + br_state.bytes_in_buffer := cinfop^.src^.bytes_in_buffer; + get_buffer := permstate.get_buffer; + bits_left := permstate.bits_left; + +{$define BITREAD_SAVE_STATE(cinfop,permstate) } + cinfop^.src^.next_input_byte := br_state.next_input_byte; + cinfop^.src^.bytes_in_buffer := br_state.bytes_in_buffer; + permstate.get_buffer := get_buffer; + permstate.bits_left := bits_left; + + +{ These macros provide the in-line portion of bit fetching. + Use CHECK_BIT_BUFFER to ensure there are N bits in get_buffer + before using GET_BITS, PEEK_BITS, or DROP_BITS. + The variables get_buffer and bits_left are assumed to be locals, + but the state struct might not be (jpeg_huff_decode needs this). + CHECK_BIT_BUFFER(state,n,action); + Ensure there are N bits in get_buffer; if suspend, take action. + val = GET_BITS(n); + Fetch next N bits. + val = PEEK_BITS(n); + Fetch next N bits without removing them from the buffer. + DROP_BITS(n); + Discard next N bits. + The value N should be a simple variable, not an expression, because it + is evaluated multiple times. } + + +{$define CHECK_BIT_BUFFER(state,nbits,action)} + if (bits_left < (nbits)) then + begin + if (not jpeg_fill_bit_buffer(&(state),get_buffer,bits_left,nbits)) then + begin + action; + exit; + end; + get_buffer := state.get_buffer; + bits_left := state.bits_left; + end; + + +{$define GET_BITS(nbits)} + Dec(bits_left, (nbits)); + ( (int(get_buffer shr bits_left)) and ( pred(1 shl (nbits)) ) ) + +{$define PEEK_BITS(nbits)} + int(get_buffer shr (bits_left - (nbits))) and pred(1 shl (nbits)) + +{$define DROP_BITS(nbits)} + Dec(bits_left, nbits); + + + + +{ Code for extracting next Huffman-coded symbol from input bit stream. + Again, this is time-critical and we make the main paths be macros. + + We use a lookahead table to process codes of up to HUFF_LOOKAHEAD bits + without looping. Usually, more than 95% of the Huffman codes will be 8 + or fewer bits long. The few overlength codes are handled with a loop, + which need not be inline code. + + Notes about the HUFF_DECODE macro: + 1. Near the end of the data segment, we may fail to get enough bits + for a lookahead. In that case, we do it the hard way. + 2. If the lookahead table contains no entry, the next code must be + more than HUFF_LOOKAHEAD bits long. + 3. jpeg_huff_decode returns -1 if forced to suspend. } + + + + +macro HUFF_DECODE(s,br_state,htbl,return FALSE,slowlabel); +label showlabel; +var + nb, look : int; {register} +begin + if (bits_left < HUFF_LOOKAHEAD) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then + begin + decode_mcu := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + if (bits_left < HUFF_LOOKAHEAD) then + begin + nb := 1; + goto slowlabel; + end; + end; + {look := PEEK_BITS(HUFF_LOOKAHEAD);} + look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and + pred(1 shl HUFF_LOOKAHEAD); + + nb := htbl^.look_nbits[look]; + if (nb <> 0) then + begin + {DROP_BITS(nb);} + Dec(bits_left, nb); + + s := htbl^.look_sym[look]; + end + else + begin + nb := HUFF_LOOKAHEAD+1; +slowlabel: + s := jpeg_huff_decode(br_state,get_buffer,bits_left,htbl,nb)); + if (s < 0) then + begin + result := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; +end; + + +{$ENDIF} {MACRO} + +{ Expanded entropy decoder object for Huffman decoding. + + The savable_state subrecord contains fields that change within an MCU, + but must not be updated permanently until we complete the MCU. } + +type + savable_state = record + last_dc_val : array[0..MAX_COMPS_IN_SCAN-1] of int; { last DC coef for each component } + end; + + +type + huff_entropy_ptr = ^huff_entropy_decoder; + huff_entropy_decoder = record + pub : jpeg_entropy_decoder; { public fields } + + { These fields are loaded into local variables at start of each MCU. + In case of suspension, we exit WITHOUT updating them. } + + bitstate : bitread_perm_state; { Bit buffer at start of MCU } + saved : savable_state; { Other state at start of MCU } + + { These fields are NOT loaded into local working state. } + restarts_to_go : uInt; { MCUs left in this restart interval } + + { Pointers to derived tables (these workspaces have image lifespan) } + dc_derived_tbls : array[0..NUM_HUFF_TBLS] of d_derived_tbl_ptr; + ac_derived_tbls : array[0..NUM_HUFF_TBLS] of d_derived_tbl_ptr; + + { Precalculated info set up by start_pass for use in decode_mcu: } + + { Pointers to derived tables to be used for each block within an MCU } + dc_cur_tbls : array[0..D_MAX_BLOCKS_IN_MCU-1] of d_derived_tbl_ptr; + ac_cur_tbls : array[0..D_MAX_BLOCKS_IN_MCU-1] of d_derived_tbl_ptr; + { Whether we care about the DC and AC coefficient values for each block } + dc_needed : array[0..D_MAX_BLOCKS_IN_MCU-1] of boolean; + ac_needed : array[0..D_MAX_BLOCKS_IN_MCU-1] of boolean; + end; + + + +{ Initialize for a Huffman-compressed scan. } + +{METHODDEF} +procedure start_pass_huff_decoder (cinfo : j_decompress_ptr); +var + entropy : huff_entropy_ptr; + ci, blkn, dctbl, actbl : int; + compptr : jpeg_component_info_ptr; +begin + entropy := huff_entropy_ptr (cinfo^.entropy); + + { Check that the scan parameters Ss, Se, Ah/Al are OK for sequential JPEG. + This ought to be an error condition, but we make it a warning because + there are some baseline files out there with all zeroes in these bytes. } + + if (cinfo^.Ss <> 0) or (cinfo^.Se <> DCTSIZE2-1) or + (cinfo^.Ah <> 0) or (cinfo^.Al <> 0) then + WARNMS(j_common_ptr(cinfo), JWRN_NOT_SEQUENTIAL); + + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + dctbl := compptr^.dc_tbl_no; + actbl := compptr^.ac_tbl_no; + { Compute derived values for Huffman tables } + { We may do this more than once for a table, but it's not expensive } + jpeg_make_d_derived_tbl(cinfo, TRUE, dctbl, + entropy^.dc_derived_tbls[dctbl]); + jpeg_make_d_derived_tbl(cinfo, FALSE, actbl, + entropy^.ac_derived_tbls[actbl]); + { Initialize DC predictions to 0 } + entropy^.saved.last_dc_val[ci] := 0; + end; + + { Precalculate decoding info for each block in an MCU of this scan } + for blkn := 0 to pred(cinfo^.blocks_in_MCU) do + begin + ci := cinfo^.MCU_membership[blkn]; + compptr := cinfo^.cur_comp_info[ci]; + { Precalculate which table to use for each block } + entropy^.dc_cur_tbls[blkn] := entropy^.dc_derived_tbls[compptr^.dc_tbl_no]; + entropy^.ac_cur_tbls[blkn] := entropy^.ac_derived_tbls[compptr^.ac_tbl_no]; + { Decide whether we really care about the coefficient values } + if (compptr^.component_needed) then + begin + entropy^.dc_needed[blkn] := TRUE; + { we don't need the ACs if producing a 1/8th-size image } + entropy^.ac_needed[blkn] := (compptr^.DCT_scaled_size > 1); + end + else + begin + entropy^.ac_needed[blkn] := FALSE; + entropy^.dc_needed[blkn] := FALSE; + end; + end; + + { Initialize bitread state variables } + entropy^.bitstate.bits_left := 0; + entropy^.bitstate.get_buffer := 0; { unnecessary, but keeps Purify quiet } + entropy^.pub.insufficient_data := FALSE; + + { Initialize restart counter } + entropy^.restarts_to_go := cinfo^.restart_interval; +end; + + +{ Compute the derived values for a Huffman table. + This routine also performs some validation checks on the table. + + Note this is also used by jdphuff.c. } + +{GLOBAL} +procedure jpeg_make_d_derived_tbl (cinfo : j_decompress_ptr; + isDC : boolean; + tblno : int; + var pdtbl : d_derived_tbl_ptr); +var + htbl : JHUFF_TBL_PTR; + dtbl : d_derived_tbl_ptr; + p, i, l, si, numsymbols : int; + lookbits, ctr : int; + huffsize : array[0..257-1] of byte; + huffcode : array[0..257-1] of uInt; + code : uInt; +var + sym : int; +begin + { Note that huffsize[] and huffcode[] are filled in code-length order, + paralleling the order of the symbols themselves in htbl^.huffval[]. } + + { Find the input Huffman table } + if (tblno < 0) or (tblno >= NUM_HUFF_TBLS) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno); + if isDC then + htbl := cinfo^.dc_huff_tbl_ptrs[tblno] + else + htbl := cinfo^.ac_huff_tbl_ptrs[tblno]; + if (htbl = NIL) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, tblno); + + { Allocate a workspace if we haven't already done so. } + if (pdtbl = NIL) then + pdtbl := d_derived_tbl_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(d_derived_tbl)) ); + dtbl := pdtbl; + dtbl^.pub := htbl; { fill in back link } + + { Figure C.1: make table of Huffman code length for each symbol } + + p := 0; + for l := 1 to 16 do + begin + i := int(htbl^.bits[l]); + if (i < 0) or (p + i > 256) then { protect against table overrun } + ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); + while (i > 0) do + begin + huffsize[p] := byte(l); + Inc(p); + Dec(i); + end; + end; + huffsize[p] := 0; + numsymbols := p; + + { Figure C.2: generate the codes themselves } + { We also validate that the counts represent a legal Huffman code tree. } + + code := 0; + si := huffsize[0]; + p := 0; + while (huffsize[p] <> 0) do + begin + while (( int (huffsize[p]) ) = si) do + begin + huffcode[p] := code; + Inc(p); + Inc(code); + end; + { code is now 1 more than the last code used for codelength si; but + it must still fit in si bits, since no code is allowed to be all ones. } + + if (INT32(code) >= (INT32(1) shl si)) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); + + code := code shl 1; + Inc(si); + end; + + { Figure F.15: generate decoding tables for bit-sequential decoding } + + p := 0; + for l := 1 to 16 do + begin + if (htbl^.bits[l] <> 0) then + begin + { valoffset[l] = huffval[] index of 1st symbol of code length l, + minus the minimum code of length l } + + dtbl^.valoffset[l] := INT32(p) - INT32(huffcode[p]); + Inc(p, htbl^.bits[l]); + dtbl^.maxcode[l] := huffcode[p-1]; { maximum code of length l } + end + else + begin + dtbl^.maxcode[l] := -1; { -1 if no codes of this length } + end; + end; + dtbl^.maxcode[17] := long($FFFFF); { ensures jpeg_huff_decode terminates } + + { Compute lookahead tables to speed up decoding. + First we set all the table entries to 0, indicating "too long"; + then we iterate through the Huffman codes that are short enough and + fill in all the entries that correspond to bit sequences starting + with that code. } + + MEMZERO(@dtbl^.look_nbits, SIZEOF(dtbl^.look_nbits)); + + p := 0; + for l := 1 to HUFF_LOOKAHEAD do + begin + for i := 1 to int (htbl^.bits[l]) do + begin + { l := current code's length, p := its index in huffcode[] & huffval[]. } + { Generate left-justified code followed by all possible bit sequences } + lookbits := huffcode[p] shl (HUFF_LOOKAHEAD-l); + for ctr := pred(1 shl (HUFF_LOOKAHEAD-l)) downto 0 do + begin + dtbl^.look_nbits[lookbits] := l; + dtbl^.look_sym[lookbits] := htbl^.huffval[p]; + Inc(lookbits); + end; + Inc(p); + end; + end; + + { Validate symbols as being reasonable. + For AC tables, we make no check, but accept all byte values 0..255. + For DC tables, we require the symbols to be in range 0..15. + (Tighter bounds could be applied depending on the data depth and mode, + but this is sufficient to ensure safe decoding.) } + + if (isDC) then + begin + for i := 0 to pred(numsymbols) do + begin + sym := htbl^.huffval[i]; + if (sym < 0) or (sym > 15) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); + end; + end; +end; + + +{ Out-of-line code for bit fetching (shared with jdphuff.c). + See jdhuff.h for info about usage. + Note: current values of get_buffer and bits_left are passed as parameters, + but are returned in the corresponding fields of the state struct. + + On most machines MIN_GET_BITS should be 25 to allow the full 32-bit width + of get_buffer to be used. (On machines with wider words, an even larger + buffer could be used.) However, on some machines 32-bit shifts are + quite slow and take time proportional to the number of places shifted. + (This is true with most PC compilers, for instance.) In this case it may + be a win to set MIN_GET_BITS to the minimum value of 15. This reduces the + average shift distance at the cost of more calls to jpeg_fill_bit_buffer. } + +{$ifdef SLOW_SHIFT_32} +const + MIN_GET_BITS = 15; { minimum allowable value } +{$else} +const + MIN_GET_BITS = (BIT_BUF_SIZE-7); +{$endif} + + +{GLOBAL} +function jpeg_fill_bit_buffer (var state : bitread_working_state; + {register} get_buffer : bit_buf_type; + {register} bits_left : int; + nbits : int) : boolean; +label + no_more_bytes; +{ Load up the bit buffer to a depth of at least nbits } +var + { Copy heavily used state fields into locals (hopefully registers) } + {register} next_input_byte : {const} JOCTETptr; + {register} bytes_in_buffer : size_t; +var + {register} c : int; +var + cinfo : j_decompress_ptr; +begin + next_input_byte := state.next_input_byte; + bytes_in_buffer := state.bytes_in_buffer; + cinfo := state.cinfo; + + { Attempt to load at least MIN_GET_BITS bits into get_buffer. } + { (It is assumed that no request will be for more than that many bits.) } + { We fail to do so only if we hit a marker or are forced to suspend. } + + if (cinfo^.unread_marker = 0) then { cannot advance past a marker } + begin + while (bits_left < MIN_GET_BITS) do + begin + { Attempt to read a byte } + if (bytes_in_buffer = 0) then + begin + if not cinfo^.src^.fill_input_buffer(cinfo) then + begin + jpeg_fill_bit_buffer := FALSE; + exit; + end; + next_input_byte := cinfo^.src^.next_input_byte; + bytes_in_buffer := cinfo^.src^.bytes_in_buffer; + end; + Dec(bytes_in_buffer); + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + + { If it's $FF, check and discard stuffed zero byte } + if (c = $FF) then + begin + { Loop here to discard any padding FF's on terminating marker, + so that we can save a valid unread_marker value. NOTE: we will + accept multiple FF's followed by a 0 as meaning a single FF data + byte. This data pattern is not valid according to the standard. } + + repeat + if (bytes_in_buffer = 0) then + begin + if (not state.cinfo^.src^.fill_input_buffer (state.cinfo)) then + begin + jpeg_fill_bit_buffer := FALSE; + exit; + end; + next_input_byte := state.cinfo^.src^.next_input_byte; + bytes_in_buffer := state.cinfo^.src^.bytes_in_buffer; + end; + Dec(bytes_in_buffer); + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + Until (c <> $FF); + + if (c = 0) then + begin + { Found FF/00, which represents an FF data byte } + c := $FF; + end + else + begin + { Oops, it's actually a marker indicating end of compressed data. + Save the marker code for later use. + Fine point: it might appear that we should save the marker into + bitread working state, not straight into permanent state. But + once we have hit a marker, we cannot need to suspend within the + current MCU, because we will read no more bytes from the data + source. So it is OK to update permanent state right away. } + + cinfo^.unread_marker := c; + { See if we need to insert some fake zero bits. } + goto no_more_bytes; + end; + end; + + { OK, load c into get_buffer } + get_buffer := (get_buffer shl 8) or c; + Inc(bits_left, 8); + end { end while } + end + else + begin + no_more_bytes: + { We get here if we've read the marker that terminates the compressed + data segment. There should be enough bits in the buffer register + to satisfy the request; if so, no problem. } + + if (nbits > bits_left) then + begin + { Uh-oh. Report corrupted data to user and stuff zeroes into + the data stream, so that we can produce some kind of image. + We use a nonvolatile flag to ensure that only one warning message + appears per data segment. } + + if not cinfo^.entropy^.insufficient_data then + begin + WARNMS(j_common_ptr(cinfo), JWRN_HIT_MARKER); + cinfo^.entropy^.insufficient_data := TRUE; + end; + { Fill the buffer with zero bits } + get_buffer := get_buffer shl (MIN_GET_BITS - bits_left); + bits_left := MIN_GET_BITS; + end; + end; + + { Unload the local registers } + state.next_input_byte := next_input_byte; + state.bytes_in_buffer := bytes_in_buffer; + state.get_buffer := get_buffer; + state.bits_left := bits_left; + + jpeg_fill_bit_buffer := TRUE; +end; + + +{ Out-of-line code for Huffman code decoding. + See jdhuff.h for info about usage. } + +{GLOBAL} +function jpeg_huff_decode (var state : bitread_working_state; + {register} get_buffer : bit_buf_type; + {register} bits_left : int; + htbl : d_derived_tbl_ptr; + min_bits : int) : int; +var + {register} l : int; + {register} code : INT32; +begin + l := min_bits; + + { HUFF_DECODE has determined that the code is at least min_bits } + { bits long, so fetch that many bits in one swoop. } + + {CHECK_BIT_BUFFER(state, l, return -1);} + if (bits_left < l) then + begin + if (not jpeg_fill_bit_buffer(state, get_buffer, bits_left, l)) then + begin + jpeg_huff_decode := -1; + exit; + end; + get_buffer := state.get_buffer; + bits_left := state.bits_left; + end; + + {code := GET_BITS(l);} + Dec(bits_left, l); + code := (int(get_buffer shr bits_left)) and ( pred(1 shl l) ); + + { Collect the rest of the Huffman code one bit at a time. } + { This is per Figure F.16 in the JPEG spec. } + + while (code > htbl^.maxcode[l]) do + begin + code := code shl 1; + {CHECK_BIT_BUFFER(state, 1, return -1);} + if (bits_left < 1) then + begin + if (not jpeg_fill_bit_buffer(state, get_buffer, bits_left, 1)) then + begin + jpeg_huff_decode := -1; + exit; + end; + get_buffer := state.get_buffer; + bits_left := state.bits_left; + end; + + {code := code or GET_BITS(1);} + Dec(bits_left); + code := code or ( (int(get_buffer shr bits_left)) and pred(1 shl 1) ); + + Inc(l); + end; + + { Unload the local registers } + state.get_buffer := get_buffer; + state.bits_left := bits_left; + + { With garbage input we may reach the sentinel value l := 17. } + + if (l > 16) then + begin + WARNMS(j_common_ptr(state.cinfo), JWRN_HUFF_BAD_CODE); + jpeg_huff_decode := 0; { fake a zero as the safest result } + exit; + end; + + jpeg_huff_decode := htbl^.pub^.huffval[ int (code + htbl^.valoffset[l]) ]; +end; + + +{ Figure F.12: extend sign bit. + On some machines, a shift and add will be faster than a table lookup. } + +{$ifdef AVOID_TABLES} + +#define HUFF_EXTEND(x,s) ((x) < (1<<((s)-1)) ? (x) + (((-1)<<(s)) + 1) : (x)) + +{$else} + +{$define HUFF_EXTEND(x,s) + if (x < extend_test[s]) then + := x + extend_offset[s] + else + x;} + +const + extend_test : array[0..16-1] of int = { entry n is 2**(n-1) } + ($0000, $0001, $0002, $0004, $0008, $0010, $0020, $0040, + $0080, $0100, $0200, $0400, $0800, $1000, $2000, $4000); + +const + extend_offset : array[0..16-1] of int = { entry n is (-1 << n) + 1 } +(0, ((-1) shl 1) + 1, ((-1) shl 2) + 1, ((-1) shl 3) + 1, ((-1) shl 4) + 1, + ((-1) shl 5) + 1, ((-1) shl 6) + 1, ((-1) shl 7) + 1, ((-1) shl 8) + 1, + ((-1) shl 9) + 1, ((-1) shl 10) + 1, ((-1) shl 11) + 1,((-1) shl 12) + 1, + ((-1) shl 13) + 1, ((-1) shl 14) + 1, ((-1) shl 15) + 1); + +{$endif} { AVOID_TABLES } + + +{ Check for a restart marker & resynchronize decoder. + Returns FALSE if must suspend. } + +{LOCAL} +function process_restart (cinfo : j_decompress_ptr) : boolean; +var + entropy : huff_entropy_ptr; + ci : int; +begin + entropy := huff_entropy_ptr (cinfo^.entropy); + + { Throw away any unused bits remaining in bit buffer; } + { include any full bytes in next_marker's count of discarded bytes } + Inc(cinfo^.marker^.discarded_bytes, entropy^.bitstate.bits_left div 8); + entropy^.bitstate.bits_left := 0; + + { Advance past the RSTn marker } + if (not cinfo^.marker^.read_restart_marker (cinfo)) then + begin + process_restart := FALSE; + exit; + end; + + { Re-initialize DC predictions to 0 } + for ci := 0 to pred(cinfo^.comps_in_scan) do + entropy^.saved.last_dc_val[ci] := 0; + + { Reset restart counter } + entropy^.restarts_to_go := cinfo^.restart_interval; + + { Reset out-of-data flag, unless read_restart_marker left us smack up + against a marker. In that case we will end up treating the next data + segment as empty, and we can avoid producing bogus output pixels by + leaving the flag set. } + + if (cinfo^.unread_marker = 0) then + entropy^.pub.insufficient_data := FALSE; + + process_restart := TRUE; +end; + + +{ Decode and return one MCU's worth of Huffman-compressed coefficients. + The coefficients are reordered from zigzag order into natural array order, + but are not dequantized. + + The i'th block of the MCU is stored into the block pointed to by + MCU_data[i]. WE ASSUME THIS AREA HAS BEEN ZEROED BY THE CALLER. + (Wholesale zeroing is usually a little faster than retail...) + + Returns FALSE if data source requested suspension. In that case no + changes have been made to permanent state. (Exception: some output + coefficients may already have been assigned. This is harmless for + this module, since we'll just re-assign them on the next call.) } + +{METHODDEF} +function decode_mcu (cinfo : j_decompress_ptr; + var MCU_data : array of JBLOCKROW) : boolean; +label + label1, label2, label3; +var + entropy : huff_entropy_ptr; + {register} s, k, r : int; + blkn, ci : int; + block : JBLOCK_PTR; + {BITREAD_STATE_VARS} + get_buffer : bit_buf_type ; {register} + bits_left : int; {register} + br_state : bitread_working_state; + + state : savable_state; + dctbl : d_derived_tbl_ptr; + actbl : d_derived_tbl_ptr; +var + nb, look : int; {register} +begin + entropy := huff_entropy_ptr (cinfo^.entropy); + + { Process restart marker if needed; may have to suspend } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + if (not process_restart(cinfo)) then + begin + decode_mcu := FALSE; + exit; + end; + end; + + { If we've run out of data, just leave the MCU set to zeroes. + This way, we return uniform gray for the remainder of the segment. } + + if not entropy^.pub.insufficient_data then + begin + + { Load up working state } + {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);} + br_state.cinfo := cinfo; + br_state.next_input_byte := cinfo^.src^.next_input_byte; + br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer; + get_buffer := entropy^.bitstate.get_buffer; + bits_left := entropy^.bitstate.bits_left; + + {ASSIGN_STATE(state, entropy^.saved);} + state := entropy^.saved; + + { Outer loop handles each block in the MCU } + + for blkn := 0 to pred(cinfo^.blocks_in_MCU) do + begin + block := JBLOCK_PTR(MCU_data[blkn]); + dctbl := entropy^.dc_cur_tbls[blkn]; + actbl := entropy^.ac_cur_tbls[blkn]; + + { Decode a single block's worth of coefficients } + + { Section F.2.2.1: decode the DC coefficient difference } + {HUFF_DECODE(s, br_state, dctbl, return FALSE, label1);} + if (bits_left < HUFF_LOOKAHEAD) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then + begin + decode_mcu := False; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + if (bits_left < HUFF_LOOKAHEAD) then + begin + nb := 1; + goto label1; + end; + end; + {look := PEEK_BITS(HUFF_LOOKAHEAD);} + look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and + pred(1 shl HUFF_LOOKAHEAD); + + nb := dctbl^.look_nbits[look]; + if (nb <> 0) then + begin + {DROP_BITS(nb);} + Dec(bits_left, nb); + + s := dctbl^.look_sym[look]; + end + else + begin + nb := HUFF_LOOKAHEAD+1; + label1: + s := jpeg_huff_decode(br_state,get_buffer,bits_left,dctbl,nb); + if (s < 0) then + begin + decode_mcu := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + if (s <> 0) then + begin + {CHECK_BIT_BUFFER(br_state, s, return FALSE);} + if (bits_left < s) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then + begin + decode_mcu := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {r := GET_BITS(s);} + Dec(bits_left, s); + r := ( int(get_buffer shr bits_left)) and ( pred(1 shl s) ); + + {s := HUFF_EXTEND(r, s);} + if (r < extend_test[s]) then + s := r + extend_offset[s] + else + s := r; + end; + + if (entropy^.dc_needed[blkn]) then + begin + { Convert DC difference to actual value, update last_dc_val } + ci := cinfo^.MCU_membership[blkn]; + Inc(s, state.last_dc_val[ci]); + state.last_dc_val[ci] := s; + { Output the DC coefficient (assumes jpeg_natural_order[0] := 0) } + block^[0] := JCOEF (s); + end; + + if (entropy^.ac_needed[blkn]) then + begin + + { Section F.2.2.2: decode the AC coefficients } + { Since zeroes are skipped, output area must be cleared beforehand } + k := 1; + while (k < DCTSIZE2) do { Nomssi: k is incr. in the loop } + begin + {HUFF_DECODE(s, br_state, actbl, return FALSE, label2);} + if (bits_left < HUFF_LOOKAHEAD) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then + begin + decode_mcu := False; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + if (bits_left < HUFF_LOOKAHEAD) then + begin + nb := 1; + goto label2; + end; + end; + {look := PEEK_BITS(HUFF_LOOKAHEAD);} + look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and + pred(1 shl HUFF_LOOKAHEAD); + + nb := actbl^.look_nbits[look]; + if (nb <> 0) then + begin + {DROP_BITS(nb);} + Dec(bits_left, nb); + + s := actbl^.look_sym[look]; + end + else + begin + nb := HUFF_LOOKAHEAD+1; + label2: + s := jpeg_huff_decode(br_state,get_buffer,bits_left,actbl,nb); + if (s < 0) then + begin + decode_mcu := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + r := s shr 4; + s := s and 15; + + if (s <> 0) then + begin + Inc(k, r); + {CHECK_BIT_BUFFER(br_state, s, return FALSE);} + if (bits_left < s) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then + begin + decode_mcu := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {r := GET_BITS(s);} + Dec(bits_left, s); + r := (int(get_buffer shr bits_left)) and ( pred(1 shl s) ); + + {s := HUFF_EXTEND(r, s);} + if (r < extend_test[s]) then + s := r + extend_offset[s] + else + s := r; + { Output coefficient in natural (dezigzagged) order. + Note: the extra entries in jpeg_natural_order[] will save us + if k >= DCTSIZE2, which could happen if the data is corrupted. } + + block^[jpeg_natural_order[k]] := JCOEF (s); + end + else + begin + if (r <> 15) then + break; + Inc(k, 15); + end; + Inc(k); + end; + end + else + begin + + { Section F.2.2.2: decode the AC coefficients } + { In this path we just discard the values } + k := 1; + while (k < DCTSIZE2) do + begin + {HUFF_DECODE(s, br_state, actbl, return FALSE, label3);} + if (bits_left < HUFF_LOOKAHEAD) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then + begin + decode_mcu := False; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + if (bits_left < HUFF_LOOKAHEAD) then + begin + nb := 1; + goto label3; + end; + end; + {look := PEEK_BITS(HUFF_LOOKAHEAD);} + look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and + pred(1 shl HUFF_LOOKAHEAD); + + nb := actbl^.look_nbits[look]; + if (nb <> 0) then + begin + {DROP_BITS(nb);} + Dec(bits_left, nb); + + s := actbl^.look_sym[look]; + end + else + begin + nb := HUFF_LOOKAHEAD+1; + label3: + s := jpeg_huff_decode(br_state,get_buffer,bits_left,actbl,nb); + if (s < 0) then + begin + decode_mcu := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + r := s shr 4; + s := s and 15; + + if (s <> 0) then + begin + Inc(k, r); + {CHECK_BIT_BUFFER(br_state, s, return FALSE);} + if (bits_left < s) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then + begin + decode_mcu := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {DROP_BITS(s);} + Dec(bits_left, s); + end + else + begin + if (r <> 15) then + break; + Inc(k, 15); + end; + Inc(k); + end; + + end; + end; + + { Completed MCU, so update state } + {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);} + cinfo^.src^.next_input_byte := br_state.next_input_byte; + cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer; + entropy^.bitstate.get_buffer := get_buffer; + entropy^.bitstate.bits_left := bits_left; + + {ASSIGN_STATE(entropy^.saved, state);} + entropy^.saved := state; + + end; + + { Account for restart interval (no-op if not using restarts) } + if entropy^.restarts_to_go > 0 then + Dec(entropy^.restarts_to_go); + + decode_mcu := TRUE; +end; + + +{ Module initialization routine for Huffman entropy decoding. } + +{GLOBAL} +procedure jinit_huff_decoder (cinfo : j_decompress_ptr); +var + entropy : huff_entropy_ptr; + i : int; +begin + entropy := huff_entropy_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(huff_entropy_decoder)) ); + cinfo^.entropy := jpeg_entropy_decoder_ptr (entropy); + entropy^.pub.start_pass := start_pass_huff_decoder; + entropy^.pub.decode_mcu := decode_mcu; + + { Mark tables unallocated } + for i := 0 to pred(NUM_HUFF_TBLS) do + begin + entropy^.dc_derived_tbls[i] := NIL; + entropy^.ac_derived_tbls[i] := NIL; + end; +end; + +end. diff --git a/Imaging/JpegLib/imjdinput.pas b/Imaging/JpegLib/imjdinput.pas index 16a13e2..32a4d09 100644 --- a/Imaging/JpegLib/imjdinput.pas +++ b/Imaging/JpegLib/imjdinput.pas @@ -1,416 +1,416 @@ -unit imjdinput; - -{ Original: jdinput.c ; Copyright (C) 1991-1997, Thomas G. Lane. } - -{ This file is part of the Independent JPEG Group's software. - For conditions of distribution and use, see the accompanying README file. - - This file contains input control logic for the JPEG decompressor. - These routines are concerned with controlling the decompressor's input - processing (marker reading and coefficient decoding). The actual input - reading is done in jdmarker.c, jdhuff.c, and jdphuff.c. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjpeglib, - imjdeferr, - imjerror, - imjinclude, imjutils; - -{ Initialize the input controller module. - This is called only once, when the decompression object is created. } - -{GLOBAL} -procedure jinit_input_controller (cinfo : j_decompress_ptr); - -implementation - -{ Private state } - -type - my_inputctl_ptr = ^my_input_controller; - my_input_controller = record - pub : jpeg_input_controller; { public fields } - - inheaders : boolean; { TRUE until first SOS is reached } - end; {my_input_controller;} - - - -{ Forward declarations } -{METHODDEF} -function consume_markers (cinfo : j_decompress_ptr) : int; forward; - - -{ Routines to calculate various quantities related to the size of the image. } - -{LOCAL} -procedure initial_setup (cinfo : j_decompress_ptr); -{ Called once, when first SOS marker is reached } -var - ci : int; - compptr : jpeg_component_info_ptr; -begin - { Make sure image isn't bigger than I can handle } - if (long(cinfo^.image_height) > long (JPEG_MAX_DIMENSION)) or - (long(cinfo^.image_width) > long(JPEG_MAX_DIMENSION)) then - ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(JPEG_MAX_DIMENSION)); - - { For now, precision must match compiled-in value... } - if (cinfo^.data_precision <> BITS_IN_JSAMPLE) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PRECISION, cinfo^.data_precision); - - { Check that number of components won't exceed internal array sizes } - if (cinfo^.num_components > MAX_COMPONENTS) then - ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components, - MAX_COMPONENTS); - - { Compute maximum sampling factors; check factor validity } - cinfo^.max_h_samp_factor := 1; - cinfo^.max_v_samp_factor := 1; - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - if (compptr^.h_samp_factor<=0) or (compptr^.h_samp_factor>MAX_SAMP_FACTOR) or - (compptr^.v_samp_factor<=0) or (compptr^.v_samp_factor>MAX_SAMP_FACTOR) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_SAMPLING); - {cinfo^.max_h_samp_factor := MAX(cinfo^.max_h_samp_factor, - compptr^.h_samp_factor); - cinfo^.max_v_samp_factor := MAX(cinfo^.max_v_samp_factor, - compptr^.v_samp_factor);} - if cinfo^.max_h_samp_factor < compptr^.h_samp_factor then - cinfo^.max_h_samp_factor := compptr^.h_samp_factor; - if cinfo^.max_v_samp_factor < compptr^.v_samp_factor then - cinfo^.max_v_samp_factor := compptr^.v_samp_factor; - Inc(compptr); - end; - - { We initialize DCT_scaled_size and min_DCT_scaled_size to DCTSIZE. - In the full decompressor, this will be overridden by jdmaster.c; - but in the transcoder, jdmaster.c is not used, so we must do it here. } - - cinfo^.min_DCT_scaled_size := DCTSIZE; - - { Compute dimensions of components } - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - compptr^.DCT_scaled_size := DCTSIZE; - { Size in DCT blocks } - compptr^.width_in_blocks := JDIMENSION( - jdiv_round_up( long(cinfo^.image_width) * long(compptr^.h_samp_factor), - long(cinfo^.max_h_samp_factor * DCTSIZE)) ); - compptr^.height_in_blocks := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor), - long (cinfo^.max_v_samp_factor * DCTSIZE)) ); - { downsampled_width and downsampled_height will also be overridden by - jdmaster.c if we are doing full decompression. The transcoder library - doesn't use these values, but the calling application might. } - - { Size in samples } - compptr^.downsampled_width := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_width) * long(compptr^.h_samp_factor), - long (cinfo^.max_h_samp_factor)) ); - compptr^.downsampled_height := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor), - long (cinfo^.max_v_samp_factor)) ); - { Mark component needed, until color conversion says otherwise } - compptr^.component_needed := TRUE; - { Mark no quantization table yet saved for component } - compptr^.quant_table := NIL; - Inc(compptr); - end; - - { Compute number of fully interleaved MCU rows. } - cinfo^.total_iMCU_rows := JDIMENSION( - jdiv_round_up(long(cinfo^.image_height), - long(cinfo^.max_v_samp_factor*DCTSIZE)) ); - - { Decide whether file contains multiple scans } - if (cinfo^.comps_in_scan < cinfo^.num_components) or - (cinfo^.progressive_mode) then - cinfo^.inputctl^.has_multiple_scans := TRUE - else - cinfo^.inputctl^.has_multiple_scans := FALSE; -end; - - -{LOCAL} -procedure per_scan_setup (cinfo : j_decompress_ptr); -{ Do computations that are needed before processing a JPEG scan } -{ cinfo^.comps_in_scan and cinfo^.cur_comp_info[] were set from SOS marker } -var - ci, mcublks, tmp : int; - compptr : jpeg_component_info_ptr; -begin - if (cinfo^.comps_in_scan = 1) then - begin - { Noninterleaved (single-component) scan } - compptr := cinfo^.cur_comp_info[0]; - - { Overall image size in MCUs } - cinfo^.MCUs_per_row := compptr^.width_in_blocks; - cinfo^.MCU_rows_in_scan := compptr^.height_in_blocks; - - { For noninterleaved scan, always one block per MCU } - compptr^.MCU_width := 1; - compptr^.MCU_height := 1; - compptr^.MCU_blocks := 1; - compptr^.MCU_sample_width := compptr^.DCT_scaled_size; - compptr^.last_col_width := 1; - { For noninterleaved scans, it is convenient to define last_row_height - as the number of block rows present in the last iMCU row. } - - tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.v_samp_factor); - if (tmp = 0) then - tmp := compptr^.v_samp_factor; - compptr^.last_row_height := tmp; - - { Prepare array describing MCU composition } - cinfo^.blocks_in_MCU := 1; - cinfo^.MCU_membership[0] := 0; - - end - else - begin - - { Interleaved (multi-component) scan } - if (cinfo^.comps_in_scan <= 0) or (cinfo^.comps_in_scan > MAX_COMPS_IN_SCAN) then - ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.comps_in_scan, - MAX_COMPS_IN_SCAN); - - { Overall image size in MCUs } - cinfo^.MCUs_per_row := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_width), - long (cinfo^.max_h_samp_factor*DCTSIZE)) ); - cinfo^.MCU_rows_in_scan := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_height), - long (cinfo^.max_v_samp_factor*DCTSIZE)) ); - - cinfo^.blocks_in_MCU := 0; - - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - { Sampling factors give # of blocks of component in each MCU } - compptr^.MCU_width := compptr^.h_samp_factor; - compptr^.MCU_height := compptr^.v_samp_factor; - compptr^.MCU_blocks := compptr^.MCU_width * compptr^.MCU_height; - compptr^.MCU_sample_width := compptr^.MCU_width * compptr^.DCT_scaled_size; - { Figure number of non-dummy blocks in last MCU column & row } - tmp := int (LongInt(compptr^.width_in_blocks) mod compptr^.MCU_width); - if (tmp = 0) then - tmp := compptr^.MCU_width; - compptr^.last_col_width := tmp; - tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.MCU_height); - if (tmp = 0) then - tmp := compptr^.MCU_height; - compptr^.last_row_height := tmp; - { Prepare array describing MCU composition } - mcublks := compptr^.MCU_blocks; - if (LongInt(cinfo^.blocks_in_MCU) + mcublks > D_MAX_BLOCKS_IN_MCU) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_MCU_SIZE); - while (mcublks > 0) do - begin - Dec(mcublks); - cinfo^.MCU_membership[cinfo^.blocks_in_MCU] := ci; - Inc(cinfo^.blocks_in_MCU); - end; - end; - - end; -end; - - -{ Save away a copy of the Q-table referenced by each component present - in the current scan, unless already saved during a prior scan. - - In a multiple-scan JPEG file, the encoder could assign different components - the same Q-table slot number, but change table definitions between scans - so that each component uses a different Q-table. (The IJG encoder is not - currently capable of doing this, but other encoders might.) Since we want - to be able to dequantize all the components at the end of the file, this - means that we have to save away the table actually used for each component. - We do this by copying the table at the start of the first scan containing - the component. - The JPEG spec prohibits the encoder from changing the contents of a Q-table - slot between scans of a component using that slot. If the encoder does so - anyway, this decoder will simply use the Q-table values that were current - at the start of the first scan for the component. - - The decompressor output side looks only at the saved quant tables, - not at the current Q-table slots. } - -{LOCAL} -procedure latch_quant_tables (cinfo : j_decompress_ptr); -var - ci, qtblno : int; - compptr : jpeg_component_info_ptr; - qtbl : JQUANT_TBL_PTR; -begin - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - { No work if we already saved Q-table for this component } - if (compptr^.quant_table <> NIL) then - continue; - { Make sure specified quantization table is present } - qtblno := compptr^.quant_tbl_no; - if (qtblno < 0) or (qtblno >= NUM_QUANT_TBLS) or - (cinfo^.quant_tbl_ptrs[qtblno] = NIL) then - ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, qtblno); - { OK, save away the quantization table } - qtbl := JQUANT_TBL_PTR( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(JQUANT_TBL)) ); - MEMCOPY(qtbl, cinfo^.quant_tbl_ptrs[qtblno], SIZEOF(JQUANT_TBL)); - compptr^.quant_table := qtbl; - end; -end; - - -{ Initialize the input modules to read a scan of compressed data. - The first call to this is done by jdmaster.c after initializing - the entire decompressor (during jpeg_start_decompress). - Subsequent calls come from consume_markers, below. } - -{METHODDEF} -procedure start_input_pass (cinfo : j_decompress_ptr); -begin - per_scan_setup(cinfo); - latch_quant_tables(cinfo); - cinfo^.entropy^.start_pass (cinfo); - cinfo^.coef^.start_input_pass (cinfo); - cinfo^.inputctl^.consume_input := cinfo^.coef^.consume_data; -end; - - -{ Finish up after inputting a compressed-data scan. - This is called by the coefficient controller after it's read all - the expected data of the scan. } - -{METHODDEF} -procedure finish_input_pass (cinfo : j_decompress_ptr); -begin - cinfo^.inputctl^.consume_input := consume_markers; -end; - - -{ Read JPEG markers before, between, or after compressed-data scans. - Change state as necessary when a new scan is reached. - Return value is JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. - - The consume_input method pointer points either here or to the - coefficient controller's consume_data routine, depending on whether - we are reading a compressed data segment or inter-segment markers. } - -{METHODDEF} -function consume_markers (cinfo : j_decompress_ptr) : int; -var - val : int; - inputctl : my_inputctl_ptr; -begin - inputctl := my_inputctl_ptr (cinfo^.inputctl); - - if (inputctl^.pub.eoi_reached) then { After hitting EOI, read no further } - begin - consume_markers := JPEG_REACHED_EOI; - exit; - end; - - val := cinfo^.marker^.read_markers (cinfo); - - case (val) of - JPEG_REACHED_SOS: { Found SOS } - begin - if (inputctl^.inheaders) then - begin { 1st SOS } - initial_setup(cinfo); - inputctl^.inheaders := FALSE; - { Note: start_input_pass must be called by jdmaster.c - before any more input can be consumed. jdapimin.c is - responsible for enforcing this sequencing. } - end - else - begin { 2nd or later SOS marker } - if (not inputctl^.pub.has_multiple_scans) then - ERREXIT(j_common_ptr(cinfo), JERR_EOI_EXPECTED); { Oops, I wasn't expecting this! } - start_input_pass(cinfo); - end; - end; - JPEG_REACHED_EOI: { Found EOI } - begin - inputctl^.pub.eoi_reached := TRUE; - if (inputctl^.inheaders) then - begin { Tables-only datastream, apparently } - if (cinfo^.marker^.saw_SOF) then - ERREXIT(j_common_ptr(cinfo), JERR_SOF_NO_SOS); - end - else - begin - { Prevent infinite loop in coef ctlr's decompress_data routine - if user set output_scan_number larger than number of scans. } - - if (cinfo^.output_scan_number > cinfo^.input_scan_number) then - cinfo^.output_scan_number := cinfo^.input_scan_number; - end; - end; - JPEG_SUSPENDED:; - end; - - consume_markers := val; -end; - - -{ Reset state to begin a fresh datastream. } - -{METHODDEF} -procedure reset_input_controller (cinfo : j_decompress_ptr); -var - inputctl : my_inputctl_ptr; -begin - inputctl := my_inputctl_ptr (cinfo^.inputctl); - - inputctl^.pub.consume_input := consume_markers; - inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better } - inputctl^.pub.eoi_reached := FALSE; - inputctl^.inheaders := TRUE; - { Reset other modules } - cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo)); - cinfo^.marker^.reset_marker_reader (cinfo); - { Reset progression state -- would be cleaner if entropy decoder did this } - cinfo^.coef_bits := NIL; -end; - - -{ Initialize the input controller module. - This is called only once, when the decompression object is created. } - -{GLOBAL} -procedure jinit_input_controller (cinfo : j_decompress_ptr); -var - inputctl : my_inputctl_ptr; -begin - { Create subobject in permanent pool } - inputctl := my_inputctl_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT, - SIZEOF(my_input_controller)) ); - cinfo^.inputctl := jpeg_input_controller_ptr(inputctl); - { Initialize method pointers } - inputctl^.pub.consume_input := consume_markers; - inputctl^.pub.reset_input_controller := reset_input_controller; - inputctl^.pub.start_input_pass := start_input_pass; - inputctl^.pub.finish_input_pass := finish_input_pass; - { Initialize state: can't use reset_input_controller since we don't - want to try to reset other modules yet. } - - inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better } - inputctl^.pub.eoi_reached := FALSE; - inputctl^.inheaders := TRUE; -end; - -end. +unit imjdinput; + +{ Original: jdinput.c ; Copyright (C) 1991-1997, Thomas G. Lane. } + +{ This file is part of the Independent JPEG Group's software. + For conditions of distribution and use, see the accompanying README file. + + This file contains input control logic for the JPEG decompressor. + These routines are concerned with controlling the decompressor's input + processing (marker reading and coefficient decoding). The actual input + reading is done in jdmarker.c, jdhuff.c, and jdphuff.c. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjpeglib, + imjdeferr, + imjerror, + imjinclude, imjutils; + +{ Initialize the input controller module. + This is called only once, when the decompression object is created. } + +{GLOBAL} +procedure jinit_input_controller (cinfo : j_decompress_ptr); + +implementation + +{ Private state } + +type + my_inputctl_ptr = ^my_input_controller; + my_input_controller = record + pub : jpeg_input_controller; { public fields } + + inheaders : boolean; { TRUE until first SOS is reached } + end; {my_input_controller;} + + + +{ Forward declarations } +{METHODDEF} +function consume_markers (cinfo : j_decompress_ptr) : int; forward; + + +{ Routines to calculate various quantities related to the size of the image. } + +{LOCAL} +procedure initial_setup (cinfo : j_decompress_ptr); +{ Called once, when first SOS marker is reached } +var + ci : int; + compptr : jpeg_component_info_ptr; +begin + { Make sure image isn't bigger than I can handle } + if (long(cinfo^.image_height) > long (JPEG_MAX_DIMENSION)) or + (long(cinfo^.image_width) > long(JPEG_MAX_DIMENSION)) then + ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(JPEG_MAX_DIMENSION)); + + { For now, precision must match compiled-in value... } + if (cinfo^.data_precision <> BITS_IN_JSAMPLE) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_PRECISION, cinfo^.data_precision); + + { Check that number of components won't exceed internal array sizes } + if (cinfo^.num_components > MAX_COMPONENTS) then + ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.num_components, + MAX_COMPONENTS); + + { Compute maximum sampling factors; check factor validity } + cinfo^.max_h_samp_factor := 1; + cinfo^.max_v_samp_factor := 1; + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + if (compptr^.h_samp_factor<=0) or (compptr^.h_samp_factor>MAX_SAMP_FACTOR) or + (compptr^.v_samp_factor<=0) or (compptr^.v_samp_factor>MAX_SAMP_FACTOR) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_SAMPLING); + {cinfo^.max_h_samp_factor := MAX(cinfo^.max_h_samp_factor, + compptr^.h_samp_factor); + cinfo^.max_v_samp_factor := MAX(cinfo^.max_v_samp_factor, + compptr^.v_samp_factor);} + if cinfo^.max_h_samp_factor < compptr^.h_samp_factor then + cinfo^.max_h_samp_factor := compptr^.h_samp_factor; + if cinfo^.max_v_samp_factor < compptr^.v_samp_factor then + cinfo^.max_v_samp_factor := compptr^.v_samp_factor; + Inc(compptr); + end; + + { We initialize DCT_scaled_size and min_DCT_scaled_size to DCTSIZE. + In the full decompressor, this will be overridden by jdmaster.c; + but in the transcoder, jdmaster.c is not used, so we must do it here. } + + cinfo^.min_DCT_scaled_size := DCTSIZE; + + { Compute dimensions of components } + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + compptr^.DCT_scaled_size := DCTSIZE; + { Size in DCT blocks } + compptr^.width_in_blocks := JDIMENSION( + jdiv_round_up( long(cinfo^.image_width) * long(compptr^.h_samp_factor), + long(cinfo^.max_h_samp_factor * DCTSIZE)) ); + compptr^.height_in_blocks := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor), + long (cinfo^.max_v_samp_factor * DCTSIZE)) ); + { downsampled_width and downsampled_height will also be overridden by + jdmaster.c if we are doing full decompression. The transcoder library + doesn't use these values, but the calling application might. } + + { Size in samples } + compptr^.downsampled_width := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_width) * long(compptr^.h_samp_factor), + long (cinfo^.max_h_samp_factor)) ); + compptr^.downsampled_height := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_height) * long(compptr^.v_samp_factor), + long (cinfo^.max_v_samp_factor)) ); + { Mark component needed, until color conversion says otherwise } + compptr^.component_needed := TRUE; + { Mark no quantization table yet saved for component } + compptr^.quant_table := NIL; + Inc(compptr); + end; + + { Compute number of fully interleaved MCU rows. } + cinfo^.total_iMCU_rows := JDIMENSION( + jdiv_round_up(long(cinfo^.image_height), + long(cinfo^.max_v_samp_factor*DCTSIZE)) ); + + { Decide whether file contains multiple scans } + if (cinfo^.comps_in_scan < cinfo^.num_components) or + (cinfo^.progressive_mode) then + cinfo^.inputctl^.has_multiple_scans := TRUE + else + cinfo^.inputctl^.has_multiple_scans := FALSE; +end; + + +{LOCAL} +procedure per_scan_setup (cinfo : j_decompress_ptr); +{ Do computations that are needed before processing a JPEG scan } +{ cinfo^.comps_in_scan and cinfo^.cur_comp_info[] were set from SOS marker } +var + ci, mcublks, tmp : int; + compptr : jpeg_component_info_ptr; +begin + if (cinfo^.comps_in_scan = 1) then + begin + { Noninterleaved (single-component) scan } + compptr := cinfo^.cur_comp_info[0]; + + { Overall image size in MCUs } + cinfo^.MCUs_per_row := compptr^.width_in_blocks; + cinfo^.MCU_rows_in_scan := compptr^.height_in_blocks; + + { For noninterleaved scan, always one block per MCU } + compptr^.MCU_width := 1; + compptr^.MCU_height := 1; + compptr^.MCU_blocks := 1; + compptr^.MCU_sample_width := compptr^.DCT_scaled_size; + compptr^.last_col_width := 1; + { For noninterleaved scans, it is convenient to define last_row_height + as the number of block rows present in the last iMCU row. } + + tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.v_samp_factor); + if (tmp = 0) then + tmp := compptr^.v_samp_factor; + compptr^.last_row_height := tmp; + + { Prepare array describing MCU composition } + cinfo^.blocks_in_MCU := 1; + cinfo^.MCU_membership[0] := 0; + + end + else + begin + + { Interleaved (multi-component) scan } + if (cinfo^.comps_in_scan <= 0) or (cinfo^.comps_in_scan > MAX_COMPS_IN_SCAN) then + ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT, cinfo^.comps_in_scan, + MAX_COMPS_IN_SCAN); + + { Overall image size in MCUs } + cinfo^.MCUs_per_row := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_width), + long (cinfo^.max_h_samp_factor*DCTSIZE)) ); + cinfo^.MCU_rows_in_scan := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_height), + long (cinfo^.max_v_samp_factor*DCTSIZE)) ); + + cinfo^.blocks_in_MCU := 0; + + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + { Sampling factors give # of blocks of component in each MCU } + compptr^.MCU_width := compptr^.h_samp_factor; + compptr^.MCU_height := compptr^.v_samp_factor; + compptr^.MCU_blocks := compptr^.MCU_width * compptr^.MCU_height; + compptr^.MCU_sample_width := compptr^.MCU_width * compptr^.DCT_scaled_size; + { Figure number of non-dummy blocks in last MCU column & row } + tmp := int (LongInt(compptr^.width_in_blocks) mod compptr^.MCU_width); + if (tmp = 0) then + tmp := compptr^.MCU_width; + compptr^.last_col_width := tmp; + tmp := int (LongInt(compptr^.height_in_blocks) mod compptr^.MCU_height); + if (tmp = 0) then + tmp := compptr^.MCU_height; + compptr^.last_row_height := tmp; + { Prepare array describing MCU composition } + mcublks := compptr^.MCU_blocks; + if (LongInt(cinfo^.blocks_in_MCU) + mcublks > D_MAX_BLOCKS_IN_MCU) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_MCU_SIZE); + while (mcublks > 0) do + begin + Dec(mcublks); + cinfo^.MCU_membership[cinfo^.blocks_in_MCU] := ci; + Inc(cinfo^.blocks_in_MCU); + end; + end; + + end; +end; + + +{ Save away a copy of the Q-table referenced by each component present + in the current scan, unless already saved during a prior scan. + + In a multiple-scan JPEG file, the encoder could assign different components + the same Q-table slot number, but change table definitions between scans + so that each component uses a different Q-table. (The IJG encoder is not + currently capable of doing this, but other encoders might.) Since we want + to be able to dequantize all the components at the end of the file, this + means that we have to save away the table actually used for each component. + We do this by copying the table at the start of the first scan containing + the component. + The JPEG spec prohibits the encoder from changing the contents of a Q-table + slot between scans of a component using that slot. If the encoder does so + anyway, this decoder will simply use the Q-table values that were current + at the start of the first scan for the component. + + The decompressor output side looks only at the saved quant tables, + not at the current Q-table slots. } + +{LOCAL} +procedure latch_quant_tables (cinfo : j_decompress_ptr); +var + ci, qtblno : int; + compptr : jpeg_component_info_ptr; + qtbl : JQUANT_TBL_PTR; +begin + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + { No work if we already saved Q-table for this component } + if (compptr^.quant_table <> NIL) then + continue; + { Make sure specified quantization table is present } + qtblno := compptr^.quant_tbl_no; + if (qtblno < 0) or (qtblno >= NUM_QUANT_TBLS) or + (cinfo^.quant_tbl_ptrs[qtblno] = NIL) then + ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, qtblno); + { OK, save away the quantization table } + qtbl := JQUANT_TBL_PTR( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(JQUANT_TBL)) ); + MEMCOPY(qtbl, cinfo^.quant_tbl_ptrs[qtblno], SIZEOF(JQUANT_TBL)); + compptr^.quant_table := qtbl; + end; +end; + + +{ Initialize the input modules to read a scan of compressed data. + The first call to this is done by jdmaster.c after initializing + the entire decompressor (during jpeg_start_decompress). + Subsequent calls come from consume_markers, below. } + +{METHODDEF} +procedure start_input_pass (cinfo : j_decompress_ptr); +begin + per_scan_setup(cinfo); + latch_quant_tables(cinfo); + cinfo^.entropy^.start_pass (cinfo); + cinfo^.coef^.start_input_pass (cinfo); + cinfo^.inputctl^.consume_input := cinfo^.coef^.consume_data; +end; + + +{ Finish up after inputting a compressed-data scan. + This is called by the coefficient controller after it's read all + the expected data of the scan. } + +{METHODDEF} +procedure finish_input_pass (cinfo : j_decompress_ptr); +begin + cinfo^.inputctl^.consume_input := consume_markers; +end; + + +{ Read JPEG markers before, between, or after compressed-data scans. + Change state as necessary when a new scan is reached. + Return value is JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. + + The consume_input method pointer points either here or to the + coefficient controller's consume_data routine, depending on whether + we are reading a compressed data segment or inter-segment markers. } + +{METHODDEF} +function consume_markers (cinfo : j_decompress_ptr) : int; +var + val : int; + inputctl : my_inputctl_ptr; +begin + inputctl := my_inputctl_ptr (cinfo^.inputctl); + + if (inputctl^.pub.eoi_reached) then { After hitting EOI, read no further } + begin + consume_markers := JPEG_REACHED_EOI; + exit; + end; + + val := cinfo^.marker^.read_markers (cinfo); + + case (val) of + JPEG_REACHED_SOS: { Found SOS } + begin + if (inputctl^.inheaders) then + begin { 1st SOS } + initial_setup(cinfo); + inputctl^.inheaders := FALSE; + { Note: start_input_pass must be called by jdmaster.c + before any more input can be consumed. jdapimin.c is + responsible for enforcing this sequencing. } + end + else + begin { 2nd or later SOS marker } + if (not inputctl^.pub.has_multiple_scans) then + ERREXIT(j_common_ptr(cinfo), JERR_EOI_EXPECTED); { Oops, I wasn't expecting this! } + start_input_pass(cinfo); + end; + end; + JPEG_REACHED_EOI: { Found EOI } + begin + inputctl^.pub.eoi_reached := TRUE; + if (inputctl^.inheaders) then + begin { Tables-only datastream, apparently } + if (cinfo^.marker^.saw_SOF) then + ERREXIT(j_common_ptr(cinfo), JERR_SOF_NO_SOS); + end + else + begin + { Prevent infinite loop in coef ctlr's decompress_data routine + if user set output_scan_number larger than number of scans. } + + if (cinfo^.output_scan_number > cinfo^.input_scan_number) then + cinfo^.output_scan_number := cinfo^.input_scan_number; + end; + end; + JPEG_SUSPENDED:; + end; + + consume_markers := val; +end; + + +{ Reset state to begin a fresh datastream. } + +{METHODDEF} +procedure reset_input_controller (cinfo : j_decompress_ptr); +var + inputctl : my_inputctl_ptr; +begin + inputctl := my_inputctl_ptr (cinfo^.inputctl); + + inputctl^.pub.consume_input := consume_markers; + inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better } + inputctl^.pub.eoi_reached := FALSE; + inputctl^.inheaders := TRUE; + { Reset other modules } + cinfo^.err^.reset_error_mgr (j_common_ptr(cinfo)); + cinfo^.marker^.reset_marker_reader (cinfo); + { Reset progression state -- would be cleaner if entropy decoder did this } + cinfo^.coef_bits := NIL; +end; + + +{ Initialize the input controller module. + This is called only once, when the decompression object is created. } + +{GLOBAL} +procedure jinit_input_controller (cinfo : j_decompress_ptr); +var + inputctl : my_inputctl_ptr; +begin + { Create subobject in permanent pool } + inputctl := my_inputctl_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT, + SIZEOF(my_input_controller)) ); + cinfo^.inputctl := jpeg_input_controller_ptr(inputctl); + { Initialize method pointers } + inputctl^.pub.consume_input := consume_markers; + inputctl^.pub.reset_input_controller := reset_input_controller; + inputctl^.pub.start_input_pass := start_input_pass; + inputctl^.pub.finish_input_pass := finish_input_pass; + { Initialize state: can't use reset_input_controller since we don't + want to try to reset other modules yet. } + + inputctl^.pub.has_multiple_scans := FALSE; { "unknown" would be better } + inputctl^.pub.eoi_reached := FALSE; + inputctl^.inheaders := TRUE; +end; + +end. diff --git a/Imaging/JpegLib/imjdmainct.pas b/Imaging/JpegLib/imjdmainct.pas index 8c04d7e..78a5bbd 100644 --- a/Imaging/JpegLib/imjdmainct.pas +++ b/Imaging/JpegLib/imjdmainct.pas @@ -1,610 +1,610 @@ -unit imjdmainct; - - -{ This file is part of the Independent JPEG Group's software. - For conditions of distribution and use, see the accompanying README file. - - This file contains the main buffer controller for decompression. - The main buffer lies between the JPEG decompressor proper and the - post-processor; it holds downsampled data in the JPEG colorspace. - - Note that this code is bypassed in raw-data mode, since the application - supplies the equivalent of the main buffer in that case. } - -{ Original: jdmainct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - - -{ In the current system design, the main buffer need never be a full-image - buffer; any full-height buffers will be found inside the coefficient or - postprocessing controllers. Nonetheless, the main controller is not - trivial. Its responsibility is to provide context rows for upsampling/ - rescaling, and doing this in an efficient fashion is a bit tricky. - - Postprocessor input data is counted in "row groups". A row group - is defined to be (v_samp_factor * DCT_scaled_size / min_DCT_scaled_size) - sample rows of each component. (We require DCT_scaled_size values to be - chosen such that these numbers are integers. In practice DCT_scaled_size - values will likely be powers of two, so we actually have the stronger - condition that DCT_scaled_size / min_DCT_scaled_size is an integer.) - Upsampling will typically produce max_v_samp_factor pixel rows from each - row group (times any additional scale factor that the upsampler is - applying). - - The coefficient controller will deliver data to us one iMCU row at a time; - each iMCU row contains v_samp_factor * DCT_scaled_size sample rows, or - exactly min_DCT_scaled_size row groups. (This amount of data corresponds - to one row of MCUs when the image is fully interleaved.) Note that the - number of sample rows varies across components, but the number of row - groups does not. Some garbage sample rows may be included in the last iMCU - row at the bottom of the image. - - Depending on the vertical scaling algorithm used, the upsampler may need - access to the sample row(s) above and below its current input row group. - The upsampler is required to set need_context_rows TRUE at global - selection - time if so. When need_context_rows is FALSE, this controller can simply - obtain one iMCU row at a time from the coefficient controller and dole it - out as row groups to the postprocessor. - - When need_context_rows is TRUE, this controller guarantees that the buffer - passed to postprocessing contains at least one row group's worth of samples - above and below the row group(s) being processed. Note that the context - rows "above" the first passed row group appear at negative row offsets in - the passed buffer. At the top and bottom of the image, the required - context rows are manufactured by duplicating the first or last real sample - row; this avoids having special cases in the upsampling inner loops. - - The amount of context is fixed at one row group just because that's a - convenient number for this controller to work with. The existing - upsamplers really only need one sample row of context. An upsampler - supporting arbitrary output rescaling might wish for more than one row - group of context when shrinking the image; tough, we don't handle that. - (This is justified by the assumption that downsizing will be handled mostly - by adjusting the DCT_scaled_size values, so that the actual scale factor at - the upsample step needn't be much less than one.) - - To provide the desired context, we have to retain the last two row groups - of one iMCU row while reading in the next iMCU row. (The last row group - can't be processed until we have another row group for its below-context, - and so we have to save the next-to-last group too for its above-context.) - We could do this most simply by copying data around in our buffer, but - that'd be very slow. We can avoid copying any data by creating a rather - strange pointer structure. Here's how it works. We allocate a workspace - consisting of M+2 row groups (where M = min_DCT_scaled_size is the number - of row groups per iMCU row). We create two sets of redundant pointers to - the workspace. Labeling the physical row groups 0 to M+1, the synthesized - pointer lists look like this: - M+1 M-1 - master pointer --> 0 master pointer --> 0 - 1 1 - ... ... - M-3 M-3 - M-2 M - M-1 M+1 - M M-2 - M+1 M-1 - 0 0 - We read alternate iMCU rows using each master pointer; thus the last two - row groups of the previous iMCU row remain un-overwritten in the workspace. - The pointer lists are set up so that the required context rows appear to - be adjacent to the proper places when we pass the pointer lists to the - upsampler. - - The above pictures describe the normal state of the pointer lists. - At top and bottom of the image, we diddle the pointer lists to duplicate - the first or last sample row as necessary (this is cheaper than copying - sample rows around). - - This scheme breaks down if M < 2, ie, min_DCT_scaled_size is 1. In that - situation each iMCU row provides only one row group so the buffering logic - must be different (eg, we must read two iMCU rows before we can emit the - first row group). For now, we simply do not support providing context - rows when min_DCT_scaled_size is 1. That combination seems unlikely to - be worth providing --- if someone wants a 1/8th-size preview, they probably - want it quick and dirty, so a context-free upsampler is sufficient. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, -{$ifdef QUANT_2PASS_SUPPORTED} - imjquant2, -{$endif} - imjdeferr, - imjerror, - imjpeglib; - - -{GLOBAL} -procedure jinit_d_main_controller (cinfo : j_decompress_ptr; - need_full_buffer : boolean); - - -implementation - -{ Private buffer controller object } - -type - my_main_ptr = ^my_main_controller; - my_main_controller = record - pub : jpeg_d_main_controller; { public fields } - - { Pointer to allocated workspace (M or M+2 row groups). } - buffer : array[0..MAX_COMPONENTS-1] of JSAMPARRAY; - - buffer_full : boolean; { Have we gotten an iMCU row from decoder? } - rowgroup_ctr : JDIMENSION ; { counts row groups output to postprocessor } - - { Remaining fields are only used in the context case. } - - { These are the master pointers to the funny-order pointer lists. } - xbuffer : array[0..2-1] of JSAMPIMAGE; { pointers to weird pointer lists } - - whichptr : int; { indicates which pointer set is now in use } - context_state : int; { process_data state machine status } - rowgroups_avail : JDIMENSION; { row groups available to postprocessor } - iMCU_row_ctr : JDIMENSION; { counts iMCU rows to detect image top/bot } - end; { my_main_controller; } - - -{ context_state values: } -const - CTX_PREPARE_FOR_IMCU = 0; { need to prepare for MCU row } - CTX_PROCESS_IMCU = 1; { feeding iMCU to postprocessor } - CTX_POSTPONED_ROW = 2; { feeding postponed row group } - - -{ Forward declarations } -{METHODDEF} -procedure process_data_simple_main(cinfo : j_decompress_ptr; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); forward; -{METHODDEF} -procedure process_data_context_main (cinfo : j_decompress_ptr; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); forward; - -{$ifdef QUANT_2PASS_SUPPORTED} -{METHODDEF} -procedure process_data_crank_post (cinfo : j_decompress_ptr; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); forward; -{$endif} - - -{LOCAL} -procedure alloc_funny_pointers (cinfo : j_decompress_ptr); -{ Allocate space for the funny pointer lists. - This is done only once, not once per pass. } -var - main : my_main_ptr; - ci, rgroup : int; - M : int; - compptr : jpeg_component_info_ptr; - xbuf : JSAMPARRAY; -begin - main := my_main_ptr (cinfo^.main); - M := cinfo^.min_DCT_scaled_size; - - { Get top-level space for component array pointers. - We alloc both arrays with one call to save a few cycles. } - - main^.xbuffer[0] := JSAMPIMAGE ( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - cinfo^.num_components * 2 * SIZEOF(JSAMPARRAY)) ); - main^.xbuffer[1] := JSAMPIMAGE(@( main^.xbuffer[0]^[cinfo^.num_components] )); - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div - cinfo^.min_DCT_scaled_size; { height of a row group of component } - { Get space for pointer lists --- M+4 row groups in each list. - We alloc both pointer lists with one call to save a few cycles. } - - xbuf := JSAMPARRAY ( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - 2 * (rgroup * (M + 4)) * SIZEOF(JSAMPROW)) ); - Inc(JSAMPROW_PTR(xbuf), rgroup); { want one row group at negative offsets } - main^.xbuffer[0]^[ci] := xbuf; - Inc(JSAMPROW_PTR(xbuf), rgroup * (M + 4)); - main^.xbuffer[1]^[ci] := xbuf; - Inc(compptr); - end; -end; - -{LOCAL} -procedure make_funny_pointers (cinfo : j_decompress_ptr); -{ Create the funny pointer lists discussed in the comments above. - The actual workspace is already allocated (in main^.buffer), - and the space for the pointer lists is allocated too. - This routine just fills in the curiously ordered lists. - This will be repeated at the beginning of each pass. } -var - main : my_main_ptr; - ci, i, rgroup : int; - M : int; - compptr : jpeg_component_info_ptr; - buf, xbuf0, xbuf1 : JSAMPARRAY; -var - help_xbuf0 : JSAMPARRAY; { work around negative offsets } -begin - main := my_main_ptr (cinfo^.main); - M := cinfo^.min_DCT_scaled_size; - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div - cinfo^.min_DCT_scaled_size; { height of a row group of component } - xbuf0 := main^.xbuffer[0]^[ci]; - xbuf1 := main^.xbuffer[1]^[ci]; - { First copy the workspace pointers as-is } - buf := main^.buffer[ci]; - for i := 0 to pred(rgroup * (M + 2)) do - begin - xbuf0^[i] := buf^[i]; - xbuf1^[i] := buf^[i]; - end; - { In the second list, put the last four row groups in swapped order } - for i := 0 to pred(rgroup * 2) do - begin - xbuf1^[rgroup*(M-2) + i] := buf^[rgroup*M + i]; - xbuf1^[rgroup*M + i] := buf^[rgroup*(M-2) + i]; - end; - { The wraparound pointers at top and bottom will be filled later - (see set_wraparound_pointers, below). Initially we want the "above" - pointers to duplicate the first actual data line. This only needs - to happen in xbuffer[0]. } - - help_xbuf0 := xbuf0; - Dec(JSAMPROW_PTR(help_xbuf0), rgroup); - - for i := 0 to pred(rgroup) do - begin - {xbuf0^[i - rgroup] := xbuf0^[0];} - help_xbuf0^[i] := xbuf0^[0]; - end; - Inc(compptr); - end; -end; - - -{LOCAL} -procedure set_wraparound_pointers (cinfo : j_decompress_ptr); -{ Set up the "wraparound" pointers at top and bottom of the pointer lists. - This changes the pointer list state from top-of-image to the normal state. } -var - main : my_main_ptr; - ci, i, rgroup : int; - M : int; - compptr : jpeg_component_info_ptr; - xbuf0, xbuf1 : JSAMPARRAY; -var - help_xbuf0, - help_xbuf1 : JSAMPARRAY; { work around negative offsets } -begin - main := my_main_ptr (cinfo^.main); - M := cinfo^.min_DCT_scaled_size; - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div - cinfo^.min_DCT_scaled_size; { height of a row group of component } - xbuf0 := main^.xbuffer[0]^[ci]; - xbuf1 := main^.xbuffer[1]^[ci]; - - help_xbuf0 := xbuf0; - Dec(JSAMPROW_PTR(help_xbuf0), rgroup); - help_xbuf1 := xbuf1; - Dec(JSAMPROW_PTR(help_xbuf1), rgroup); - - for i := 0 to pred(rgroup) do - begin - {xbuf0^[i - rgroup] := xbuf0^[rgroup*(M+1) + i]; - xbuf1^[i - rgroup] := xbuf1^[rgroup*(M+1) + i];} - - help_xbuf0^[i] := xbuf0^[rgroup*(M+1) + i]; - help_xbuf1^[i] := xbuf1^[rgroup*(M+1) + i]; - - xbuf0^[rgroup*(M+2) + i] := xbuf0^[i]; - xbuf1^[rgroup*(M+2) + i] := xbuf1^[i]; - end; - Inc(compptr); - end; -end; - - -{LOCAL} -procedure set_bottom_pointers (cinfo : j_decompress_ptr); -{ Change the pointer lists to duplicate the last sample row at the bottom - of the image. whichptr indicates which xbuffer holds the final iMCU row. - Also sets rowgroups_avail to indicate number of nondummy row groups in row. } -var - main : my_main_ptr; - ci, i, rgroup, iMCUheight, rows_left : int; - compptr : jpeg_component_info_ptr; - xbuf : JSAMPARRAY; -begin - main := my_main_ptr (cinfo^.main); - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - { Count sample rows in one iMCU row and in one row group } - iMCUheight := compptr^.v_samp_factor * compptr^.DCT_scaled_size; - rgroup := iMCUheight div cinfo^.min_DCT_scaled_size; - { Count nondummy sample rows remaining for this component } - rows_left := int (compptr^.downsampled_height mod JDIMENSION (iMCUheight)); - if (rows_left = 0) then - rows_left := iMCUheight; - { Count nondummy row groups. Should get same answer for each component, - so we need only do it once. } - if (ci = 0) then - begin - main^.rowgroups_avail := JDIMENSION ((rows_left-1) div rgroup + 1); - end; - { Duplicate the last real sample row rgroup*2 times; this pads out the - last partial rowgroup and ensures at least one full rowgroup of context. } - - xbuf := main^.xbuffer[main^.whichptr]^[ci]; - for i := 0 to pred(rgroup * 2) do - begin - xbuf^[rows_left + i] := xbuf^[rows_left-1]; - end; - Inc(compptr); - end; -end; - - -{ Initialize for a processing pass. } - -{METHODDEF} -procedure start_pass_main (cinfo : j_decompress_ptr; - pass_mode : J_BUF_MODE); -var - main : my_main_ptr; -begin - main := my_main_ptr (cinfo^.main); - - case (pass_mode) of - JBUF_PASS_THRU: - begin - if (cinfo^.upsample^.need_context_rows) then - begin - main^.pub.process_data := process_data_context_main; - make_funny_pointers(cinfo); { Create the xbuffer[] lists } - main^.whichptr := 0; { Read first iMCU row into xbuffer[0] } - main^.context_state := CTX_PREPARE_FOR_IMCU; - main^.iMCU_row_ctr := 0; - end - else - begin - { Simple case with no context needed } - main^.pub.process_data := process_data_simple_main; - end; - main^.buffer_full := FALSE; { Mark buffer empty } - main^.rowgroup_ctr := 0; - end; -{$ifdef QUANT_2PASS_SUPPORTED} - JBUF_CRANK_DEST: - { For last pass of 2-pass quantization, just crank the postprocessor } - main^.pub.process_data := process_data_crank_post; -{$endif} - else - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - end; -end; - - -{ Process some data. - This handles the simple case where no context is required. } - -{METHODDEF} -procedure process_data_simple_main (cinfo : j_decompress_ptr; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); -var - main : my_main_ptr; - rowgroups_avail : JDIMENSION; -var - main_buffer_ptr : JSAMPIMAGE; -begin - main := my_main_ptr (cinfo^.main); - main_buffer_ptr := JSAMPIMAGE(@(main^.buffer)); - - { Read input data if we haven't filled the main buffer yet } - if (not main^.buffer_full) then - begin - if (cinfo^.coef^.decompress_data (cinfo, main_buffer_ptr)=0) then - exit; { suspension forced, can do nothing more } - main^.buffer_full := TRUE; { OK, we have an iMCU row to work with } - end; - - { There are always min_DCT_scaled_size row groups in an iMCU row. } - rowgroups_avail := JDIMENSION (cinfo^.min_DCT_scaled_size); - { Note: at the bottom of the image, we may pass extra garbage row groups - to the postprocessor. The postprocessor has to check for bottom - of image anyway (at row resolution), so no point in us doing it too. } - - { Feed the postprocessor } - cinfo^.post^.post_process_data (cinfo, main_buffer_ptr, - main^.rowgroup_ctr, rowgroups_avail, - output_buf, out_row_ctr, out_rows_avail); - - { Has postprocessor consumed all the data yet? If so, mark buffer empty } - if (main^.rowgroup_ctr >= rowgroups_avail) then - begin - main^.buffer_full := FALSE; - main^.rowgroup_ctr := 0; - end; -end; - - -{ Process some data. - This handles the case where context rows must be provided. } - -{METHODDEF} -procedure process_data_context_main (cinfo : j_decompress_ptr; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); -var - main : my_main_ptr; -begin - main := my_main_ptr (cinfo^.main); - - { Read input data if we haven't filled the main buffer yet } - if (not main^.buffer_full) then - begin - if (cinfo^.coef^.decompress_data (cinfo, - main^.xbuffer[main^.whichptr])=0) then - exit; { suspension forced, can do nothing more } - main^.buffer_full := TRUE; { OK, we have an iMCU row to work with } - Inc(main^.iMCU_row_ctr); { count rows received } - end; - - { Postprocessor typically will not swallow all the input data it is handed - in one call (due to filling the output buffer first). Must be prepared - to exit and restart. This switch lets us keep track of how far we got. - Note that each case falls through to the next on successful completion. } - - case (main^.context_state) of - CTX_POSTPONED_ROW: - begin - { Call postprocessor using previously set pointers for postponed row } - cinfo^.post^.post_process_data (cinfo, main^.xbuffer[main^.whichptr], - main^.rowgroup_ctr, main^.rowgroups_avail, - output_buf, out_row_ctr, out_rows_avail); - if (main^.rowgroup_ctr < main^.rowgroups_avail) then - exit; { Need to suspend } - main^.context_state := CTX_PREPARE_FOR_IMCU; - if (out_row_ctr >= out_rows_avail) then - exit; { Postprocessor exactly filled output buf } - end; - end; - case (main^.context_state) of - CTX_POSTPONED_ROW, - CTX_PREPARE_FOR_IMCU: {FALLTHROUGH} - begin - { Prepare to process first M-1 row groups of this iMCU row } - main^.rowgroup_ctr := 0; - main^.rowgroups_avail := JDIMENSION (cinfo^.min_DCT_scaled_size - 1); - { Check for bottom of image: if so, tweak pointers to "duplicate" - the last sample row, and adjust rowgroups_avail to ignore padding rows. } - - if (main^.iMCU_row_ctr = cinfo^.total_iMCU_rows) then - set_bottom_pointers(cinfo); - main^.context_state := CTX_PROCESS_IMCU; - - end; - end; - case (main^.context_state) of - CTX_POSTPONED_ROW, - CTX_PREPARE_FOR_IMCU, {FALLTHROUGH} - CTX_PROCESS_IMCU: - begin - { Call postprocessor using previously set pointers } - cinfo^.post^.post_process_data (cinfo, main^.xbuffer[main^.whichptr], - main^.rowgroup_ctr, main^.rowgroups_avail, - output_buf, out_row_ctr, out_rows_avail); - if (main^.rowgroup_ctr < main^.rowgroups_avail) then - exit; { Need to suspend } - { After the first iMCU, change wraparound pointers to normal state } - if (main^.iMCU_row_ctr = 1) then - set_wraparound_pointers(cinfo); - { Prepare to load new iMCU row using other xbuffer list } - main^.whichptr := main^.whichptr xor 1; { 0=>1 or 1=>0 } - main^.buffer_full := FALSE; - { Still need to process last row group of this iMCU row, } - { which is saved at index M+1 of the other xbuffer } - main^.rowgroup_ctr := JDIMENSION (cinfo^.min_DCT_scaled_size + 1); - main^.rowgroups_avail := JDIMENSION (cinfo^.min_DCT_scaled_size + 2); - main^.context_state := CTX_POSTPONED_ROW; - end; - end; -end; - - -{ Process some data. - Final pass of two-pass quantization: just call the postprocessor. - Source data will be the postprocessor controller's internal buffer. } - -{$ifdef QUANT_2PASS_SUPPORTED} - -{METHODDEF} -procedure process_data_crank_post (cinfo : j_decompress_ptr; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); -var - in_row_group_ctr : JDIMENSION; -begin - in_row_group_ctr := 0; - cinfo^.post^.post_process_data (cinfo, JSAMPIMAGE (NIL), - in_row_group_ctr, - JDIMENSION(0), - output_buf, - out_row_ctr, - out_rows_avail); -end; - -{$endif} { QUANT_2PASS_SUPPORTED } - - -{ Initialize main buffer controller. } - -{GLOBAL} -procedure jinit_d_main_controller (cinfo : j_decompress_ptr; - need_full_buffer : boolean); -var - main : my_main_ptr; - ci, rgroup, ngroups : int; - compptr : jpeg_component_info_ptr; -begin - main := my_main_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_main_controller)) ); - cinfo^.main := jpeg_d_main_controller_ptr(main); - main^.pub.start_pass := start_pass_main; - - if (need_full_buffer) then { shouldn't happen } - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - - { Allocate the workspace. - ngroups is the number of row groups we need.} - - if (cinfo^.upsample^.need_context_rows) then - begin - if (cinfo^.min_DCT_scaled_size < 2) then { unsupported, see comments above } - ERREXIT(j_common_ptr(cinfo), JERR_NOTIMPL); - alloc_funny_pointers(cinfo); { Alloc space for xbuffer[] lists } - ngroups := cinfo^.min_DCT_scaled_size + 2; - end - else - begin - ngroups := cinfo^.min_DCT_scaled_size; - end; - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div - cinfo^.min_DCT_scaled_size; { height of a row group of component } - main^.buffer[ci] := cinfo^.mem^.alloc_sarray - (j_common_ptr(cinfo), JPOOL_IMAGE, - compptr^.width_in_blocks * LongWord(compptr^.DCT_scaled_size), - JDIMENSION (rgroup * ngroups)); - Inc(compptr); - end; -end; - -end. +unit imjdmainct; + + +{ This file is part of the Independent JPEG Group's software. + For conditions of distribution and use, see the accompanying README file. + + This file contains the main buffer controller for decompression. + The main buffer lies between the JPEG decompressor proper and the + post-processor; it holds downsampled data in the JPEG colorspace. + + Note that this code is bypassed in raw-data mode, since the application + supplies the equivalent of the main buffer in that case. } + +{ Original: jdmainct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + + +{ In the current system design, the main buffer need never be a full-image + buffer; any full-height buffers will be found inside the coefficient or + postprocessing controllers. Nonetheless, the main controller is not + trivial. Its responsibility is to provide context rows for upsampling/ + rescaling, and doing this in an efficient fashion is a bit tricky. + + Postprocessor input data is counted in "row groups". A row group + is defined to be (v_samp_factor * DCT_scaled_size / min_DCT_scaled_size) + sample rows of each component. (We require DCT_scaled_size values to be + chosen such that these numbers are integers. In practice DCT_scaled_size + values will likely be powers of two, so we actually have the stronger + condition that DCT_scaled_size / min_DCT_scaled_size is an integer.) + Upsampling will typically produce max_v_samp_factor pixel rows from each + row group (times any additional scale factor that the upsampler is + applying). + + The coefficient controller will deliver data to us one iMCU row at a time; + each iMCU row contains v_samp_factor * DCT_scaled_size sample rows, or + exactly min_DCT_scaled_size row groups. (This amount of data corresponds + to one row of MCUs when the image is fully interleaved.) Note that the + number of sample rows varies across components, but the number of row + groups does not. Some garbage sample rows may be included in the last iMCU + row at the bottom of the image. + + Depending on the vertical scaling algorithm used, the upsampler may need + access to the sample row(s) above and below its current input row group. + The upsampler is required to set need_context_rows TRUE at global + selection + time if so. When need_context_rows is FALSE, this controller can simply + obtain one iMCU row at a time from the coefficient controller and dole it + out as row groups to the postprocessor. + + When need_context_rows is TRUE, this controller guarantees that the buffer + passed to postprocessing contains at least one row group's worth of samples + above and below the row group(s) being processed. Note that the context + rows "above" the first passed row group appear at negative row offsets in + the passed buffer. At the top and bottom of the image, the required + context rows are manufactured by duplicating the first or last real sample + row; this avoids having special cases in the upsampling inner loops. + + The amount of context is fixed at one row group just because that's a + convenient number for this controller to work with. The existing + upsamplers really only need one sample row of context. An upsampler + supporting arbitrary output rescaling might wish for more than one row + group of context when shrinking the image; tough, we don't handle that. + (This is justified by the assumption that downsizing will be handled mostly + by adjusting the DCT_scaled_size values, so that the actual scale factor at + the upsample step needn't be much less than one.) + + To provide the desired context, we have to retain the last two row groups + of one iMCU row while reading in the next iMCU row. (The last row group + can't be processed until we have another row group for its below-context, + and so we have to save the next-to-last group too for its above-context.) + We could do this most simply by copying data around in our buffer, but + that'd be very slow. We can avoid copying any data by creating a rather + strange pointer structure. Here's how it works. We allocate a workspace + consisting of M+2 row groups (where M = min_DCT_scaled_size is the number + of row groups per iMCU row). We create two sets of redundant pointers to + the workspace. Labeling the physical row groups 0 to M+1, the synthesized + pointer lists look like this: + M+1 M-1 + master pointer --> 0 master pointer --> 0 + 1 1 + ... ... + M-3 M-3 + M-2 M + M-1 M+1 + M M-2 + M+1 M-1 + 0 0 + We read alternate iMCU rows using each master pointer; thus the last two + row groups of the previous iMCU row remain un-overwritten in the workspace. + The pointer lists are set up so that the required context rows appear to + be adjacent to the proper places when we pass the pointer lists to the + upsampler. + + The above pictures describe the normal state of the pointer lists. + At top and bottom of the image, we diddle the pointer lists to duplicate + the first or last sample row as necessary (this is cheaper than copying + sample rows around). + + This scheme breaks down if M < 2, ie, min_DCT_scaled_size is 1. In that + situation each iMCU row provides only one row group so the buffering logic + must be different (eg, we must read two iMCU rows before we can emit the + first row group). For now, we simply do not support providing context + rows when min_DCT_scaled_size is 1. That combination seems unlikely to + be worth providing --- if someone wants a 1/8th-size preview, they probably + want it quick and dirty, so a context-free upsampler is sufficient. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, +{$ifdef QUANT_2PASS_SUPPORTED} + imjquant2, +{$endif} + imjdeferr, + imjerror, + imjpeglib; + + +{GLOBAL} +procedure jinit_d_main_controller (cinfo : j_decompress_ptr; + need_full_buffer : boolean); + + +implementation + +{ Private buffer controller object } + +type + my_main_ptr = ^my_main_controller; + my_main_controller = record + pub : jpeg_d_main_controller; { public fields } + + { Pointer to allocated workspace (M or M+2 row groups). } + buffer : array[0..MAX_COMPONENTS-1] of JSAMPARRAY; + + buffer_full : boolean; { Have we gotten an iMCU row from decoder? } + rowgroup_ctr : JDIMENSION ; { counts row groups output to postprocessor } + + { Remaining fields are only used in the context case. } + + { These are the master pointers to the funny-order pointer lists. } + xbuffer : array[0..2-1] of JSAMPIMAGE; { pointers to weird pointer lists } + + whichptr : int; { indicates which pointer set is now in use } + context_state : int; { process_data state machine status } + rowgroups_avail : JDIMENSION; { row groups available to postprocessor } + iMCU_row_ctr : JDIMENSION; { counts iMCU rows to detect image top/bot } + end; { my_main_controller; } + + +{ context_state values: } +const + CTX_PREPARE_FOR_IMCU = 0; { need to prepare for MCU row } + CTX_PROCESS_IMCU = 1; { feeding iMCU to postprocessor } + CTX_POSTPONED_ROW = 2; { feeding postponed row group } + + +{ Forward declarations } +{METHODDEF} +procedure process_data_simple_main(cinfo : j_decompress_ptr; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); forward; +{METHODDEF} +procedure process_data_context_main (cinfo : j_decompress_ptr; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); forward; + +{$ifdef QUANT_2PASS_SUPPORTED} +{METHODDEF} +procedure process_data_crank_post (cinfo : j_decompress_ptr; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); forward; +{$endif} + + +{LOCAL} +procedure alloc_funny_pointers (cinfo : j_decompress_ptr); +{ Allocate space for the funny pointer lists. + This is done only once, not once per pass. } +var + main : my_main_ptr; + ci, rgroup : int; + M : int; + compptr : jpeg_component_info_ptr; + xbuf : JSAMPARRAY; +begin + main := my_main_ptr (cinfo^.main); + M := cinfo^.min_DCT_scaled_size; + + { Get top-level space for component array pointers. + We alloc both arrays with one call to save a few cycles. } + + main^.xbuffer[0] := JSAMPIMAGE ( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + cinfo^.num_components * 2 * SIZEOF(JSAMPARRAY)) ); + main^.xbuffer[1] := JSAMPIMAGE(@( main^.xbuffer[0]^[cinfo^.num_components] )); + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div + cinfo^.min_DCT_scaled_size; { height of a row group of component } + { Get space for pointer lists --- M+4 row groups in each list. + We alloc both pointer lists with one call to save a few cycles. } + + xbuf := JSAMPARRAY ( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + 2 * (rgroup * (M + 4)) * SIZEOF(JSAMPROW)) ); + Inc(JSAMPROW_PTR(xbuf), rgroup); { want one row group at negative offsets } + main^.xbuffer[0]^[ci] := xbuf; + Inc(JSAMPROW_PTR(xbuf), rgroup * (M + 4)); + main^.xbuffer[1]^[ci] := xbuf; + Inc(compptr); + end; +end; + +{LOCAL} +procedure make_funny_pointers (cinfo : j_decompress_ptr); +{ Create the funny pointer lists discussed in the comments above. + The actual workspace is already allocated (in main^.buffer), + and the space for the pointer lists is allocated too. + This routine just fills in the curiously ordered lists. + This will be repeated at the beginning of each pass. } +var + main : my_main_ptr; + ci, i, rgroup : int; + M : int; + compptr : jpeg_component_info_ptr; + buf, xbuf0, xbuf1 : JSAMPARRAY; +var + help_xbuf0 : JSAMPARRAY; { work around negative offsets } +begin + main := my_main_ptr (cinfo^.main); + M := cinfo^.min_DCT_scaled_size; + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div + cinfo^.min_DCT_scaled_size; { height of a row group of component } + xbuf0 := main^.xbuffer[0]^[ci]; + xbuf1 := main^.xbuffer[1]^[ci]; + { First copy the workspace pointers as-is } + buf := main^.buffer[ci]; + for i := 0 to pred(rgroup * (M + 2)) do + begin + xbuf0^[i] := buf^[i]; + xbuf1^[i] := buf^[i]; + end; + { In the second list, put the last four row groups in swapped order } + for i := 0 to pred(rgroup * 2) do + begin + xbuf1^[rgroup*(M-2) + i] := buf^[rgroup*M + i]; + xbuf1^[rgroup*M + i] := buf^[rgroup*(M-2) + i]; + end; + { The wraparound pointers at top and bottom will be filled later + (see set_wraparound_pointers, below). Initially we want the "above" + pointers to duplicate the first actual data line. This only needs + to happen in xbuffer[0]. } + + help_xbuf0 := xbuf0; + Dec(JSAMPROW_PTR(help_xbuf0), rgroup); + + for i := 0 to pred(rgroup) do + begin + {xbuf0^[i - rgroup] := xbuf0^[0];} + help_xbuf0^[i] := xbuf0^[0]; + end; + Inc(compptr); + end; +end; + + +{LOCAL} +procedure set_wraparound_pointers (cinfo : j_decompress_ptr); +{ Set up the "wraparound" pointers at top and bottom of the pointer lists. + This changes the pointer list state from top-of-image to the normal state. } +var + main : my_main_ptr; + ci, i, rgroup : int; + M : int; + compptr : jpeg_component_info_ptr; + xbuf0, xbuf1 : JSAMPARRAY; +var + help_xbuf0, + help_xbuf1 : JSAMPARRAY; { work around negative offsets } +begin + main := my_main_ptr (cinfo^.main); + M := cinfo^.min_DCT_scaled_size; + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div + cinfo^.min_DCT_scaled_size; { height of a row group of component } + xbuf0 := main^.xbuffer[0]^[ci]; + xbuf1 := main^.xbuffer[1]^[ci]; + + help_xbuf0 := xbuf0; + Dec(JSAMPROW_PTR(help_xbuf0), rgroup); + help_xbuf1 := xbuf1; + Dec(JSAMPROW_PTR(help_xbuf1), rgroup); + + for i := 0 to pred(rgroup) do + begin + {xbuf0^[i - rgroup] := xbuf0^[rgroup*(M+1) + i]; + xbuf1^[i - rgroup] := xbuf1^[rgroup*(M+1) + i];} + + help_xbuf0^[i] := xbuf0^[rgroup*(M+1) + i]; + help_xbuf1^[i] := xbuf1^[rgroup*(M+1) + i]; + + xbuf0^[rgroup*(M+2) + i] := xbuf0^[i]; + xbuf1^[rgroup*(M+2) + i] := xbuf1^[i]; + end; + Inc(compptr); + end; +end; + + +{LOCAL} +procedure set_bottom_pointers (cinfo : j_decompress_ptr); +{ Change the pointer lists to duplicate the last sample row at the bottom + of the image. whichptr indicates which xbuffer holds the final iMCU row. + Also sets rowgroups_avail to indicate number of nondummy row groups in row. } +var + main : my_main_ptr; + ci, i, rgroup, iMCUheight, rows_left : int; + compptr : jpeg_component_info_ptr; + xbuf : JSAMPARRAY; +begin + main := my_main_ptr (cinfo^.main); + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + { Count sample rows in one iMCU row and in one row group } + iMCUheight := compptr^.v_samp_factor * compptr^.DCT_scaled_size; + rgroup := iMCUheight div cinfo^.min_DCT_scaled_size; + { Count nondummy sample rows remaining for this component } + rows_left := int (compptr^.downsampled_height mod JDIMENSION (iMCUheight)); + if (rows_left = 0) then + rows_left := iMCUheight; + { Count nondummy row groups. Should get same answer for each component, + so we need only do it once. } + if (ci = 0) then + begin + main^.rowgroups_avail := JDIMENSION ((rows_left-1) div rgroup + 1); + end; + { Duplicate the last real sample row rgroup*2 times; this pads out the + last partial rowgroup and ensures at least one full rowgroup of context. } + + xbuf := main^.xbuffer[main^.whichptr]^[ci]; + for i := 0 to pred(rgroup * 2) do + begin + xbuf^[rows_left + i] := xbuf^[rows_left-1]; + end; + Inc(compptr); + end; +end; + + +{ Initialize for a processing pass. } + +{METHODDEF} +procedure start_pass_main (cinfo : j_decompress_ptr; + pass_mode : J_BUF_MODE); +var + main : my_main_ptr; +begin + main := my_main_ptr (cinfo^.main); + + case (pass_mode) of + JBUF_PASS_THRU: + begin + if (cinfo^.upsample^.need_context_rows) then + begin + main^.pub.process_data := process_data_context_main; + make_funny_pointers(cinfo); { Create the xbuffer[] lists } + main^.whichptr := 0; { Read first iMCU row into xbuffer[0] } + main^.context_state := CTX_PREPARE_FOR_IMCU; + main^.iMCU_row_ctr := 0; + end + else + begin + { Simple case with no context needed } + main^.pub.process_data := process_data_simple_main; + end; + main^.buffer_full := FALSE; { Mark buffer empty } + main^.rowgroup_ctr := 0; + end; +{$ifdef QUANT_2PASS_SUPPORTED} + JBUF_CRANK_DEST: + { For last pass of 2-pass quantization, just crank the postprocessor } + main^.pub.process_data := process_data_crank_post; +{$endif} + else + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + end; +end; + + +{ Process some data. + This handles the simple case where no context is required. } + +{METHODDEF} +procedure process_data_simple_main (cinfo : j_decompress_ptr; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); +var + main : my_main_ptr; + rowgroups_avail : JDIMENSION; +var + main_buffer_ptr : JSAMPIMAGE; +begin + main := my_main_ptr (cinfo^.main); + main_buffer_ptr := JSAMPIMAGE(@(main^.buffer)); + + { Read input data if we haven't filled the main buffer yet } + if (not main^.buffer_full) then + begin + if (cinfo^.coef^.decompress_data (cinfo, main_buffer_ptr)=0) then + exit; { suspension forced, can do nothing more } + main^.buffer_full := TRUE; { OK, we have an iMCU row to work with } + end; + + { There are always min_DCT_scaled_size row groups in an iMCU row. } + rowgroups_avail := JDIMENSION (cinfo^.min_DCT_scaled_size); + { Note: at the bottom of the image, we may pass extra garbage row groups + to the postprocessor. The postprocessor has to check for bottom + of image anyway (at row resolution), so no point in us doing it too. } + + { Feed the postprocessor } + cinfo^.post^.post_process_data (cinfo, main_buffer_ptr, + main^.rowgroup_ctr, rowgroups_avail, + output_buf, out_row_ctr, out_rows_avail); + + { Has postprocessor consumed all the data yet? If so, mark buffer empty } + if (main^.rowgroup_ctr >= rowgroups_avail) then + begin + main^.buffer_full := FALSE; + main^.rowgroup_ctr := 0; + end; +end; + + +{ Process some data. + This handles the case where context rows must be provided. } + +{METHODDEF} +procedure process_data_context_main (cinfo : j_decompress_ptr; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); +var + main : my_main_ptr; +begin + main := my_main_ptr (cinfo^.main); + + { Read input data if we haven't filled the main buffer yet } + if (not main^.buffer_full) then + begin + if (cinfo^.coef^.decompress_data (cinfo, + main^.xbuffer[main^.whichptr])=0) then + exit; { suspension forced, can do nothing more } + main^.buffer_full := TRUE; { OK, we have an iMCU row to work with } + Inc(main^.iMCU_row_ctr); { count rows received } + end; + + { Postprocessor typically will not swallow all the input data it is handed + in one call (due to filling the output buffer first). Must be prepared + to exit and restart. This switch lets us keep track of how far we got. + Note that each case falls through to the next on successful completion. } + + case (main^.context_state) of + CTX_POSTPONED_ROW: + begin + { Call postprocessor using previously set pointers for postponed row } + cinfo^.post^.post_process_data (cinfo, main^.xbuffer[main^.whichptr], + main^.rowgroup_ctr, main^.rowgroups_avail, + output_buf, out_row_ctr, out_rows_avail); + if (main^.rowgroup_ctr < main^.rowgroups_avail) then + exit; { Need to suspend } + main^.context_state := CTX_PREPARE_FOR_IMCU; + if (out_row_ctr >= out_rows_avail) then + exit; { Postprocessor exactly filled output buf } + end; + end; + case (main^.context_state) of + CTX_POSTPONED_ROW, + CTX_PREPARE_FOR_IMCU: {FALLTHROUGH} + begin + { Prepare to process first M-1 row groups of this iMCU row } + main^.rowgroup_ctr := 0; + main^.rowgroups_avail := JDIMENSION (cinfo^.min_DCT_scaled_size - 1); + { Check for bottom of image: if so, tweak pointers to "duplicate" + the last sample row, and adjust rowgroups_avail to ignore padding rows. } + + if (main^.iMCU_row_ctr = cinfo^.total_iMCU_rows) then + set_bottom_pointers(cinfo); + main^.context_state := CTX_PROCESS_IMCU; + + end; + end; + case (main^.context_state) of + CTX_POSTPONED_ROW, + CTX_PREPARE_FOR_IMCU, {FALLTHROUGH} + CTX_PROCESS_IMCU: + begin + { Call postprocessor using previously set pointers } + cinfo^.post^.post_process_data (cinfo, main^.xbuffer[main^.whichptr], + main^.rowgroup_ctr, main^.rowgroups_avail, + output_buf, out_row_ctr, out_rows_avail); + if (main^.rowgroup_ctr < main^.rowgroups_avail) then + exit; { Need to suspend } + { After the first iMCU, change wraparound pointers to normal state } + if (main^.iMCU_row_ctr = 1) then + set_wraparound_pointers(cinfo); + { Prepare to load new iMCU row using other xbuffer list } + main^.whichptr := main^.whichptr xor 1; { 0=>1 or 1=>0 } + main^.buffer_full := FALSE; + { Still need to process last row group of this iMCU row, } + { which is saved at index M+1 of the other xbuffer } + main^.rowgroup_ctr := JDIMENSION (cinfo^.min_DCT_scaled_size + 1); + main^.rowgroups_avail := JDIMENSION (cinfo^.min_DCT_scaled_size + 2); + main^.context_state := CTX_POSTPONED_ROW; + end; + end; +end; + + +{ Process some data. + Final pass of two-pass quantization: just call the postprocessor. + Source data will be the postprocessor controller's internal buffer. } + +{$ifdef QUANT_2PASS_SUPPORTED} + +{METHODDEF} +procedure process_data_crank_post (cinfo : j_decompress_ptr; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); +var + in_row_group_ctr : JDIMENSION; +begin + in_row_group_ctr := 0; + cinfo^.post^.post_process_data (cinfo, JSAMPIMAGE (NIL), + in_row_group_ctr, + JDIMENSION(0), + output_buf, + out_row_ctr, + out_rows_avail); +end; + +{$endif} { QUANT_2PASS_SUPPORTED } + + +{ Initialize main buffer controller. } + +{GLOBAL} +procedure jinit_d_main_controller (cinfo : j_decompress_ptr; + need_full_buffer : boolean); +var + main : my_main_ptr; + ci, rgroup, ngroups : int; + compptr : jpeg_component_info_ptr; +begin + main := my_main_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_main_controller)) ); + cinfo^.main := jpeg_d_main_controller_ptr(main); + main^.pub.start_pass := start_pass_main; + + if (need_full_buffer) then { shouldn't happen } + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + + { Allocate the workspace. + ngroups is the number of row groups we need.} + + if (cinfo^.upsample^.need_context_rows) then + begin + if (cinfo^.min_DCT_scaled_size < 2) then { unsupported, see comments above } + ERREXIT(j_common_ptr(cinfo), JERR_NOTIMPL); + alloc_funny_pointers(cinfo); { Alloc space for xbuffer[] lists } + ngroups := cinfo^.min_DCT_scaled_size + 2; + end + else + begin + ngroups := cinfo^.min_DCT_scaled_size; + end; + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + rgroup := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div + cinfo^.min_DCT_scaled_size; { height of a row group of component } + main^.buffer[ci] := cinfo^.mem^.alloc_sarray + (j_common_ptr(cinfo), JPOOL_IMAGE, + compptr^.width_in_blocks * uInt(compptr^.DCT_scaled_size), + JDIMENSION (rgroup * ngroups)); + Inc(compptr); + end; +end; + +end. diff --git a/Imaging/JpegLib/imjdmarker.pas b/Imaging/JpegLib/imjdmarker.pas index 23cb9fa..6aa30b5 100644 --- a/Imaging/JpegLib/imjdmarker.pas +++ b/Imaging/JpegLib/imjdmarker.pas @@ -1,2644 +1,2648 @@ -unit imjdmarker; - -{ This file contains routines to decode JPEG datastream markers. - Most of the complexity arises from our desire to support input - suspension: if not all of the data for a marker is available; - we must exit back to the application. On resumption; we reprocess - the marker. } - -{ Original: jdmarker.c; Copyright (C) 1991-1998; Thomas G. Lane. } -{ History - 9.7.96 Conversion to pascal started jnn - 22.3.98 updated to 6b jnn } - - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjcomapi, - imjpeglib; - -const { JPEG marker codes } - M_SOF0 = $c0; - M_SOF1 = $c1; - M_SOF2 = $c2; - M_SOF3 = $c3; - - M_SOF5 = $c5; - M_SOF6 = $c6; - M_SOF7 = $c7; - - M_JPG = $c8; - M_SOF9 = $c9; - M_SOF10 = $ca; - M_SOF11 = $cb; - - M_SOF13 = $cd; - M_SOF14 = $ce; - M_SOF15 = $cf; - - M_DHT = $c4; - - M_DAC = $cc; - - M_RST0 = $d0; - M_RST1 = $d1; - M_RST2 = $d2; - M_RST3 = $d3; - M_RST4 = $d4; - M_RST5 = $d5; - M_RST6 = $d6; - M_RST7 = $d7; - - M_SOI = $d8; - M_EOI = $d9; - M_SOS = $da; - M_DQT = $db; - M_DNL = $dc; - M_DRI = $dd; - M_DHP = $de; - M_EXP = $df; - - M_APP0 = $e0; - M_APP1 = $e1; - M_APP2 = $e2; - M_APP3 = $e3; - M_APP4 = $e4; - M_APP5 = $e5; - M_APP6 = $e6; - M_APP7 = $e7; - M_APP8 = $e8; - M_APP9 = $e9; - M_APP10 = $ea; - M_APP11 = $eb; - M_APP12 = $ec; - M_APP13 = $ed; - M_APP14 = $ee; - M_APP15 = $ef; - - M_JPG0 = $f0; - M_JPG13 = $fd; - M_COM = $fe; - - M_TEM = $01; - - M_ERROR = $100; - -type - JPEG_MARKER = uint; { JPEG marker codes } - -{ Private state } - -type - my_marker_ptr = ^my_marker_reader; - my_marker_reader = record - pub : jpeg_marker_reader; { public fields } - - { Application-overridable marker processing methods } - process_COM : jpeg_marker_parser_method; - process_APPn : array[0..16-1] of jpeg_marker_parser_method; - - { Limit on marker data length to save for each marker type } - length_limit_COM : uint; - length_limit_APPn : array[0..16-1] of uint; - - { Status of COM/APPn marker saving } - cur_marker : jpeg_saved_marker_ptr; { NIL if not processing a marker } - bytes_read : uint; { data bytes read so far in marker } - { Note: cur_marker is not linked into marker_list until it's all read. } - end; - -{GLOBAL} -function jpeg_resync_to_restart(cinfo : j_decompress_ptr; - desired : int) : boolean; -{GLOBAL} -procedure jinit_marker_reader (cinfo : j_decompress_ptr); - -{$ifdef SAVE_MARKERS_SUPPORTED} - -{GLOBAL} -procedure jpeg_save_markers (cinfo : j_decompress_ptr; - marker_code : int; - length_limit : uint); -{$ENDIF} - -{GLOBAL} -procedure jpeg_set_marker_processor (cinfo : j_decompress_ptr; - marker_code : int; - routine : jpeg_marker_parser_method); - -implementation - -uses - imjutils; - -{ At all times, cinfo1.src.next_input_byte and .bytes_in_buffer reflect - the current restart point; we update them only when we have reached a - suitable place to restart if a suspension occurs. } - - -{ Routines to process JPEG markers. - - Entry condition: JPEG marker itself has been read and its code saved - in cinfo^.unread_marker; input restart point is just after the marker. - - Exit: if return TRUE, have read and processed any parameters, and have - updated the restart point to point after the parameters. - If return FALSE, was forced to suspend before reaching end of - marker parameters; restart point has not been moved. Same routine - will be called again after application supplies more input data. - - This approach to suspension assumes that all of a marker's parameters - can fit into a single input bufferload. This should hold for "normal" - markers. Some COM/APPn markers might have large parameter segments - that might not fit. If we are simply dropping such a marker, we use - skip_input_data to get past it, and thereby put the problem on the - source manager's shoulders. If we are saving the marker's contents - into memory, we use a slightly different convention: when forced to - suspend, the marker processor updates the restart point to the end of - what it's consumed (ie, the end of the buffer) before returning FALSE. - On resumption, cinfo->unread_marker still contains the marker code, - but the data source will point to the next chunk of marker data. - The marker processor must retain internal state to deal with this. - - Note that we don't bother to avoid duplicate trace messages if a - suspension occurs within marker parameters. Other side effects - require more care. } - -{LOCAL} -function get_soi (cinfo : j_decompress_ptr) : boolean; -{ Process an SOI marker } -var - i : int; -begin - {$IFDEF DEBUG} - TRACEMS(j_common_ptr(cinfo), 1, JTRC_SOI); - {$ENDIF} - - if (cinfo^.marker^.saw_SOI) then - ERREXIT(j_common_ptr(cinfo), JERR_SOI_DUPLICATE); - - { Reset all parameters that are defined to be reset by SOI } - - for i := 0 to Pred(NUM_ARITH_TBLS) do - with cinfo^ do - begin - arith_dc_L[i] := 0; - arith_dc_U[i] := 1; - arith_ac_K[i] := 5; - end; - cinfo^.restart_interval := 0; - - { Set initial assumptions for colorspace etc } - - with cinfo^ do - begin - jpeg_color_space := JCS_UNKNOWN; - CCIR601_sampling := FALSE; { Assume non-CCIR sampling??? } - - saw_JFIF_marker := FALSE; - JFIF_major_version := 1; { set default JFIF APP0 values } - JFIF_minor_version := 1; - density_unit := 0; - X_density := 1; - Y_density := 1; - saw_Adobe_marker := FALSE; - Adobe_transform := 0; - - marker^.saw_SOI := TRUE; - end; - get_soi := TRUE; -end; { get_soi } - - -{LOCAL} -function get_sof(cinfo : j_decompress_ptr; - is_prog : boolean; - is_arith : boolean) : boolean; -{ Process a SOFn marker } -var - length : INT32; - c, ci : int; - compptr : jpeg_component_info_ptr; -{ Declare and initialize local copies of input pointer/count } -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; - bytes_in_buffer : size_t; -begin - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; -{} - cinfo^.progressive_mode := is_prog; - cinfo^.arith_code := is_arith; - -{ Read two bytes interpreted as an unsigned 16-bit integer. - length should be declared unsigned int or perhaps INT32. } - -{ make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - length := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( length, GETJOCTET( next_input_byte^)); - Inc( next_input_byte ); - - - { Read a byte into variable cinfo^.data_precision. - If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - cinfo^.data_precision := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - -{ Read two bytes interpreted as an unsigned 16-bit integer. - cinfo^.image_height should be declared unsigned int or perhaps INT32. } - -{ make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - cinfo^.image_height := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( cinfo^.image_height, GETJOCTET( next_input_byte^)); - Inc( next_input_byte ); - -{ Read two bytes interpreted as an unsigned 16-bit integer. - cinfo^.image_width should be declared unsigned int or perhaps INT32. } - -{ make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - cinfo^.image_width := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( cinfo^.image_width, GETJOCTET( next_input_byte^)); - Inc( next_input_byte ); - - { Read a byte into variable cinfo^.num_components. - If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - cinfo^.num_components := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - Dec(length, 8); - - {$IFDEF DEBUG} - TRACEMS4(j_common_ptr(cinfo), 1, JTRC_SOF, cinfo^.unread_marker, - int(cinfo^.image_width), int(cinfo^.image_height), - cinfo^.num_components); - {$ENDIF} - - if (cinfo^.marker^.saw_SOF) then - ERREXIT(j_common_ptr(cinfo), JERR_SOF_DUPLICATE); - - { We don't support files in which the image height is initially specified } - { as 0 and is later redefined by DNL. As long as we have to check that, } - { might as well have a general sanity check. } - if (cinfo^.image_height <= 0) or (cinfo^.image_width <= 0) - or (cinfo^.num_components <= 0) then - ERREXIT(j_common_ptr(cinfo), JERR_EMPTY_IMAGE); - - if (length <> (cinfo^.num_components * 3)) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); - - if (cinfo^.comp_info = NIL) then { do only once, even if suspend } - cinfo^.comp_info := jpeg_component_info_list_ptr( - cinfo^.mem^.alloc_small(j_common_ptr(cinfo), JPOOL_IMAGE, - cinfo^.num_components * SIZEOF(jpeg_component_info))); - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - compptr^.component_index := ci; - - { Read a byte into variable compptr^.component_id. - If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - compptr^.component_id := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - { Read a byte into variable c. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - compptr^.h_samp_factor := (c shr 4) and 15; - compptr^.v_samp_factor := (c ) and 15; - - { Read a byte into variable compptr^.quant_tbl_no. - If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sof := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - compptr^.quant_tbl_no := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - {$IFDEF DEBUG} - TRACEMS4(j_common_ptr(cinfo), 1, JTRC_SOF_COMPONENT, - compptr^.component_id, compptr^.h_samp_factor, - compptr^.v_samp_factor, compptr^.quant_tbl_no); - {$ENDIF} - - Inc(compptr); - end; - - cinfo^.marker^.saw_SOF := TRUE; - - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - get_sof := TRUE; -end; { get_sof } - - -{LOCAL} -function get_sos (cinfo : j_decompress_ptr) : boolean; -{ Process a SOS marker } -label - id_found; -var - length : INT32; - i, ci, n, c, cc : int; - compptr : jpeg_component_info_ptr; -{ Declare and initialize local copies of input pointer/count } -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; { Array[] of JOCTET; } - bytes_in_buffer : size_t; -begin - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - -{} - - if not cinfo^.marker^.saw_SOF then - ERREXIT(j_common_ptr(cinfo), JERR_SOS_NO_SOF); - -{ Read two bytes interpreted as an unsigned 16-bit integer. - length should be declared unsigned int or perhaps INT32. } - -{ make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sos := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - length := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sos := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( length, GETJOCTET( next_input_byte^)); - Inc( next_input_byte ); - - - { Read a byte into variable n (Number of components). - If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sos := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - n := GETJOCTET(next_input_byte^); { Number of components } - Inc(next_input_byte); - - {$IFDEF DEBUG} - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_SOS, n); - {$ENDIF} - - if ((length <> (n * 2 + 6)) or (n < 1) or (n > MAX_COMPS_IN_SCAN)) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); - - cinfo^.comps_in_scan := n; - - { Collect the component-spec parameters } - - for i := 0 to Pred(n) do - begin - { Read a byte into variable cc. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sos := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - cc := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - { Read a byte into variable c. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sos := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to Pred(cinfo^.num_components) do - begin - if (cc = compptr^.component_id) then - goto id_found; - Inc(compptr); - end; - - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_COMPONENT_ID, cc); - - id_found: - - cinfo^.cur_comp_info[i] := compptr; - compptr^.dc_tbl_no := (c shr 4) and 15; - compptr^.ac_tbl_no := (c ) and 15; - - {$IFDEF DEBUG} - TRACEMS3(j_common_ptr(cinfo), 1, JTRC_SOS_COMPONENT, cc, - compptr^.dc_tbl_no, compptr^.ac_tbl_no); - {$ENDIF} - end; - - { Collect the additional scan parameters Ss, Se, Ah/Al. } - { Read a byte into variable c. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sos := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - cinfo^.Ss := c; - - { Read a byte into variable c. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sos := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - cinfo^.Se := c; - - { Read a byte into variable c. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_sos := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - cinfo^.Ah := (c shr 4) and 15; - cinfo^.Al := (c ) and 15; - - {$IFDEF DEBUG} - TRACEMS4(j_common_ptr(cinfo), 1, JTRC_SOS_PARAMS, cinfo^.Ss, cinfo^.Se, - cinfo^.Ah, cinfo^.Al); - {$ENDIF} - - { Prepare to scan data & restart markers } - cinfo^.marker^.next_restart_num := 0; - - { Count another SOS marker } - Inc( cinfo^.input_scan_number ); - - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - get_sos := TRUE; -end; { get_sos } - - -{METHODDEF} -function skip_variable (cinfo : j_decompress_ptr) : boolean; -{ Skip over an unknown or uninteresting variable-length marker } -var - length : INT32; -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; { Array[] of JOCTET; } - bytes_in_buffer : size_t; -begin - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - -{ Read two bytes interpreted as an unsigned 16-bit integer. - length should be declared unsigned int or perhaps INT32. } - -{ make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - skip_variable := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - length := uint(GETJOCTET(next_input_byte^)) shl 8; - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - skip_variable := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( length, GETJOCTET(next_input_byte^)); - Inc( next_input_byte ); - - Dec(length, 2); - - {$IFDEF DEBUG} - TRACEMS2(j_common_ptr(cinfo), 1, JTRC_MISC_MARKER, - cinfo^.unread_marker, int(length)); - {$ENDIF} - - { Unload the local copies --- do this only at a restart boundary } - { do before skip_input_data } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - if (length > 0) then - cinfo^.src^.skip_input_data(cinfo, long(length)); - - skip_variable := TRUE; -end; { skip_variable } - - -{$IFDEF D_ARITH_CODING_SUPPORTED} - -{LOCAL} -function get_dac (cinfo : j_decompress_ptr) : boolean; -{ Process a DAC marker } -var - length : INT32; - index, val : int; -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; - bytes_in_buffer : size_t; -begin - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - -{ Read two bytes interpreted as an unsigned 16-bit integer. - length should be declared unsigned int or perhaps INT32. } - -{ make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dac := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - length := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dac := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( length, GETJOCTET( next_input_byte^)); - Inc( next_input_byte ); - - Dec(length, 2); - - while (length > 0) do - begin - { Read a byte into variable index. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dac := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - index := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - { Read a byte into variable val. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dac := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - val := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - Dec( length, 2); - - {$IFDEF DEBUG} - TRACEMS2(j_common_ptr(cinfo), 1, JTRC_DAC, index, val); - {$ENDIF} - - if (index < 0) or (index >= (2*NUM_ARITH_TBLS)) then - ERREXIT1(j_common_ptr(cinfo) , JERR_DAC_INDEX, index); - - if (index >= NUM_ARITH_TBLS) then - begin { define AC table } - cinfo^.arith_ac_K[index-NUM_ARITH_TBLS] := UINT8(val); - end - else - begin { define DC table } - cinfo^.arith_dc_L[index] := UINT8(val and $0F); - cinfo^.arith_dc_U[index] := UINT8(val shr 4); - if (cinfo^.arith_dc_L[index] > cinfo^.arith_dc_U[index]) then - ERREXIT1(j_common_ptr(cinfo) , JERR_DAC_VALUE, val); - end; - end; - - if (length <> 0) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); - - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - get_dac := TRUE; -end; { get_dac } - -{$ELSE} - -{LOCAL} -function get_dac (cinfo : j_decompress_ptr) : boolean; -begin - get_dac := skip_variable(cinfo); -end; - -{$ENDIF} - -{LOCAL} -function get_dht (cinfo : j_decompress_ptr) : boolean; -{ Process a DHT marker } -var - length : INT32; - bits : Array[0..17-1] of UINT8; - huffval : Array[0..256-1] of UINT8; - i, index, count : int; - htblptr : ^JHUFF_TBL_PTR; -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; - bytes_in_buffer : size_t; -begin - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - -{ Read two bytes interpreted as an unsigned 16-bit integer. - length should be declared unsigned int or perhaps INT32. } - -{ make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dht := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - length := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dht := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( length, GETJOCTET( next_input_byte^)); - Inc( next_input_byte ); - - Dec(length, 2); - - while (length > 16) do - begin - { Read a byte into variable index. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dht := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - index := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - {$IFDEF DEBUG} - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_DHT, index); - {$ENDIF} - - bits[0] := 0; - count := 0; - for i := 1 to 16 do - begin - { Read a byte into variable bits[i]. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dht := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - bits[i] := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - Inc( count, bits[i] ); - end; - - Dec( length, (1 + 16) ); - - {$IFDEF DEBUG} - TRACEMS8(j_common_ptr(cinfo), 2, JTRC_HUFFBITS, - bits[1], bits[2], bits[3], bits[4], - bits[5], bits[6], bits[7], bits[8]); - TRACEMS8(j_common_ptr(cinfo), 2, JTRC_HUFFBITS, - bits[9], bits[10], bits[11], bits[12], - bits[13], bits[14], bits[15], bits[16]); - {$ENDIF} - - { Here we just do minimal validation of the counts to avoid walking - off the end of our table space. jdhuff.c will check more carefully. } - - if (count > 256) or (INT32(count) > length) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); - - for i := 0 to Pred(count) do - begin - { Read a byte into variable huffval[i]. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dht := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - huffval[i] := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - end; - - Dec( length, count ); - - if (index and $10)<>0 then - begin { AC table definition } - Dec( index, $10 ); - htblptr := @cinfo^.ac_huff_tbl_ptrs[index]; - end - else - begin { DC table definition } - htblptr := @cinfo^.dc_huff_tbl_ptrs[index]; - end; - - if (index < 0) or (index >= NUM_HUFF_TBLS) then - ERREXIT1(j_common_ptr(cinfo), JERR_DHT_INDEX, index); - - if (htblptr^ = NIL) then - htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo)); - - MEMCOPY(@(htblptr^)^.bits, @bits, SIZEOF((htblptr^)^.bits)); - MEMCOPY(@(htblptr^)^.huffval, @huffval, SIZEOF((htblptr^)^.huffval)); - end; - - if (length <> 0) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); - - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - get_dht := TRUE; -end; { get_dht } - - -{LOCAL} -function get_dqt (cinfo : j_decompress_ptr) : boolean; -{ Process a DQT marker } -var - length : INT32; - n, i, prec : int; - tmp : uint; - quant_ptr : JQUANT_TBL_PTR; -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; - bytes_in_buffer : size_t; -begin - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - -{ Read two bytes interpreted as an unsigned 16-bit integer. - length should be declared unsigned int or perhaps INT32. } - -{ make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dqt := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - length := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dqt := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( length, GETJOCTET( next_input_byte^)); - Inc( next_input_byte ); - - Dec( length, 2 ); - - while (length > 0) do - begin - { Read a byte into variable n. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dqt := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - n := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - prec := n shr 4; - n := n and $0F; - - {$IFDEF DEBUG} - TRACEMS2(j_common_ptr(cinfo), 1, JTRC_DQT, n, prec); - {$ENDIF} - - if (n >= NUM_QUANT_TBLS) then - ERREXIT1(j_common_ptr(cinfo) , JERR_DQT_INDEX, n); - - if (cinfo^.quant_tbl_ptrs[n] = NIL) then - cinfo^.quant_tbl_ptrs[n] := jpeg_alloc_quant_table(j_common_ptr(cinfo)); - quant_ptr := cinfo^.quant_tbl_ptrs[n]; - - for i := 0 to Pred(DCTSIZE2) do - begin - if (prec <> 0) then - begin - { Read two bytes interpreted as an unsigned 16-bit integer. - tmp should be declared unsigned int or perhaps INT32. } - - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dqt := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - tmp := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dqt := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( tmp, GETJOCTET( next_input_byte^)); - Inc( next_input_byte ); - - end - else - begin - { Read a byte into variable tmp. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dqt := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - tmp := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - end; - - { We convert the zigzag-order table to natural array order. } - quant_ptr^.quantval[jpeg_natural_order[i]] := UINT16(tmp); - end; - - if (cinfo^.err^.trace_level >= 2) then - begin - i := 0; - while i < Pred(DCTSIZE2) do - begin - {$IFDEF DEBUG} - TRACEMS8(j_common_ptr(cinfo), 2, JTRC_QUANTVALS, - quant_ptr^.quantval[i], quant_ptr^.quantval[i+1], - quant_ptr^.quantval[i+2], quant_ptr^.quantval[i+3], - quant_ptr^.quantval[i+4], quant_ptr^.quantval[i+5], - quant_ptr^.quantval[i+6], quant_ptr^.quantval[i+7]); - {$ENDIF} - Inc(i, 8); - end; - end; - - Dec( length, DCTSIZE2+1 ); - if (prec <> 0) then - Dec( length, DCTSIZE2 ); - end; - - if (length <> 0) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); - - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - get_dqt := TRUE; -end; { get_dqt } - - -{LOCAL} -function get_dri (cinfo : j_decompress_ptr) : boolean; -{ Process a DRI marker } -var - length : INT32; - tmp : uint; -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; - bytes_in_buffer : size_t; -begin - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - -{ Read two bytes interpreted as an unsigned 16-bit integer. - length should be declared unsigned int or perhaps INT32. } - -{ make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dri := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - length := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dri := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( length, GETJOCTET( next_input_byte^)); - Inc( next_input_byte ); - - if (length <> 4) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); - -{ Read two bytes interpreted as an unsigned 16-bit integer. - tmp should be declared unsigned int or perhaps INT32. } - -{ make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dri := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - tmp := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_dri := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( tmp, GETJOCTET( next_input_byte^)); - Inc( next_input_byte ); - - {$IFDEF DEBUG} - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_DRI, tmp); - {$ENDIF} - - cinfo^.restart_interval := tmp; - - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - get_dri := TRUE; -end; { get_dri } - - -{ Routines for processing APPn and COM markers. - These are either saved in memory or discarded, per application request. - APP0 and APP14 are specially checked to see if they are - JFIF and Adobe markers, respectively. } - -const - APP0_DATA_LEN = 14; { Length of interesting data in APP0 } - APP14_DATA_LEN = 12; { Length of interesting data in APP14 } - APPN_DATA_LEN = 14; { Must be the largest of the above!! } - - -{LOCAL} -procedure examine_app0 (cinfo : j_decompress_ptr; - var data : array of JOCTET; - datalen : uint; - remaining : INT32); - -{ Examine first few bytes from an APP0. - Take appropriate action if it is a JFIF marker. - datalen is # of bytes at data[], remaining is length of rest of marker data. -} -{$IFDEF DEBUG} -var - totallen : INT32; -{$ENDIF} -begin - {$IFDEF DEBUG} - totallen := INT32(datalen) + remaining; - {$ENDIF} - if (datalen >= APP0_DATA_LEN) and - (GETJOCTET(data[0]) = $4A) and - (GETJOCTET(data[1]) = $46) and - (GETJOCTET(data[2]) = $49) and - (GETJOCTET(data[3]) = $46) and - (GETJOCTET(data[4]) = 0) then - begin - { Found JFIF APP0 marker: save info } - cinfo^.saw_JFIF_marker := TRUE; - cinfo^.JFIF_major_version := GETJOCTET(data[5]); - cinfo^.JFIF_minor_version := GETJOCTET(data[6]); - cinfo^.density_unit := GETJOCTET(data[7]); - cinfo^.X_density := (GETJOCTET(data[8]) shl 8) + GETJOCTET(data[9]); - cinfo^.Y_density := (GETJOCTET(data[10]) shl 8) + GETJOCTET(data[11]); - { Check version. - Major version must be 1, anything else signals an incompatible change. - (We used to treat this as an error, but now it's a nonfatal warning, - because some bozo at Hijaak couldn't read the spec.) - Minor version should be 0..2, but process anyway if newer. } - - if (cinfo^.JFIF_major_version <> 1) then - WARNMS2(j_common_ptr(cinfo), JWRN_JFIF_MAJOR, - cinfo^.JFIF_major_version, cinfo^.JFIF_minor_version); - { Generate trace messages } - {$IFDEF DEBUG} - TRACEMS5(j_common_ptr(cinfo), 1, JTRC_JFIF, - cinfo^.JFIF_major_version, cinfo^.JFIF_minor_version, - cinfo^.X_density, cinfo^.Y_density, cinfo^.density_unit); - { Validate thumbnail dimensions and issue appropriate messages } - if (GETJOCTET(data[12]) or GETJOCTET(data[13])) <> 0 then - TRACEMS2(j_common_ptr(cinfo), 1, JTRC_JFIF_THUMBNAIL, - GETJOCTET(data[12]), GETJOCTET(data[13])); - Dec(totallen, APP0_DATA_LEN); - if (totallen <> - ( INT32(GETJOCTET(data[12])) * INT32(GETJOCTET(data[13])) * INT32(3) )) then - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_JFIF_BADTHUMBNAILSIZE, int(totallen)); - {$ENDIF} - end - else - if (datalen >= 6) and - (GETJOCTET(data[0]) = $4A) and - (GETJOCTET(data[1]) = $46) and - (GETJOCTET(data[2]) = $58) and - (GETJOCTET(data[3]) = $58) and - (GETJOCTET(data[4]) = 0) then - begin - { Found JFIF "JFXX" extension APP0 marker } - { The library doesn't actually do anything with these, - but we try to produce a helpful trace message. } - {$IFDEF DEBUG} - case (GETJOCTET(data[5])) of - $10: - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_THUMB_JPEG, int(totallen)); - $11: - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_THUMB_PALETTE, int(totallen)); - $13: - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_THUMB_RGB, int(totallen)); - else - TRACEMS2(j_common_ptr(cinfo), 1, JTRC_JFIF_EXTENSION, - GETJOCTET(data[5]), int(totallen)); - end; - {$ENDIF} - end - else - begin - { Start of APP0 does not match "JFIF" or "JFXX", or too short } - {$IFDEF DEBUG} - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_APP0, int(totallen)); - {$ENDIF} - end; -end; - - -{LOCAL} -procedure examine_app14 (cinfo : j_decompress_ptr; - var data : array of JOCTET; - datalen : uint; - remaining : INT32); -{ Examine first few bytes from an APP14. - Take appropriate action if it is an Adobe marker. - datalen is # of bytes at data[], remaining is length of rest of marker data. - } -var - {$IFDEF DEBUG} - version, flags0, flags1, - {$ENDIF} - transform : uint; -begin - if (datalen >= APP14_DATA_LEN) and - (GETJOCTET(data[0]) = $41) and - (GETJOCTET(data[1]) = $64) and - (GETJOCTET(data[2]) = $6F) and - (GETJOCTET(data[3]) = $62) and - (GETJOCTET(data[4]) = $65) then - begin - { Found Adobe APP14 marker } - {$IFDEF DEBUG} - version := (GETJOCTET(data[5]) shl 8) + GETJOCTET(data[6]); - flags0 := (GETJOCTET(data[7]) shl 8) + GETJOCTET(data[8]); - flags1 := (GETJOCTET(data[9]) shl 8) + GETJOCTET(data[10]); - {$ENDIF} - transform := GETJOCTET(data[11]); - {$IFDEF DEBUG} - TRACEMS4(j_common_ptr(cinfo), 1, JTRC_ADOBE, version, flags0, flags1, transform); - {$ENDIF} - cinfo^.saw_Adobe_marker := TRUE; - cinfo^.Adobe_transform := UINT8 (transform); - end - else - begin - { Start of APP14 does not match "Adobe", or too short } - {$IFDEF DEBUG} - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_APP14, int (datalen + remaining)); - {$ENDIF} - end; -end; - - -{METHODDEF} -function get_interesting_appn (cinfo : j_decompress_ptr) : boolean; -{ Process an APP0 or APP14 marker without saving it } -var - length : INT32; - b : array[0..APPN_DATA_LEN-1] of JOCTET; - i, numtoread : uint; -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; - bytes_in_buffer : size_t; -begin - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - -{ Read two bytes interpreted as an unsigned 16-bit integer. - length should be declared unsigned int or perhaps INT32. } - - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_interesting_appn := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - length := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_interesting_appn := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( length, GETJOCTET(next_input_byte^)); - Inc( next_input_byte ); - - Dec(length, 2); - - { get the interesting part of the marker data } - if (length >= APPN_DATA_LEN) then - numtoread := APPN_DATA_LEN - else - if (length > 0) then - numtoread := uint(length) - else - numtoread := 0; - for i := 0 to numtoread-1 do - begin - { Read a byte into b[i]. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - get_interesting_appn := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - b[i] := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - end; - - Dec(length, numtoread); - - { process it } - case (cinfo^.unread_marker) of - M_APP0: - examine_app0(cinfo, b, numtoread, length); - M_APP14: - examine_app14(cinfo, b, numtoread, length); - else - { can't get here unless jpeg_save_markers chooses wrong processor } - ERREXIT1(j_common_ptr(cinfo), JERR_UNKNOWN_MARKER, cinfo^.unread_marker); - end; - - { skip any remaining data -- could be lots } - - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - if (length > 0) then - cinfo^.src^.skip_input_data(cinfo, long(length)); - - get_interesting_appn := TRUE; -end; - -{$ifdef SAVE_MARKERS_SUPPORTED} - -{METHODDEF} -function save_marker (cinfo : j_decompress_ptr) : boolean; -{ Save an APPn or COM marker into the marker list } -var - marker : my_marker_ptr; - cur_marker : jpeg_saved_marker_ptr; - bytes_read, data_length : uint; - data : JOCTET_FIELD_PTR; - length : INT32; -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; - bytes_in_buffer : size_t; -var - limit : uint; -var - prev : jpeg_saved_marker_ptr; -begin - { local copies of input pointer/count } - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - - marker := my_marker_ptr(cinfo^.marker); - cur_marker := marker^.cur_marker; - length := 0; - - if (cur_marker = NIL) then - begin - { begin reading a marker } - { Read two bytes interpreted as an unsigned 16-bit integer. } - - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - save_marker := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - length := (uint( GETJOCTET(next_input_byte^)) shl 8); - Inc( next_input_byte ); - - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - save_marker := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - Inc( length, GETJOCTET(next_input_byte^)); - Inc( next_input_byte ); - - Dec(length, 2); - if (length >= 0) then - begin { watch out for bogus length word } - { figure out how much we want to save } - - if (cinfo^.unread_marker = int(M_COM)) then - limit := marker^.length_limit_COM - else - limit := marker^.length_limit_APPn[cinfo^.unread_marker - int(M_APP0)]; - if (uint(length) < limit) then - limit := uint(length); - { allocate and initialize the marker item } - cur_marker := jpeg_saved_marker_ptr( - cinfo^.mem^.alloc_large (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(jpeg_marker_struct) + limit) ); - cur_marker^.next := NIL; - cur_marker^.marker := UINT8 (cinfo^.unread_marker); - cur_marker^.original_length := uint(length); - cur_marker^.data_length := limit; - { data area is just beyond the jpeg_marker_struct } - cur_marker^.data := JOCTET_FIELD_PTR(cur_marker); - Inc(jpeg_saved_marker_ptr(cur_marker^.data)); - data := cur_marker^.data; - - marker^.cur_marker := cur_marker; - marker^.bytes_read := 0; - bytes_read := 0; - data_length := limit; - end - else - begin - { deal with bogus length word } - data_length := 0; - bytes_read := 0; - data := NIL; - end - end - else - begin - { resume reading a marker } - bytes_read := marker^.bytes_read; - data_length := cur_marker^.data_length; - data := cur_marker^.data; - Inc(data, bytes_read); - end; - - while (bytes_read < data_length) do - begin - { move the restart point to here } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - marker^.bytes_read := bytes_read; - { If there's not at least one byte in buffer, suspend } - if (bytes_in_buffer = 0) then - begin - if not datasrc^.fill_input_buffer (cinfo) then - begin - save_marker := FALSE; - exit; - end; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - - { Copy bytes with reasonable rapidity } - while (bytes_read < data_length) and (bytes_in_buffer > 0) do - begin - JOCTETPTR(data)^ := next_input_byte^; - Inc(JOCTETPTR(data)); - Inc(next_input_byte); - Dec(bytes_in_buffer); - Inc(bytes_read); - end; - end; - - { Done reading what we want to read } - if (cur_marker <> NIL) then - begin { will be NIL if bogus length word } - { Add new marker to end of list } - if (cinfo^.marker_list = NIL) then - begin - cinfo^.marker_list := cur_marker - end - else - begin - prev := cinfo^.marker_list; - while (prev^.next <> NIL) do - prev := prev^.next; - prev^.next := cur_marker; - end; - { Reset pointer & calc remaining data length } - data := cur_marker^.data; - length := cur_marker^.original_length - data_length; - end; - { Reset to initial state for next marker } - marker^.cur_marker := NIL; - - { Process the marker if interesting; else just make a generic trace msg } - case (cinfo^.unread_marker) of - M_APP0: - examine_app0(cinfo, data^, data_length, length); - M_APP14: - examine_app14(cinfo, data^, data_length, length); - else - {$IFDEF DEBUG} - TRACEMS2(j_common_ptr(cinfo), 1, JTRC_MISC_MARKER, cinfo^.unread_marker, - int(data_length + length)); - {$ENDIF} - end; - - { skip any remaining data -- could be lots } - { do before skip_input_data } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - if (length > 0) then - cinfo^.src^.skip_input_data (cinfo, long(length) ); - - save_marker := TRUE; -end; - -{$endif} { SAVE_MARKERS_SUPPORTED } - - -{ Find the next JPEG marker, save it in cinfo^.unread_marker. - Returns FALSE if had to suspend before reaching a marker; - in that case cinfo^.unread_marker is unchanged. - - Note that the result might not be a valid marker code, - but it will never be 0 or FF. } - -{LOCAL} -function next_marker (cinfo : j_decompress_ptr) : boolean; -var - c : int; -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; - bytes_in_buffer : size_t; -begin - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - - {while TRUE do} - repeat - { Read a byte into variable c. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - next_marker := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - { Skip any non-FF bytes. - This may look a bit inefficient, but it will not occur in a valid file. - We sync after each discarded byte so that a suspending data source - can discard the byte from its buffer. } - - while (c <> $FF) do - begin - Inc(cinfo^.marker^.discarded_bytes); - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - { Read a byte into variable c. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - next_marker := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - end; - { This loop swallows any duplicate FF bytes. Extra FFs are legal as - pad bytes, so don't count them in discarded_bytes. We assume there - will not be so many consecutive FF bytes as to overflow a suspending - data source's input buffer. } - - repeat - { Read a byte into variable c. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - next_marker := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - Until (c <> $FF); - if (c <> 0) then - break; { found a valid marker, exit loop } - { Reach here if we found a stuffed-zero data sequence (FF/00). - Discard it and loop back to try again. } - - Inc(cinfo^.marker^.discarded_bytes, 2); - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - Until False; - - if (cinfo^.marker^.discarded_bytes <> 0) then - begin - WARNMS2(j_common_ptr(cinfo), JWRN_EXTRANEOUS_DATA, - cinfo^.marker^.discarded_bytes, c); - cinfo^.marker^.discarded_bytes := 0; - end; - - cinfo^.unread_marker := c; - - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - next_marker := TRUE; -end; { next_marker } - - -{LOCAL} -function first_marker (cinfo : j_decompress_ptr) : boolean; -{ Like next_marker, but used to obtain the initial SOI marker. } -{ For this marker, we do not allow preceding garbage or fill; otherwise, - we might well scan an entire input file before realizing it ain't JPEG. - If an application wants to process non-JFIF files, it must seek to the - SOI before calling the JPEG library. } -var - c, c2 : int; -var - datasrc : jpeg_source_mgr_ptr; - next_input_byte : JOCTETptr; - bytes_in_buffer : size_t; -begin - datasrc := cinfo^.src; - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - - { Read a byte into variable c. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - first_marker := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - c := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - { Read a byte into variable c2. If must suspend, return FALSE. } - { make a byte available. - Note we do *not* do INPUT_SYNC before calling fill_input_buffer, - but we must reload the local copies after a successful fill. } - if (bytes_in_buffer = 0) then - begin - if (not datasrc^.fill_input_buffer(cinfo)) then - begin - first_marker := FALSE; - exit; - end; - { Reload the local copies } - next_input_byte := datasrc^.next_input_byte; - bytes_in_buffer := datasrc^.bytes_in_buffer; - end; - Dec( bytes_in_buffer ); - - c2 := GETJOCTET(next_input_byte^); - Inc(next_input_byte); - - if (c <> $FF) or (c2 <> int(M_SOI)) then - ERREXIT2(j_common_ptr(cinfo), JERR_NO_SOI, c, c2); - - cinfo^.unread_marker := c2; - - { Unload the local copies --- do this only at a restart boundary } - datasrc^.next_input_byte := next_input_byte; - datasrc^.bytes_in_buffer := bytes_in_buffer; - - first_marker := TRUE; -end; { first_marker } - - -{ Read markers until SOS or EOI. - - Returns same codes as are defined for jpeg_consume_input: - JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. } - -{METHODDEF} -function read_markers (cinfo : j_decompress_ptr) : int; -begin - { Outer loop repeats once for each marker. } - repeat - { Collect the marker proper, unless we already did. } - { NB: first_marker() enforces the requirement that SOI appear first. } - if (cinfo^.unread_marker = 0) then - begin - if not cinfo^.marker^.saw_SOI then - begin - if not first_marker(cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - end - else - begin - if not next_marker(cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - end; - end; - { At this point cinfo^.unread_marker contains the marker code and the - input point is just past the marker proper, but before any parameters. - A suspension will cause us to return with this state still true. } - - case (cinfo^.unread_marker) of - M_SOI: - if not get_soi(cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - M_SOF0, { Baseline } - M_SOF1: { Extended sequential, Huffman } - if not get_sof(cinfo, FALSE, FALSE) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - M_SOF2: { Progressive, Huffman } - if not get_sof(cinfo, TRUE, FALSE) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - M_SOF9: { Extended sequential, arithmetic } - if not get_sof(cinfo, FALSE, TRUE) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - M_SOF10: { Progressive, arithmetic } - if not get_sof(cinfo, TRUE, TRUE) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - { Currently unsupported SOFn types } - M_SOF3, { Lossless, Huffman } - M_SOF5, { Differential sequential, Huffman } - M_SOF6, { Differential progressive, Huffman } - M_SOF7, { Differential lossless, Huffman } - M_JPG, { Reserved for JPEG extensions } - M_SOF11, { Lossless, arithmetic } - M_SOF13, { Differential sequential, arithmetic } - M_SOF14, { Differential progressive, arithmetic } - M_SOF15: { Differential lossless, arithmetic } - ERREXIT1(j_common_ptr(cinfo), JERR_SOF_UNSUPPORTED, cinfo^.unread_marker); - - M_SOS: - begin - if not get_sos(cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - cinfo^.unread_marker := 0; { processed the marker } - read_markers := JPEG_REACHED_SOS; - exit; - end; - - M_EOI: - begin - {$IFDEF DEBUG} - TRACEMS(j_common_ptr(cinfo), 1, JTRC_EOI); - {$ENDIF} - cinfo^.unread_marker := 0; { processed the marker } - read_markers := JPEG_REACHED_EOI; - exit; - end; - - M_DAC: - if not get_dac(cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - M_DHT: - if not get_dht(cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - M_DQT: - if not get_dqt(cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - M_DRI: - if not get_dri(cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - M_APP0, - M_APP1, - M_APP2, - M_APP3, - M_APP4, - M_APP5, - M_APP6, - M_APP7, - M_APP8, - M_APP9, - M_APP10, - M_APP11, - M_APP12, - M_APP13, - M_APP14, - M_APP15: - if not my_marker_ptr(cinfo^.marker)^. - process_APPn[cinfo^.unread_marker - int(M_APP0)](cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - M_COM: - if not my_marker_ptr(cinfo^.marker)^.process_COM (cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - M_RST0, { these are all parameterless } - M_RST1, - M_RST2, - M_RST3, - M_RST4, - M_RST5, - M_RST6, - M_RST7, - M_TEM: - {$IFDEF DEBUG} - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_PARMLESS_MARKER, - cinfo^.unread_marker) - {$ENDIF} - ; - - M_DNL: { Ignore DNL ... perhaps the wrong thing } - if not skip_variable(cinfo) then - begin - read_markers := JPEG_SUSPENDED; - exit; - end; - - else { must be DHP, EXP, JPGn, or RESn } - { For now, we treat the reserved markers as fatal errors since they are - likely to be used to signal incompatible JPEG Part 3 extensions. - Once the JPEG 3 version-number marker is well defined, this code - ought to change! } - ERREXIT1(j_common_ptr(cinfo) , JERR_UNKNOWN_MARKER, - cinfo^.unread_marker); - end; { end of case } - { Successfully processed marker, so reset state variable } - cinfo^.unread_marker := 0; - Until false; -end; { read_markers } - - -{ Read a restart marker, which is expected to appear next in the datastream; - if the marker is not there, take appropriate recovery action. - Returns FALSE if suspension is required. - - This is called by the entropy decoder after it has read an appropriate - number of MCUs. cinfo^.unread_marker may be nonzero if the entropy decoder - has already read a marker from the data source. Under normal conditions - cinfo^.unread_marker will be reset to 0 before returning; if not reset, - it holds a marker which the decoder will be unable to read past. } - -{METHODDEF} -function read_restart_marker (cinfo : j_decompress_ptr) :boolean; -begin - { Obtain a marker unless we already did. } - { Note that next_marker will complain if it skips any data. } - if (cinfo^.unread_marker = 0) then - begin - if not next_marker(cinfo) then - begin - read_restart_marker := FALSE; - exit; - end; - end; - - if (cinfo^.unread_marker = (int(M_RST0) + cinfo^.marker^.next_restart_num)) then - begin - { Normal case --- swallow the marker and let entropy decoder continue } - {$IFDEF DEBUG} - TRACEMS1(j_common_ptr(cinfo), 3, JTRC_RST, - cinfo^.marker^.next_restart_num); - {$ENDIF} - cinfo^.unread_marker := 0; - end - else - begin - { Uh-oh, the restart markers have been messed up. } - { Let the data source manager determine how to resync. } - if not cinfo^.src^.resync_to_restart(cinfo, - cinfo^.marker^.next_restart_num) then - begin - read_restart_marker := FALSE; - exit; - end; - end; - - { Update next-restart state } - with cinfo^.marker^ do - next_restart_num := (next_restart_num + 1) and 7; - - read_restart_marker := TRUE; -end; { read_restart_marker } - - -{ This is the default resync_to_restart method for data source managers - to use if they don't have any better approach. Some data source managers - may be able to back up, or may have additional knowledge about the data - which permits a more intelligent recovery strategy; such managers would - presumably supply their own resync method. - - read_restart_marker calls resync_to_restart if it finds a marker other than - the restart marker it was expecting. (This code is *not* used unless - a nonzero restart interval has been declared.) cinfo^.unread_marker is - the marker code actually found (might be anything, except 0 or FF). - The desired restart marker number (0..7) is passed as a parameter. - This routine is supposed to apply whatever error recovery strategy seems - appropriate in order to position the input stream to the next data segment. - Note that cinfo^.unread_marker is treated as a marker appearing before - the current data-source input point; usually it should be reset to zero - before returning. - Returns FALSE if suspension is required. - - This implementation is substantially constrained by wanting to treat the - input as a data stream; this means we can't back up. Therefore, we have - only the following actions to work with: - 1. Simply discard the marker and let the entropy decoder resume at next - byte of file. - 2. Read forward until we find another marker, discarding intervening - data. (In theory we could look ahead within the current bufferload, - without having to discard data if we don't find the desired marker. - This idea is not implemented here, in part because it makes behavior - dependent on buffer size and chance buffer-boundary positions.) - 3. Leave the marker unread (by failing to zero cinfo^.unread_marker). - This will cause the entropy decoder to process an empty data segment, - inserting dummy zeroes, and then we will reprocess the marker. - - #2 is appropriate if we think the desired marker lies ahead, while #3 is - appropriate if the found marker is a future restart marker (indicating - that we have missed the desired restart marker, probably because it got - corrupted). - We apply #2 or #3 if the found marker is a restart marker no more than - two counts behind or ahead of the expected one. We also apply #2 if the - found marker is not a legal JPEG marker code (it's certainly bogus data). - If the found marker is a restart marker more than 2 counts away, we do #1 - (too much risk that the marker is erroneous; with luck we will be able to - resync at some future point). - For any valid non-restart JPEG marker, we apply #3. This keeps us from - overrunning the end of a scan. An implementation limited to single-scan - files might find it better to apply #2 for markers other than EOI, since - any other marker would have to be bogus data in that case. } - - -{GLOBAL} -function jpeg_resync_to_restart(cinfo : j_decompress_ptr; - desired : int) : boolean; -var - marker : int; - action : int; -begin - marker := cinfo^.unread_marker; - //action := 1; { never used } - { Always put up a warning. } - WARNMS2(j_common_ptr(cinfo), JWRN_MUST_RESYNC, marker, desired); - - { Outer loop handles repeated decision after scanning forward. } - repeat - if (marker < int(M_SOF0)) then - action := 2 { invalid marker } - else - if (marker < int(M_RST0)) or (marker > int(M_RST7)) then - action := 3 { valid non-restart marker } - else - begin - if (marker = (int(M_RST0) + ((desired+1) and 7))) or - (marker = (int(M_RST0) + ((desired+2) and 7))) then - action := 3 { one of the next two expected restarts } - else - if (marker = (int(M_RST0) + ((desired-1) and 7))) or - (marker = (int(M_RST0) + ((desired-2) and 7))) then - action := 2 { a prior restart, so advance } - else - action := 1; { desired restart or too far away } - end; - - {$IFDEF DEBUG} - TRACEMS2(j_common_ptr(cinfo), 4, JTRC_RECOVERY_ACTION, marker, action); - {$ENDIF} - case action of - 1: - { Discard marker and let entropy decoder resume processing. } - begin - cinfo^.unread_marker := 0; - jpeg_resync_to_restart := TRUE; - exit; - end; - 2: - { Scan to the next marker, and repeat the decision loop. } - begin - if not next_marker(cinfo) then - begin - jpeg_resync_to_restart := FALSE; - exit; - end; - marker := cinfo^.unread_marker; - end; - 3: - { Return without advancing past this marker. } - { Entropy decoder will be forced to process an empty segment. } - begin - jpeg_resync_to_restart := TRUE; - exit; - end; - end; { case } - Until false; { end loop } -end; { jpeg_resync_to_restart } - - -{ Reset marker processing state to begin a fresh datastream. } - -{METHODDEF} -procedure reset_marker_reader (cinfo : j_decompress_ptr); -var - marker : my_marker_ptr; -begin - marker := my_marker_ptr (cinfo^.marker); - with cinfo^ do - begin - comp_info := NIL; { until allocated by get_sof } - input_scan_number := 0; { no SOS seen yet } - unread_marker := 0; { no pending marker } - end; - marker^.pub.saw_SOI := FALSE; { set internal state too } - marker^.pub.saw_SOF := FALSE; - marker^.pub.discarded_bytes := 0; - marker^.cur_marker := NIL; -end; { reset_marker_reader } - - -{ Initialize the marker reader module. - This is called only once, when the decompression object is created. } - -{GLOBAL} -procedure jinit_marker_reader (cinfo : j_decompress_ptr); -var - marker : my_marker_ptr; - i : int; -begin - { Create subobject in permanent pool } - marker := my_marker_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT, - SIZEOF(my_marker_reader)) - ); - cinfo^.marker := jpeg_marker_reader_ptr(marker); - { Initialize method pointers } - marker^.pub.reset_marker_reader := reset_marker_reader; - marker^.pub.read_markers := read_markers; - marker^.pub.read_restart_marker := read_restart_marker; - { Initialize COM/APPn processing. - By default, we examine and then discard APP0 and APP14, - but simply discard COM and all other APPn. } - - marker^.process_COM := skip_variable; - marker^.length_limit_COM := 0; - for i := 0 to 16-1 do - begin - marker^.process_APPn[i] := skip_variable; - marker^.length_limit_APPn[i] := 0; - end; - marker^.process_APPn[0] := get_interesting_appn; - marker^.process_APPn[14] := get_interesting_appn; - { Reset marker processing state } - reset_marker_reader(cinfo); -end; { jinit_marker_reader } - - -{ Control saving of COM and APPn markers into marker_list. } - - -{$ifdef SAVE_MARKERS_SUPPORTED} - -{GLOBAL} -procedure jpeg_save_markers (cinfo : j_decompress_ptr; - marker_code : int; - length_limit : uint); -var - marker : my_marker_ptr; - maxlength : long; - processor : jpeg_marker_parser_method; -begin - marker := my_marker_ptr (cinfo^.marker); - - { Length limit mustn't be larger than what we can allocate - (should only be a concern in a 16-bit environment). } - - maxlength := cinfo^.mem^.max_alloc_chunk - SIZEOF(jpeg_marker_struct); - if (long(length_limit) > maxlength) then - length_limit := uint(maxlength); - - { Choose processor routine to use. - APP0/APP14 have special requirements. } - - if (length_limit <> 0) then - begin - processor := save_marker; - { If saving APP0/APP14, save at least enough for our internal use. } - if (marker_code = int(M_APP0)) and (length_limit < APP0_DATA_LEN) then - length_limit := APP0_DATA_LEN - else - if (marker_code = int(M_APP14)) and (length_limit < APP14_DATA_LEN) then - length_limit := APP14_DATA_LEN; - end - else - begin - processor := skip_variable; - { If discarding APP0/APP14, use our regular on-the-fly processor. } - if (marker_code = int(M_APP0)) or (marker_code = int(M_APP14)) then - processor := get_interesting_appn; - end; - - if (marker_code = int(M_COM)) then - begin - marker^.process_COM := processor; - marker^.length_limit_COM := length_limit; - end - else - if (marker_code >= int(M_APP0)) and (marker_code <= int(M_APP15)) then - begin - marker^.process_APPn[marker_code - int(M_APP0)] := processor; - marker^.length_limit_APPn[marker_code - int(M_APP0)] := length_limit; - end - else - ERREXIT1(j_common_ptr(cinfo), JERR_UNKNOWN_MARKER, marker_code); -end; - -{$endif} { SAVE_MARKERS_SUPPORTED } - -{ Install a special processing method for COM or APPn markers. } - -{GLOBAL} - -procedure jpeg_set_marker_processor (cinfo : j_decompress_ptr; - marker_code : int; - routine : jpeg_marker_parser_method); -var - marker : my_marker_ptr; -begin - marker := my_marker_ptr (cinfo^.marker); - if (marker_code = int(M_COM)) then - marker^.process_COM := routine - else - if (marker_code >= int(M_APP0)) and (marker_code <= int(M_APP15)) then - marker^.process_APPn[marker_code - int(M_APP0)] := routine - else - ERREXIT1(j_common_ptr(cinfo), JERR_UNKNOWN_MARKER, marker_code); -end; - -end. +unit imjdmarker; + +{ This file contains routines to decode JPEG datastream markers. + Most of the complexity arises from our desire to support input + suspension: if not all of the data for a marker is available; + we must exit back to the application. On resumption; we reprocess + the marker. } + +{ Original: jdmarker.c; Copyright (C) 1991-1998; Thomas G. Lane. } +{ History + 9.7.96 Conversion to pascal started jnn + 22.3.98 updated to 6b jnn } + + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjcomapi, + imjpeglib; + +const { JPEG marker codes } + M_SOF0 = $c0; + M_SOF1 = $c1; + M_SOF2 = $c2; + M_SOF3 = $c3; + + M_SOF5 = $c5; + M_SOF6 = $c6; + M_SOF7 = $c7; + + M_JPG = $c8; + M_SOF9 = $c9; + M_SOF10 = $ca; + M_SOF11 = $cb; + + M_SOF13 = $cd; + M_SOF14 = $ce; + M_SOF15 = $cf; + + M_DHT = $c4; + + M_DAC = $cc; + + M_RST0 = $d0; + M_RST1 = $d1; + M_RST2 = $d2; + M_RST3 = $d3; + M_RST4 = $d4; + M_RST5 = $d5; + M_RST6 = $d6; + M_RST7 = $d7; + + M_SOI = $d8; + M_EOI = $d9; + M_SOS = $da; + M_DQT = $db; + M_DNL = $dc; + M_DRI = $dd; + M_DHP = $de; + M_EXP = $df; + + M_APP0 = $e0; + M_APP1 = $e1; + M_APP2 = $e2; + M_APP3 = $e3; + M_APP4 = $e4; + M_APP5 = $e5; + M_APP6 = $e6; + M_APP7 = $e7; + M_APP8 = $e8; + M_APP9 = $e9; + M_APP10 = $ea; + M_APP11 = $eb; + M_APP12 = $ec; + M_APP13 = $ed; + M_APP14 = $ee; + M_APP15 = $ef; + + M_JPG0 = $f0; + M_JPG13 = $fd; + M_COM = $fe; + + M_TEM = $01; + + M_ERROR = $100; + +type + JPEG_MARKER = uint; { JPEG marker codes } + +{ Private state } + +type + my_marker_ptr = ^my_marker_reader; + my_marker_reader = record + pub : jpeg_marker_reader; { public fields } + + { Application-overridable marker processing methods } + process_COM : jpeg_marker_parser_method; + process_APPn : array[0..16-1] of jpeg_marker_parser_method; + + { Limit on marker data length to save for each marker type } + length_limit_COM : uint; + length_limit_APPn : array[0..16-1] of uint; + + { Status of COM/APPn marker saving } + cur_marker : jpeg_saved_marker_ptr; { NIL if not processing a marker } + bytes_read : uint; { data bytes read so far in marker } + { Note: cur_marker is not linked into marker_list until it's all read. } + end; + +{GLOBAL} +function jpeg_resync_to_restart(cinfo : j_decompress_ptr; + desired : int) : boolean; +{GLOBAL} +procedure jinit_marker_reader (cinfo : j_decompress_ptr); + +{$ifdef SAVE_MARKERS_SUPPORTED} + +{GLOBAL} +procedure jpeg_save_markers (cinfo : j_decompress_ptr; + marker_code : int; + length_limit : uint); +{$ENDIF} + +{GLOBAL} +procedure jpeg_set_marker_processor (cinfo : j_decompress_ptr; + marker_code : int; + routine : jpeg_marker_parser_method); + +implementation + +uses + imjutils; + +{ At all times, cinfo1.src.next_input_byte and .bytes_in_buffer reflect + the current restart point; we update them only when we have reached a + suitable place to restart if a suspension occurs. } + + +{ Routines to process JPEG markers. + + Entry condition: JPEG marker itself has been read and its code saved + in cinfo^.unread_marker; input restart point is just after the marker. + + Exit: if return TRUE, have read and processed any parameters, and have + updated the restart point to point after the parameters. + If return FALSE, was forced to suspend before reaching end of + marker parameters; restart point has not been moved. Same routine + will be called again after application supplies more input data. + + This approach to suspension assumes that all of a marker's parameters + can fit into a single input bufferload. This should hold for "normal" + markers. Some COM/APPn markers might have large parameter segments + that might not fit. If we are simply dropping such a marker, we use + skip_input_data to get past it, and thereby put the problem on the + source manager's shoulders. If we are saving the marker's contents + into memory, we use a slightly different convention: when forced to + suspend, the marker processor updates the restart point to the end of + what it's consumed (ie, the end of the buffer) before returning FALSE. + On resumption, cinfo->unread_marker still contains the marker code, + but the data source will point to the next chunk of marker data. + The marker processor must retain internal state to deal with this. + + Note that we don't bother to avoid duplicate trace messages if a + suspension occurs within marker parameters. Other side effects + require more care. } + +{LOCAL} +function get_soi (cinfo : j_decompress_ptr) : boolean; +{ Process an SOI marker } +var + i : int; +begin + {$IFDEF DEBUG} + TRACEMS(j_common_ptr(cinfo), 1, JTRC_SOI); + {$ENDIF} + + if (cinfo^.marker^.saw_SOI) then + ERREXIT(j_common_ptr(cinfo), JERR_SOI_DUPLICATE); + + { Reset all parameters that are defined to be reset by SOI } + + for i := 0 to Pred(NUM_ARITH_TBLS) do + with cinfo^ do + begin + arith_dc_L[i] := 0; + arith_dc_U[i] := 1; + arith_ac_K[i] := 5; + end; + cinfo^.restart_interval := 0; + + { Set initial assumptions for colorspace etc } + + with cinfo^ do + begin + jpeg_color_space := JCS_UNKNOWN; + CCIR601_sampling := FALSE; { Assume non-CCIR sampling??? } + + saw_JFIF_marker := FALSE; + JFIF_major_version := 1; { set default JFIF APP0 values } + JFIF_minor_version := 1; + density_unit := 0; + X_density := 1; + Y_density := 1; + saw_Adobe_marker := FALSE; + Adobe_transform := 0; + + marker^.saw_SOI := TRUE; + end; + get_soi := TRUE; +end; { get_soi } + + +{LOCAL} +function get_sof(cinfo : j_decompress_ptr; + is_prog : boolean; + is_arith : boolean) : boolean; +{ Process a SOFn marker } +var + length : INT32; + c, ci : int; + compptr : jpeg_component_info_ptr; +{ Declare and initialize local copies of input pointer/count } +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; + bytes_in_buffer : size_t; +begin + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; +{} + cinfo^.progressive_mode := is_prog; + cinfo^.arith_code := is_arith; + +{ Read two bytes interpreted as an unsigned 16-bit integer. + length should be declared unsigned int or perhaps INT32. } + +{ make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + length := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( length, GETJOCTET( next_input_byte^)); + Inc( next_input_byte ); + + + { Read a byte into variable cinfo^.data_precision. + If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + cinfo^.data_precision := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + +{ Read two bytes interpreted as an unsigned 16-bit integer. + cinfo^.image_height should be declared unsigned int or perhaps INT32. } + +{ make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + cinfo^.image_height := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( cinfo^.image_height, GETJOCTET( next_input_byte^)); + Inc( next_input_byte ); + +{ Read two bytes interpreted as an unsigned 16-bit integer. + cinfo^.image_width should be declared unsigned int or perhaps INT32. } + +{ make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + cinfo^.image_width := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( cinfo^.image_width, GETJOCTET( next_input_byte^)); + Inc( next_input_byte ); + + { Read a byte into variable cinfo^.num_components. + If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + cinfo^.num_components := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + Dec(length, 8); + + {$IFDEF DEBUG} + TRACEMS4(j_common_ptr(cinfo), 1, JTRC_SOF, cinfo^.unread_marker, + int(cinfo^.image_width), int(cinfo^.image_height), + cinfo^.num_components); + {$ENDIF} + + if (cinfo^.marker^.saw_SOF) then + ERREXIT(j_common_ptr(cinfo), JERR_SOF_DUPLICATE); + + { We don't support files in which the image height is initially specified } + { as 0 and is later redefined by DNL. As long as we have to check that, } + { might as well have a general sanity check. } + if (cinfo^.image_height <= 0) or (cinfo^.image_width <= 0) + or (cinfo^.num_components <= 0) then + ERREXIT(j_common_ptr(cinfo), JERR_EMPTY_IMAGE); + + if (length <> (cinfo^.num_components * 3)) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); + + if (cinfo^.comp_info = NIL) then { do only once, even if suspend } + cinfo^.comp_info := jpeg_component_info_list_ptr( + cinfo^.mem^.alloc_small(j_common_ptr(cinfo), JPOOL_IMAGE, + cinfo^.num_components * SIZEOF(jpeg_component_info))); + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + compptr^.component_index := ci; + + { Read a byte into variable compptr^.component_id. + If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + compptr^.component_id := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + { Read a byte into variable c. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + compptr^.h_samp_factor := (c shr 4) and 15; + compptr^.v_samp_factor := (c ) and 15; + + { Read a byte into variable compptr^.quant_tbl_no. + If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sof := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + compptr^.quant_tbl_no := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + {$IFDEF DEBUG} + TRACEMS4(j_common_ptr(cinfo), 1, JTRC_SOF_COMPONENT, + compptr^.component_id, compptr^.h_samp_factor, + compptr^.v_samp_factor, compptr^.quant_tbl_no); + {$ENDIF} + + Inc(compptr); + end; + + cinfo^.marker^.saw_SOF := TRUE; + + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + get_sof := TRUE; +end; { get_sof } + + +{LOCAL} +function get_sos (cinfo : j_decompress_ptr) : boolean; +{ Process a SOS marker } +label + id_found; +var + length : INT32; + i, ci, n, c, cc : int; + compptr : jpeg_component_info_ptr; +{ Declare and initialize local copies of input pointer/count } +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; { Array[] of JOCTET; } + bytes_in_buffer : size_t; +begin + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + +{} + + if not cinfo^.marker^.saw_SOF then + ERREXIT(j_common_ptr(cinfo), JERR_SOS_NO_SOF); + +{ Read two bytes interpreted as an unsigned 16-bit integer. + length should be declared unsigned int or perhaps INT32. } + +{ make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sos := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + length := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sos := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( length, GETJOCTET( next_input_byte^)); + Inc( next_input_byte ); + + + { Read a byte into variable n (Number of components). + If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sos := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + n := GETJOCTET(next_input_byte^); { Number of components } + Inc(next_input_byte); + + {$IFDEF DEBUG} + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_SOS, n); + {$ENDIF} + + if ((length <> (n * 2 + 6)) or (n < 1) or (n > MAX_COMPS_IN_SCAN)) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); + + cinfo^.comps_in_scan := n; + + { Collect the component-spec parameters } + + for i := 0 to Pred(n) do + begin + { Read a byte into variable cc. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sos := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + cc := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + { Read a byte into variable c. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sos := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to Pred(cinfo^.num_components) do + begin + if (cc = compptr^.component_id) then + goto id_found; + Inc(compptr); + end; + + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_COMPONENT_ID, cc); + + id_found: + + cinfo^.cur_comp_info[i] := compptr; + compptr^.dc_tbl_no := (c shr 4) and 15; + compptr^.ac_tbl_no := (c ) and 15; + + {$IFDEF DEBUG} + TRACEMS3(j_common_ptr(cinfo), 1, JTRC_SOS_COMPONENT, cc, + compptr^.dc_tbl_no, compptr^.ac_tbl_no); + {$ENDIF} + end; + + { Collect the additional scan parameters Ss, Se, Ah/Al. } + { Read a byte into variable c. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sos := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + cinfo^.Ss := c; + + { Read a byte into variable c. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sos := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + cinfo^.Se := c; + + { Read a byte into variable c. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_sos := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + cinfo^.Ah := (c shr 4) and 15; + cinfo^.Al := (c ) and 15; + + {$IFDEF DEBUG} + TRACEMS4(j_common_ptr(cinfo), 1, JTRC_SOS_PARAMS, cinfo^.Ss, cinfo^.Se, + cinfo^.Ah, cinfo^.Al); + {$ENDIF} + + { Prepare to scan data & restart markers } + cinfo^.marker^.next_restart_num := 0; + + { Count another SOS marker } + Inc( cinfo^.input_scan_number ); + + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + get_sos := TRUE; +end; { get_sos } + + +{METHODDEF} +function skip_variable (cinfo : j_decompress_ptr) : boolean; +{ Skip over an unknown or uninteresting variable-length marker } +var + length : INT32; +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; { Array[] of JOCTET; } + bytes_in_buffer : size_t; +begin + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + +{ Read two bytes interpreted as an unsigned 16-bit integer. + length should be declared unsigned int or perhaps INT32. } + +{ make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + skip_variable := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + length := uint(GETJOCTET(next_input_byte^)) shl 8; + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + skip_variable := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( length, GETJOCTET(next_input_byte^)); + Inc( next_input_byte ); + + Dec(length, 2); + + {$IFDEF DEBUG} + TRACEMS2(j_common_ptr(cinfo), 1, JTRC_MISC_MARKER, + cinfo^.unread_marker, int(length)); + {$ENDIF} + + { Unload the local copies --- do this only at a restart boundary } + { do before skip_input_data } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + if (length > 0) then + cinfo^.src^.skip_input_data(cinfo, long(length)); + + skip_variable := TRUE; +end; { skip_variable } + + +{$IFDEF D_ARITH_CODING_SUPPORTED} + +{LOCAL} +function get_dac (cinfo : j_decompress_ptr) : boolean; +{ Process a DAC marker } +var + length : INT32; + index, val : int; +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; + bytes_in_buffer : size_t; +begin + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + +{ Read two bytes interpreted as an unsigned 16-bit integer. + length should be declared unsigned int or perhaps INT32. } + +{ make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dac := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + length := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dac := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( length, GETJOCTET( next_input_byte^)); + Inc( next_input_byte ); + + Dec(length, 2); + + while (length > 0) do + begin + { Read a byte into variable index. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dac := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + index := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + { Read a byte into variable val. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dac := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + val := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + Dec( length, 2); + + {$IFDEF DEBUG} + TRACEMS2(j_common_ptr(cinfo), 1, JTRC_DAC, index, val); + {$ENDIF} + + if (index < 0) or (index >= (2*NUM_ARITH_TBLS)) then + ERREXIT1(j_common_ptr(cinfo) , JERR_DAC_INDEX, index); + + if (index >= NUM_ARITH_TBLS) then + begin { define AC table } + cinfo^.arith_ac_K[index-NUM_ARITH_TBLS] := UINT8(val); + end + else + begin { define DC table } + cinfo^.arith_dc_L[index] := UINT8(val and $0F); + cinfo^.arith_dc_U[index] := UINT8(val shr 4); + if (cinfo^.arith_dc_L[index] > cinfo^.arith_dc_U[index]) then + ERREXIT1(j_common_ptr(cinfo) , JERR_DAC_VALUE, val); + end; + end; + + if (length <> 0) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); + + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + get_dac := TRUE; +end; { get_dac } + +{$ELSE} + +{LOCAL} +function get_dac (cinfo : j_decompress_ptr) : boolean; +begin + get_dac := skip_variable(cinfo); +end; + +{$ENDIF} + +{LOCAL} +function get_dht (cinfo : j_decompress_ptr) : boolean; +{ Process a DHT marker } +var + length : INT32; + bits : Array[0..17-1] of UINT8; + huffval : Array[0..256-1] of UINT8; + i, index, count : int; + htblptr : ^JHUFF_TBL_PTR; +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; + bytes_in_buffer : size_t; +begin + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + +{ Read two bytes interpreted as an unsigned 16-bit integer. + length should be declared unsigned int or perhaps INT32. } + +{ make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dht := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + length := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dht := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( length, GETJOCTET( next_input_byte^)); + Inc( next_input_byte ); + + Dec(length, 2); + + while (length > 16) do + begin + { Read a byte into variable index. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dht := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + index := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + {$IFDEF DEBUG} + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_DHT, index); + {$ENDIF} + + bits[0] := 0; + count := 0; + for i := 1 to 16 do + begin + { Read a byte into variable bits[i]. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dht := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + bits[i] := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + Inc( count, bits[i] ); + end; + + Dec( length, (1 + 16) ); + + {$IFDEF DEBUG} + TRACEMS8(j_common_ptr(cinfo), 2, JTRC_HUFFBITS, + bits[1], bits[2], bits[3], bits[4], + bits[5], bits[6], bits[7], bits[8]); + TRACEMS8(j_common_ptr(cinfo), 2, JTRC_HUFFBITS, + bits[9], bits[10], bits[11], bits[12], + bits[13], bits[14], bits[15], bits[16]); + {$ENDIF} + + { Here we just do minimal validation of the counts to avoid walking + off the end of our table space. jdhuff.c will check more carefully. } + + if (count > 256) or (INT32(count) > length) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE); + + for i := 0 to Pred(count) do + begin + { Read a byte into variable huffval[i]. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dht := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + huffval[i] := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + end; + + Dec( length, count ); + + if (index and $10)<>0 then + begin { AC table definition } + Dec( index, $10 ); + htblptr := @cinfo^.ac_huff_tbl_ptrs[index]; + end + else + begin { DC table definition } + htblptr := @cinfo^.dc_huff_tbl_ptrs[index]; + end; + + if (index < 0) or (index >= NUM_HUFF_TBLS) then + ERREXIT1(j_common_ptr(cinfo), JERR_DHT_INDEX, index); + + if (htblptr^ = NIL) then + htblptr^ := jpeg_alloc_huff_table(j_common_ptr(cinfo)); + + MEMCOPY(@(htblptr^)^.bits, @bits, SIZEOF((htblptr^)^.bits)); + MEMCOPY(@(htblptr^)^.huffval, @huffval, SIZEOF((htblptr^)^.huffval)); + end; + + if (length <> 0) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); + + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + get_dht := TRUE; +end; { get_dht } + + +{LOCAL} +function get_dqt (cinfo : j_decompress_ptr) : boolean; +{ Process a DQT marker } +var + length : INT32; + n, i, prec : int; + tmp : uint; + quant_ptr : JQUANT_TBL_PTR; +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; + bytes_in_buffer : size_t; +begin + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + +{ Read two bytes interpreted as an unsigned 16-bit integer. + length should be declared unsigned int or perhaps INT32. } + +{ make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dqt := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + length := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dqt := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( length, GETJOCTET( next_input_byte^)); + Inc( next_input_byte ); + + Dec( length, 2 ); + + while (length > 0) do + begin + { Read a byte into variable n. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dqt := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + n := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + prec := n shr 4; + n := n and $0F; + + {$IFDEF DEBUG} + TRACEMS2(j_common_ptr(cinfo), 1, JTRC_DQT, n, prec); + {$ENDIF} + + if (n >= NUM_QUANT_TBLS) then + ERREXIT1(j_common_ptr(cinfo) , JERR_DQT_INDEX, n); + + if (cinfo^.quant_tbl_ptrs[n] = NIL) then + cinfo^.quant_tbl_ptrs[n] := jpeg_alloc_quant_table(j_common_ptr(cinfo)); + quant_ptr := cinfo^.quant_tbl_ptrs[n]; + + for i := 0 to Pred(DCTSIZE2) do + begin + if (prec <> 0) then + begin + { Read two bytes interpreted as an unsigned 16-bit integer. + tmp should be declared unsigned int or perhaps INT32. } + + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dqt := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + tmp := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dqt := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( tmp, GETJOCTET( next_input_byte^)); + Inc( next_input_byte ); + + end + else + begin + { Read a byte into variable tmp. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dqt := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + tmp := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + end; + + { We convert the zigzag-order table to natural array order. } + quant_ptr^.quantval[jpeg_natural_order[i]] := UINT16(tmp); + end; + + if (cinfo^.err^.trace_level >= 2) then + begin + i := 0; + while i < Pred(DCTSIZE2) do + begin + {$IFDEF DEBUG} + TRACEMS8(j_common_ptr(cinfo), 2, JTRC_QUANTVALS, + quant_ptr^.quantval[i], quant_ptr^.quantval[i+1], + quant_ptr^.quantval[i+2], quant_ptr^.quantval[i+3], + quant_ptr^.quantval[i+4], quant_ptr^.quantval[i+5], + quant_ptr^.quantval[i+6], quant_ptr^.quantval[i+7]); + {$ENDIF} + Inc(i, 8); + end; + end; + + Dec( length, DCTSIZE2+1 ); + if (prec <> 0) then + Dec( length, DCTSIZE2 ); + end; + + if (length <> 0) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); + + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + get_dqt := TRUE; +end; { get_dqt } + + +{LOCAL} +function get_dri (cinfo : j_decompress_ptr) : boolean; +{ Process a DRI marker } +var + length : INT32; + tmp : uint; +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; + bytes_in_buffer : size_t; +begin + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + +{ Read two bytes interpreted as an unsigned 16-bit integer. + length should be declared unsigned int or perhaps INT32. } + +{ make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dri := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + length := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dri := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( length, GETJOCTET( next_input_byte^)); + Inc( next_input_byte ); + + if (length <> 4) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_LENGTH); + +{ Read two bytes interpreted as an unsigned 16-bit integer. + tmp should be declared unsigned int or perhaps INT32. } + +{ make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dri := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + tmp := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_dri := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( tmp, GETJOCTET( next_input_byte^)); + Inc( next_input_byte ); + + {$IFDEF DEBUG} + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_DRI, tmp); + {$ENDIF} + + cinfo^.restart_interval := tmp; + + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + get_dri := TRUE; +end; { get_dri } + + +{ Routines for processing APPn and COM markers. + These are either saved in memory or discarded, per application request. + APP0 and APP14 are specially checked to see if they are + JFIF and Adobe markers, respectively. } + +const + APP0_DATA_LEN = 14; { Length of interesting data in APP0 } + APP14_DATA_LEN = 12; { Length of interesting data in APP14 } + APPN_DATA_LEN = 14; { Must be the largest of the above!! } + + +{LOCAL} +procedure examine_app0 (cinfo : j_decompress_ptr; + var data : array of JOCTET; + datalen : uint; + remaining : INT32); + +{ Examine first few bytes from an APP0. + Take appropriate action if it is a JFIF marker. + datalen is # of bytes at data[], remaining is length of rest of marker data. +} +{$IFDEF DEBUG} +var + totallen : INT32; +{$ENDIF} +begin + {$IFDEF DEBUG} + totallen := INT32(datalen) + remaining; + {$ENDIF} + if (datalen >= APP0_DATA_LEN) and + (GETJOCTET(data[0]) = $4A) and + (GETJOCTET(data[1]) = $46) and + (GETJOCTET(data[2]) = $49) and + (GETJOCTET(data[3]) = $46) and + (GETJOCTET(data[4]) = 0) then + begin + { Found JFIF APP0 marker: save info } + cinfo^.saw_JFIF_marker := TRUE; + cinfo^.JFIF_major_version := GETJOCTET(data[5]); + cinfo^.JFIF_minor_version := GETJOCTET(data[6]); + cinfo^.density_unit := GETJOCTET(data[7]); + cinfo^.X_density := (GETJOCTET(data[8]) shl 8) + GETJOCTET(data[9]); + cinfo^.Y_density := (GETJOCTET(data[10]) shl 8) + GETJOCTET(data[11]); + { Check version. + Major version must be 1, anything else signals an incompatible change. + (We used to treat this as an error, but now it's a nonfatal warning, + because some bozo at Hijaak couldn't read the spec.) + Minor version should be 0..2, but process anyway if newer. } + + if (cinfo^.JFIF_major_version <> 1) then + WARNMS2(j_common_ptr(cinfo), JWRN_JFIF_MAJOR, + cinfo^.JFIF_major_version, cinfo^.JFIF_minor_version); + { Generate trace messages } + {$IFDEF DEBUG} + TRACEMS5(j_common_ptr(cinfo), 1, JTRC_JFIF, + cinfo^.JFIF_major_version, cinfo^.JFIF_minor_version, + cinfo^.X_density, cinfo^.Y_density, cinfo^.density_unit); + { Validate thumbnail dimensions and issue appropriate messages } + if (GETJOCTET(data[12]) or GETJOCTET(data[13])) <> 0 then + TRACEMS2(j_common_ptr(cinfo), 1, JTRC_JFIF_THUMBNAIL, + GETJOCTET(data[12]), GETJOCTET(data[13])); + Dec(totallen, APP0_DATA_LEN); + if (totallen <> + ( INT32(GETJOCTET(data[12])) * INT32(GETJOCTET(data[13])) * INT32(3) )) then + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_JFIF_BADTHUMBNAILSIZE, int(totallen)); + {$ENDIF} + end + else + if (datalen >= 6) and + (GETJOCTET(data[0]) = $4A) and + (GETJOCTET(data[1]) = $46) and + (GETJOCTET(data[2]) = $58) and + (GETJOCTET(data[3]) = $58) and + (GETJOCTET(data[4]) = 0) then + begin + { Found JFIF "JFXX" extension APP0 marker } + { The library doesn't actually do anything with these, + but we try to produce a helpful trace message. } + {$IFDEF DEBUG} + case (GETJOCTET(data[5])) of + $10: + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_THUMB_JPEG, int(totallen)); + $11: + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_THUMB_PALETTE, int(totallen)); + $13: + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_THUMB_RGB, int(totallen)); + else + TRACEMS2(j_common_ptr(cinfo), 1, JTRC_JFIF_EXTENSION, + GETJOCTET(data[5]), int(totallen)); + end; + {$ENDIF} + end + else + begin + { Start of APP0 does not match "JFIF" or "JFXX", or too short } + {$IFDEF DEBUG} + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_APP0, int(totallen)); + {$ENDIF} + end; +end; + + +{LOCAL} +procedure examine_app14 (cinfo : j_decompress_ptr; + var data : array of JOCTET; + datalen : uint; + remaining : INT32); +{ Examine first few bytes from an APP14. + Take appropriate action if it is an Adobe marker. + datalen is # of bytes at data[], remaining is length of rest of marker data. + } +var + {$IFDEF DEBUG} + version, flags0, flags1, + {$ENDIF} + transform : uint; +begin + if (datalen >= APP14_DATA_LEN) and + (GETJOCTET(data[0]) = $41) and + (GETJOCTET(data[1]) = $64) and + (GETJOCTET(data[2]) = $6F) and + (GETJOCTET(data[3]) = $62) and + (GETJOCTET(data[4]) = $65) then + begin + { Found Adobe APP14 marker } + {$IFDEF DEBUG} + version := (GETJOCTET(data[5]) shl 8) + GETJOCTET(data[6]); + flags0 := (GETJOCTET(data[7]) shl 8) + GETJOCTET(data[8]); + flags1 := (GETJOCTET(data[9]) shl 8) + GETJOCTET(data[10]); + {$ENDIF} + transform := GETJOCTET(data[11]); + {$IFDEF DEBUG} + TRACEMS4(j_common_ptr(cinfo), 1, JTRC_ADOBE, version, flags0, flags1, transform); + {$ENDIF} + cinfo^.saw_Adobe_marker := TRUE; + cinfo^.Adobe_transform := UINT8 (transform); + end + else + begin + { Start of APP14 does not match "Adobe", or too short } + {$IFDEF DEBUG} + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_APP14, int (datalen + remaining)); + {$ENDIF} + end; +end; + + +{METHODDEF} +function get_interesting_appn (cinfo : j_decompress_ptr) : boolean; +{ Process an APP0 or APP14 marker without saving it } +var + length : INT32; + b : array[0..APPN_DATA_LEN-1] of JOCTET; + i, numtoread: uint; +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; + bytes_in_buffer : size_t; +begin + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + +{ Read two bytes interpreted as an unsigned 16-bit integer. + length should be declared unsigned int or perhaps INT32. } + + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_interesting_appn := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + length := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_interesting_appn := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( length, GETJOCTET(next_input_byte^)); + Inc( next_input_byte ); + + Dec(length, 2); + + { get the interesting part of the marker data } + if (length >= APPN_DATA_LEN) then + numtoread := APPN_DATA_LEN + else + if (length > 0) then + numtoread := uint(length) + else + numtoread := 0; + + if numtoread > 0 then + begin + for i := 0 to numtoread-1 do + begin + { Read a byte into b[i]. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + get_interesting_appn := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + b[i] := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + end; + end; + + Dec(length, numtoread); + + { process it } + case (cinfo^.unread_marker) of + M_APP0: + examine_app0(cinfo, b, numtoread, length); + M_APP14: + examine_app14(cinfo, b, numtoread, length); + else + { can't get here unless jpeg_save_markers chooses wrong processor } + ERREXIT1(j_common_ptr(cinfo), JERR_UNKNOWN_MARKER, cinfo^.unread_marker); + end; + + { skip any remaining data -- could be lots } + + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + if (length > 0) then + cinfo^.src^.skip_input_data(cinfo, long(length)); + + get_interesting_appn := TRUE; +end; + +{$ifdef SAVE_MARKERS_SUPPORTED} + +{METHODDEF} +function save_marker (cinfo : j_decompress_ptr) : boolean; +{ Save an APPn or COM marker into the marker list } +var + marker : my_marker_ptr; + cur_marker : jpeg_saved_marker_ptr; + bytes_read, data_length : uint; + data : JOCTET_FIELD_PTR; + length : INT32; +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; + bytes_in_buffer : size_t; +var + limit : uint; +var + prev : jpeg_saved_marker_ptr; +begin + { local copies of input pointer/count } + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + + marker := my_marker_ptr(cinfo^.marker); + cur_marker := marker^.cur_marker; + length := 0; + + if (cur_marker = NIL) then + begin + { begin reading a marker } + { Read two bytes interpreted as an unsigned 16-bit integer. } + + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + save_marker := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + length := (uint( GETJOCTET(next_input_byte^)) shl 8); + Inc( next_input_byte ); + + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + save_marker := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + Inc( length, GETJOCTET(next_input_byte^)); + Inc( next_input_byte ); + + Dec(length, 2); + if (length >= 0) then + begin { watch out for bogus length word } + { figure out how much we want to save } + + if (cinfo^.unread_marker = int(M_COM)) then + limit := marker^.length_limit_COM + else + limit := marker^.length_limit_APPn[cinfo^.unread_marker - int(M_APP0)]; + if (uint(length) < limit) then + limit := uint(length); + { allocate and initialize the marker item } + cur_marker := jpeg_saved_marker_ptr( + cinfo^.mem^.alloc_large (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(jpeg_marker_struct) + limit) ); + cur_marker^.next := NIL; + cur_marker^.marker := UINT8 (cinfo^.unread_marker); + cur_marker^.original_length := uint(length); + cur_marker^.data_length := limit; + { data area is just beyond the jpeg_marker_struct } + cur_marker^.data := JOCTET_FIELD_PTR(cur_marker); + Inc(jpeg_saved_marker_ptr(cur_marker^.data)); + data := cur_marker^.data; + + marker^.cur_marker := cur_marker; + marker^.bytes_read := 0; + bytes_read := 0; + data_length := limit; + end + else + begin + { deal with bogus length word } + data_length := 0; + bytes_read := 0; + data := NIL; + end + end + else + begin + { resume reading a marker } + bytes_read := marker^.bytes_read; + data_length := cur_marker^.data_length; + data := cur_marker^.data; + Inc(data, bytes_read); + end; + + while (bytes_read < data_length) do + begin + { move the restart point to here } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + marker^.bytes_read := bytes_read; + { If there's not at least one byte in buffer, suspend } + if (bytes_in_buffer = 0) then + begin + if not datasrc^.fill_input_buffer (cinfo) then + begin + save_marker := FALSE; + exit; + end; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + + { Copy bytes with reasonable rapidity } + while (bytes_read < data_length) and (bytes_in_buffer > 0) do + begin + JOCTETPTR(data)^ := next_input_byte^; + Inc(JOCTETPTR(data)); + Inc(next_input_byte); + Dec(bytes_in_buffer); + Inc(bytes_read); + end; + end; + + { Done reading what we want to read } + if (cur_marker <> NIL) then + begin { will be NIL if bogus length word } + { Add new marker to end of list } + if (cinfo^.marker_list = NIL) then + begin + cinfo^.marker_list := cur_marker + end + else + begin + prev := cinfo^.marker_list; + while (prev^.next <> NIL) do + prev := prev^.next; + prev^.next := cur_marker; + end; + { Reset pointer & calc remaining data length } + data := cur_marker^.data; + length := cur_marker^.original_length - data_length; + end; + { Reset to initial state for next marker } + marker^.cur_marker := NIL; + + { Process the marker if interesting; else just make a generic trace msg } + case (cinfo^.unread_marker) of + M_APP0: + examine_app0(cinfo, data^, data_length, length); + M_APP14: + examine_app14(cinfo, data^, data_length, length); + else + {$IFDEF DEBUG} + TRACEMS2(j_common_ptr(cinfo), 1, JTRC_MISC_MARKER, cinfo^.unread_marker, + int(data_length + length)); + {$ENDIF} + end; + + { skip any remaining data -- could be lots } + { do before skip_input_data } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + if (length > 0) then + cinfo^.src^.skip_input_data (cinfo, long(length) ); + + save_marker := TRUE; +end; + +{$endif} { SAVE_MARKERS_SUPPORTED } + + +{ Find the next JPEG marker, save it in cinfo^.unread_marker. + Returns FALSE if had to suspend before reaching a marker; + in that case cinfo^.unread_marker is unchanged. + + Note that the result might not be a valid marker code, + but it will never be 0 or FF. } + +{LOCAL} +function next_marker (cinfo : j_decompress_ptr) : boolean; +var + c : int; +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; + bytes_in_buffer : size_t; +begin + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + + {while TRUE do} + repeat + { Read a byte into variable c. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + next_marker := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + { Skip any non-FF bytes. + This may look a bit inefficient, but it will not occur in a valid file. + We sync after each discarded byte so that a suspending data source + can discard the byte from its buffer. } + + while (c <> $FF) do + begin + Inc(cinfo^.marker^.discarded_bytes); + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + { Read a byte into variable c. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + next_marker := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + end; + { This loop swallows any duplicate FF bytes. Extra FFs are legal as + pad bytes, so don't count them in discarded_bytes. We assume there + will not be so many consecutive FF bytes as to overflow a suspending + data source's input buffer. } + + repeat + { Read a byte into variable c. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + next_marker := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + Until (c <> $FF); + if (c <> 0) then + break; { found a valid marker, exit loop } + { Reach here if we found a stuffed-zero data sequence (FF/00). + Discard it and loop back to try again. } + + Inc(cinfo^.marker^.discarded_bytes, 2); + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + Until False; + + if (cinfo^.marker^.discarded_bytes <> 0) then + begin + WARNMS2(j_common_ptr(cinfo), JWRN_EXTRANEOUS_DATA, + cinfo^.marker^.discarded_bytes, c); + cinfo^.marker^.discarded_bytes := 0; + end; + + cinfo^.unread_marker := c; + + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + next_marker := TRUE; +end; { next_marker } + + +{LOCAL} +function first_marker (cinfo : j_decompress_ptr) : boolean; +{ Like next_marker, but used to obtain the initial SOI marker. } +{ For this marker, we do not allow preceding garbage or fill; otherwise, + we might well scan an entire input file before realizing it ain't JPEG. + If an application wants to process non-JFIF files, it must seek to the + SOI before calling the JPEG library. } +var + c, c2 : int; +var + datasrc : jpeg_source_mgr_ptr; + next_input_byte : JOCTETptr; + bytes_in_buffer : size_t; +begin + datasrc := cinfo^.src; + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + + { Read a byte into variable c. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + first_marker := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + c := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + { Read a byte into variable c2. If must suspend, return FALSE. } + { make a byte available. + Note we do *not* do INPUT_SYNC before calling fill_input_buffer, + but we must reload the local copies after a successful fill. } + if (bytes_in_buffer = 0) then + begin + if (not datasrc^.fill_input_buffer(cinfo)) then + begin + first_marker := FALSE; + exit; + end; + { Reload the local copies } + next_input_byte := datasrc^.next_input_byte; + bytes_in_buffer := datasrc^.bytes_in_buffer; + end; + Dec( bytes_in_buffer ); + + c2 := GETJOCTET(next_input_byte^); + Inc(next_input_byte); + + if (c <> $FF) or (c2 <> int(M_SOI)) then + ERREXIT2(j_common_ptr(cinfo), JERR_NO_SOI, c, c2); + + cinfo^.unread_marker := c2; + + { Unload the local copies --- do this only at a restart boundary } + datasrc^.next_input_byte := next_input_byte; + datasrc^.bytes_in_buffer := bytes_in_buffer; + + first_marker := TRUE; +end; { first_marker } + + +{ Read markers until SOS or EOI. + + Returns same codes as are defined for jpeg_consume_input: + JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. } + +{METHODDEF} +function read_markers (cinfo : j_decompress_ptr) : int; +begin + { Outer loop repeats once for each marker. } + repeat + { Collect the marker proper, unless we already did. } + { NB: first_marker() enforces the requirement that SOI appear first. } + if (cinfo^.unread_marker = 0) then + begin + if not cinfo^.marker^.saw_SOI then + begin + if not first_marker(cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + end + else + begin + if not next_marker(cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + end; + end; + { At this point cinfo^.unread_marker contains the marker code and the + input point is just past the marker proper, but before any parameters. + A suspension will cause us to return with this state still true. } + + case (cinfo^.unread_marker) of + M_SOI: + if not get_soi(cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + M_SOF0, { Baseline } + M_SOF1: { Extended sequential, Huffman } + if not get_sof(cinfo, FALSE, FALSE) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + M_SOF2: { Progressive, Huffman } + if not get_sof(cinfo, TRUE, FALSE) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + M_SOF9: { Extended sequential, arithmetic } + if not get_sof(cinfo, FALSE, TRUE) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + M_SOF10: { Progressive, arithmetic } + if not get_sof(cinfo, TRUE, TRUE) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + { Currently unsupported SOFn types } + M_SOF3, { Lossless, Huffman } + M_SOF5, { Differential sequential, Huffman } + M_SOF6, { Differential progressive, Huffman } + M_SOF7, { Differential lossless, Huffman } + M_JPG, { Reserved for JPEG extensions } + M_SOF11, { Lossless, arithmetic } + M_SOF13, { Differential sequential, arithmetic } + M_SOF14, { Differential progressive, arithmetic } + M_SOF15: { Differential lossless, arithmetic } + ERREXIT1(j_common_ptr(cinfo), JERR_SOF_UNSUPPORTED, cinfo^.unread_marker); + + M_SOS: + begin + if not get_sos(cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + cinfo^.unread_marker := 0; { processed the marker } + read_markers := JPEG_REACHED_SOS; + exit; + end; + + M_EOI: + begin + {$IFDEF DEBUG} + TRACEMS(j_common_ptr(cinfo), 1, JTRC_EOI); + {$ENDIF} + cinfo^.unread_marker := 0; { processed the marker } + read_markers := JPEG_REACHED_EOI; + exit; + end; + + M_DAC: + if not get_dac(cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + M_DHT: + if not get_dht(cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + M_DQT: + if not get_dqt(cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + M_DRI: + if not get_dri(cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + M_APP0, + M_APP1, + M_APP2, + M_APP3, + M_APP4, + M_APP5, + M_APP6, + M_APP7, + M_APP8, + M_APP9, + M_APP10, + M_APP11, + M_APP12, + M_APP13, + M_APP14, + M_APP15: + if not my_marker_ptr(cinfo^.marker)^. + process_APPn[cinfo^.unread_marker - int(M_APP0)](cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + M_COM: + if not my_marker_ptr(cinfo^.marker)^.process_COM (cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + M_RST0, { these are all parameterless } + M_RST1, + M_RST2, + M_RST3, + M_RST4, + M_RST5, + M_RST6, + M_RST7, + M_TEM: + {$IFDEF DEBUG} + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_PARMLESS_MARKER, + cinfo^.unread_marker) + {$ENDIF} + ; + + M_DNL: { Ignore DNL ... perhaps the wrong thing } + if not skip_variable(cinfo) then + begin + read_markers := JPEG_SUSPENDED; + exit; + end; + + else { must be DHP, EXP, JPGn, or RESn } + { For now, we treat the reserved markers as fatal errors since they are + likely to be used to signal incompatible JPEG Part 3 extensions. + Once the JPEG 3 version-number marker is well defined, this code + ought to change! } + ERREXIT1(j_common_ptr(cinfo) , JERR_UNKNOWN_MARKER, + cinfo^.unread_marker); + end; { end of case } + { Successfully processed marker, so reset state variable } + cinfo^.unread_marker := 0; + Until false; +end; { read_markers } + + +{ Read a restart marker, which is expected to appear next in the datastream; + if the marker is not there, take appropriate recovery action. + Returns FALSE if suspension is required. + + This is called by the entropy decoder after it has read an appropriate + number of MCUs. cinfo^.unread_marker may be nonzero if the entropy decoder + has already read a marker from the data source. Under normal conditions + cinfo^.unread_marker will be reset to 0 before returning; if not reset, + it holds a marker which the decoder will be unable to read past. } + +{METHODDEF} +function read_restart_marker (cinfo : j_decompress_ptr) :boolean; +begin + { Obtain a marker unless we already did. } + { Note that next_marker will complain if it skips any data. } + if (cinfo^.unread_marker = 0) then + begin + if not next_marker(cinfo) then + begin + read_restart_marker := FALSE; + exit; + end; + end; + + if (cinfo^.unread_marker = (int(M_RST0) + cinfo^.marker^.next_restart_num)) then + begin + { Normal case --- swallow the marker and let entropy decoder continue } + {$IFDEF DEBUG} + TRACEMS1(j_common_ptr(cinfo), 3, JTRC_RST, + cinfo^.marker^.next_restart_num); + {$ENDIF} + cinfo^.unread_marker := 0; + end + else + begin + { Uh-oh, the restart markers have been messed up. } + { Let the data source manager determine how to resync. } + if not cinfo^.src^.resync_to_restart(cinfo, + cinfo^.marker^.next_restart_num) then + begin + read_restart_marker := FALSE; + exit; + end; + end; + + { Update next-restart state } + with cinfo^.marker^ do + next_restart_num := (next_restart_num + 1) and 7; + + read_restart_marker := TRUE; +end; { read_restart_marker } + + +{ This is the default resync_to_restart method for data source managers + to use if they don't have any better approach. Some data source managers + may be able to back up, or may have additional knowledge about the data + which permits a more intelligent recovery strategy; such managers would + presumably supply their own resync method. + + read_restart_marker calls resync_to_restart if it finds a marker other than + the restart marker it was expecting. (This code is *not* used unless + a nonzero restart interval has been declared.) cinfo^.unread_marker is + the marker code actually found (might be anything, except 0 or FF). + The desired restart marker number (0..7) is passed as a parameter. + This routine is supposed to apply whatever error recovery strategy seems + appropriate in order to position the input stream to the next data segment. + Note that cinfo^.unread_marker is treated as a marker appearing before + the current data-source input point; usually it should be reset to zero + before returning. + Returns FALSE if suspension is required. + + This implementation is substantially constrained by wanting to treat the + input as a data stream; this means we can't back up. Therefore, we have + only the following actions to work with: + 1. Simply discard the marker and let the entropy decoder resume at next + byte of file. + 2. Read forward until we find another marker, discarding intervening + data. (In theory we could look ahead within the current bufferload, + without having to discard data if we don't find the desired marker. + This idea is not implemented here, in part because it makes behavior + dependent on buffer size and chance buffer-boundary positions.) + 3. Leave the marker unread (by failing to zero cinfo^.unread_marker). + This will cause the entropy decoder to process an empty data segment, + inserting dummy zeroes, and then we will reprocess the marker. + + #2 is appropriate if we think the desired marker lies ahead, while #3 is + appropriate if the found marker is a future restart marker (indicating + that we have missed the desired restart marker, probably because it got + corrupted). + We apply #2 or #3 if the found marker is a restart marker no more than + two counts behind or ahead of the expected one. We also apply #2 if the + found marker is not a legal JPEG marker code (it's certainly bogus data). + If the found marker is a restart marker more than 2 counts away, we do #1 + (too much risk that the marker is erroneous; with luck we will be able to + resync at some future point). + For any valid non-restart JPEG marker, we apply #3. This keeps us from + overrunning the end of a scan. An implementation limited to single-scan + files might find it better to apply #2 for markers other than EOI, since + any other marker would have to be bogus data in that case. } + + +{GLOBAL} +function jpeg_resync_to_restart(cinfo : j_decompress_ptr; + desired : int) : boolean; +var + marker : int; + action : int; +begin + marker := cinfo^.unread_marker; + //action := 1; { never used } + { Always put up a warning. } + WARNMS2(j_common_ptr(cinfo), JWRN_MUST_RESYNC, marker, desired); + + { Outer loop handles repeated decision after scanning forward. } + repeat + if (marker < int(M_SOF0)) then + action := 2 { invalid marker } + else + if (marker < int(M_RST0)) or (marker > int(M_RST7)) then + action := 3 { valid non-restart marker } + else + begin + if (marker = (int(M_RST0) + ((desired+1) and 7))) or + (marker = (int(M_RST0) + ((desired+2) and 7))) then + action := 3 { one of the next two expected restarts } + else + if (marker = (int(M_RST0) + ((desired-1) and 7))) or + (marker = (int(M_RST0) + ((desired-2) and 7))) then + action := 2 { a prior restart, so advance } + else + action := 1; { desired restart or too far away } + end; + + {$IFDEF DEBUG} + TRACEMS2(j_common_ptr(cinfo), 4, JTRC_RECOVERY_ACTION, marker, action); + {$ENDIF} + case action of + 1: + { Discard marker and let entropy decoder resume processing. } + begin + cinfo^.unread_marker := 0; + jpeg_resync_to_restart := TRUE; + exit; + end; + 2: + { Scan to the next marker, and repeat the decision loop. } + begin + if not next_marker(cinfo) then + begin + jpeg_resync_to_restart := FALSE; + exit; + end; + marker := cinfo^.unread_marker; + end; + 3: + { Return without advancing past this marker. } + { Entropy decoder will be forced to process an empty segment. } + begin + jpeg_resync_to_restart := TRUE; + exit; + end; + end; { case } + Until false; { end loop } +end; { jpeg_resync_to_restart } + + +{ Reset marker processing state to begin a fresh datastream. } + +{METHODDEF} +procedure reset_marker_reader (cinfo : j_decompress_ptr); +var + marker : my_marker_ptr; +begin + marker := my_marker_ptr (cinfo^.marker); + with cinfo^ do + begin + comp_info := NIL; { until allocated by get_sof } + input_scan_number := 0; { no SOS seen yet } + unread_marker := 0; { no pending marker } + end; + marker^.pub.saw_SOI := FALSE; { set internal state too } + marker^.pub.saw_SOF := FALSE; + marker^.pub.discarded_bytes := 0; + marker^.cur_marker := NIL; +end; { reset_marker_reader } + + +{ Initialize the marker reader module. + This is called only once, when the decompression object is created. } + +{GLOBAL} +procedure jinit_marker_reader (cinfo : j_decompress_ptr); +var + marker : my_marker_ptr; + i : int; +begin + { Create subobject in permanent pool } + marker := my_marker_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT, + SIZEOF(my_marker_reader)) + ); + cinfo^.marker := jpeg_marker_reader_ptr(marker); + { Initialize method pointers } + marker^.pub.reset_marker_reader := reset_marker_reader; + marker^.pub.read_markers := read_markers; + marker^.pub.read_restart_marker := read_restart_marker; + { Initialize COM/APPn processing. + By default, we examine and then discard APP0 and APP14, + but simply discard COM and all other APPn. } + + marker^.process_COM := skip_variable; + marker^.length_limit_COM := 0; + for i := 0 to 16-1 do + begin + marker^.process_APPn[i] := skip_variable; + marker^.length_limit_APPn[i] := 0; + end; + marker^.process_APPn[0] := get_interesting_appn; + marker^.process_APPn[14] := get_interesting_appn; + { Reset marker processing state } + reset_marker_reader(cinfo); +end; { jinit_marker_reader } + + +{ Control saving of COM and APPn markers into marker_list. } + + +{$ifdef SAVE_MARKERS_SUPPORTED} + +{GLOBAL} +procedure jpeg_save_markers (cinfo : j_decompress_ptr; + marker_code : int; + length_limit : uint); +var + marker : my_marker_ptr; + maxlength : long; + processor : jpeg_marker_parser_method; +begin + marker := my_marker_ptr (cinfo^.marker); + + { Length limit mustn't be larger than what we can allocate + (should only be a concern in a 16-bit environment). } + + maxlength := cinfo^.mem^.max_alloc_chunk - SIZEOF(jpeg_marker_struct); + if (long(length_limit) > maxlength) then + length_limit := uint(maxlength); + + { Choose processor routine to use. + APP0/APP14 have special requirements. } + + if (length_limit <> 0) then + begin + processor := save_marker; + { If saving APP0/APP14, save at least enough for our internal use. } + if (marker_code = int(M_APP0)) and (length_limit < APP0_DATA_LEN) then + length_limit := APP0_DATA_LEN + else + if (marker_code = int(M_APP14)) and (length_limit < APP14_DATA_LEN) then + length_limit := APP14_DATA_LEN; + end + else + begin + processor := skip_variable; + { If discarding APP0/APP14, use our regular on-the-fly processor. } + if (marker_code = int(M_APP0)) or (marker_code = int(M_APP14)) then + processor := get_interesting_appn; + end; + + if (marker_code = int(M_COM)) then + begin + marker^.process_COM := processor; + marker^.length_limit_COM := length_limit; + end + else + if (marker_code >= int(M_APP0)) and (marker_code <= int(M_APP15)) then + begin + marker^.process_APPn[marker_code - int(M_APP0)] := processor; + marker^.length_limit_APPn[marker_code - int(M_APP0)] := length_limit; + end + else + ERREXIT1(j_common_ptr(cinfo), JERR_UNKNOWN_MARKER, marker_code); +end; + +{$endif} { SAVE_MARKERS_SUPPORTED } + +{ Install a special processing method for COM or APPn markers. } + +{GLOBAL} + +procedure jpeg_set_marker_processor (cinfo : j_decompress_ptr; + marker_code : int; + routine : jpeg_marker_parser_method); +var + marker : my_marker_ptr; +begin + marker := my_marker_ptr (cinfo^.marker); + if (marker_code = int(M_COM)) then + marker^.process_COM := routine + else + if (marker_code >= int(M_APP0)) and (marker_code <= int(M_APP15)) then + marker^.process_APPn[marker_code - int(M_APP0)] := routine + else + ERREXIT1(j_common_ptr(cinfo), JERR_UNKNOWN_MARKER, marker_code); +end; + +end. diff --git a/Imaging/JpegLib/imjdmaster.pas b/Imaging/JpegLib/imjdmaster.pas index 076eeec..f78e928 100644 --- a/Imaging/JpegLib/imjdmaster.pas +++ b/Imaging/JpegLib/imjdmaster.pas @@ -1,679 +1,679 @@ -unit imjdmaster; - -{ This file contains master control logic for the JPEG decompressor. - These routines are concerned with selecting the modules to be executed - and with determining the number of passes and the work to be done in each - pass. } - -{ Original: jdmaster.c ; Copyright (C) 1991-1998, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjutils, - imjerror, - imjdeferr, - imjdcolor, imjdsample, imjdpostct, imjddctmgr, imjdphuff, - imjdhuff, imjdcoefct, imjdmainct, -{$ifdef QUANT_1PASS_SUPPORTED} - imjquant1, -{$endif} -{$ifdef QUANT_2PASS_SUPPORTED} - imjquant2, -{$endif} -{$ifdef UPSAMPLE_MERGING_SUPPORTED} - imjdmerge, -{$endif} - imjpeglib; - - -{ Compute output image dimensions and related values. - NOTE: this is exported for possible use by application. - Hence it mustn't do anything that can't be done twice. - Also note that it may be called before the master module is initialized! } - -{GLOBAL} -procedure jpeg_calc_output_dimensions (cinfo : j_decompress_ptr); -{ Do computations that are needed before master selection phase } - - -{$ifdef D_MULTISCAN_FILES_SUPPORTED} - -{GLOBAL} -procedure jpeg_new_colormap (cinfo : j_decompress_ptr); - -{$endif} - -{ Initialize master decompression control and select active modules. - This is performed at the start of jpeg_start_decompress. } - -{GLOBAL} -procedure jinit_master_decompress (cinfo : j_decompress_ptr); - -implementation - -{ Private state } - -type - my_master_ptr = ^my_decomp_master; - my_decomp_master = record - pub : jpeg_decomp_master; { public fields } - - pass_number : int; { # of passes completed } - - using_merged_upsample : boolean; { TRUE if using merged upsample/cconvert } - - { Saved references to initialized quantizer modules, - in case we need to switch modes. } - - quantizer_1pass : jpeg_color_quantizer_ptr; - quantizer_2pass : jpeg_color_quantizer_ptr; - end; - -{ Determine whether merged upsample/color conversion should be used. - CRUCIAL: this must match the actual capabilities of jdmerge.c! } - -{LOCAL} -function use_merged_upsample (cinfo : j_decompress_ptr) : boolean; -var - compptr : jpeg_component_info_list_ptr; -begin - compptr := cinfo^.comp_info; - -{$ifdef UPSAMPLE_MERGING_SUPPORTED} - { Merging is the equivalent of plain box-filter upsampling } - if (cinfo^.do_fancy_upsampling) or (cinfo^.CCIR601_sampling) then - begin - use_merged_upsample := FALSE; - exit; - end; - { jdmerge.c only supports YCC=>RGB color conversion } - if (cinfo^.jpeg_color_space <> JCS_YCbCr) or (cinfo^.num_components <> 3) - or (cinfo^.out_color_space <> JCS_RGB) - or (cinfo^.out_color_components <> RGB_PIXELSIZE) then - begin - use_merged_upsample := FALSE; - exit; - end; - - { and it only handles 2h1v or 2h2v sampling ratios } - if (compptr^[0].h_samp_factor <> 2) or - (compptr^[1].h_samp_factor <> 1) or - (compptr^[2].h_samp_factor <> 1) or - (compptr^[0].v_samp_factor > 2) or - (compptr^[1].v_samp_factor <> 1) or - (compptr^[2].v_samp_factor <> 1) then - begin - use_merged_upsample := FALSE; - exit; - end; - { furthermore, it doesn't work if we've scaled the IDCTs differently } - if (compptr^[0].DCT_scaled_size <> cinfo^.min_DCT_scaled_size) or - (compptr^[1].DCT_scaled_size <> cinfo^.min_DCT_scaled_size) or - (compptr^[2].DCT_scaled_size <> cinfo^.min_DCT_scaled_size) then - begin - use_merged_upsample := FALSE; - exit; - end; - { ??? also need to test for upsample-time rescaling, when & if supported } - use_merged_upsample := TRUE; { by golly, it'll work... } -{$else} - use_merged_upsample := FALSE; -{$endif} -end; - - -{ Compute output image dimensions and related values. - NOTE: this is exported for possible use by application. - Hence it mustn't do anything that can't be done twice. - Also note that it may be called before the master module is initialized! } - -{GLOBAL} -procedure jpeg_calc_output_dimensions (cinfo : j_decompress_ptr); -{ Do computations that are needed before master selection phase } -{$ifdef IDCT_SCALING_SUPPORTED} -var - ci : int; - compptr : jpeg_component_info_ptr; -{$endif} -var - ssize : int; -begin - { Prevent application from calling me at wrong times } - if (cinfo^.global_state <> DSTATE_READY) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - -{$ifdef IDCT_SCALING_SUPPORTED} - - { Compute actual output image dimensions and DCT scaling choices. } - if (cinfo^.scale_num * 8 <= cinfo^.scale_denom) then - begin - { Provide 1/8 scaling } - cinfo^.output_width := JDIMENSION ( - jdiv_round_up( long(cinfo^.image_width), long(8)) ); - cinfo^.output_height := JDIMENSION ( - jdiv_round_up( long(cinfo^.image_height), long(8)) ); - cinfo^.min_DCT_scaled_size := 1; - end - else - if (cinfo^.scale_num * 4 <= cinfo^.scale_denom) then - begin - { Provide 1/4 scaling } - cinfo^.output_width := JDIMENSION ( - jdiv_round_up( long (cinfo^.image_width), long(4)) ); - cinfo^.output_height := JDIMENSION ( - jdiv_round_up( long (cinfo^.image_height), long(4)) ); - cinfo^.min_DCT_scaled_size := 2; - end - else - if (cinfo^.scale_num * 2 <= cinfo^.scale_denom) then - begin - { Provide 1/2 scaling } - cinfo^.output_width := JDIMENSION ( - jdiv_round_up( long(cinfo^.image_width), long(2)) ); - cinfo^.output_height := JDIMENSION ( - jdiv_round_up( long(cinfo^.image_height), long(2)) ); - cinfo^.min_DCT_scaled_size := 4; - end - else - begin - { Provide 1/1 scaling } - cinfo^.output_width := cinfo^.image_width; - cinfo^.output_height := cinfo^.image_height; - cinfo^.min_DCT_scaled_size := DCTSIZE; - end; - { In selecting the actual DCT scaling for each component, we try to - scale up the chroma components via IDCT scaling rather than upsampling. - This saves time if the upsampler gets to use 1:1 scaling. - Note this code assumes that the supported DCT scalings are powers of 2. } - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - ssize := cinfo^.min_DCT_scaled_size; - while (ssize < DCTSIZE) and - ((compptr^.h_samp_factor * ssize * 2 <= - cinfo^.max_h_samp_factor * cinfo^.min_DCT_scaled_size) and - (compptr^.v_samp_factor * ssize * 2 <= - cinfo^.max_v_samp_factor * cinfo^.min_DCT_scaled_size)) do - begin - ssize := ssize * 2; - end; - compptr^.DCT_scaled_size := ssize; - Inc(compptr); - end; - - { Recompute downsampled dimensions of components; - application needs to know these if using raw downsampled data. } - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - { Size in samples, after IDCT scaling } - compptr^.downsampled_width := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_width) * - long (compptr^.h_samp_factor * compptr^.DCT_scaled_size), - long (cinfo^.max_h_samp_factor * DCTSIZE)) ); - compptr^.downsampled_height := JDIMENSION ( - jdiv_round_up(long (cinfo^.image_height) * - long (compptr^.v_samp_factor * compptr^.DCT_scaled_size), - long (cinfo^.max_v_samp_factor * DCTSIZE)) ); - Inc(compptr); - end; - -{$else} { !IDCT_SCALING_SUPPORTED } - - { Hardwire it to "no scaling" } - cinfo^.output_width := cinfo^.image_width; - cinfo^.output_height := cinfo^.image_height; - { jdinput.c has already initialized DCT_scaled_size to DCTSIZE, - and has computed unscaled downsampled_width and downsampled_height. } - -{$endif} { IDCT_SCALING_SUPPORTED } - - { Report number of components in selected colorspace. } - { Probably this should be in the color conversion module... } - case (cinfo^.out_color_space) of - JCS_GRAYSCALE: - cinfo^.out_color_components := 1; -{$ifndef RGB_PIXELSIZE_IS_3} - JCS_RGB: - cinfo^.out_color_components := RGB_PIXELSIZE; -{$else} - JCS_RGB, -{$endif} { else share code with YCbCr } - JCS_YCbCr: - cinfo^.out_color_components := 3; - JCS_CMYK, - JCS_YCCK: - cinfo^.out_color_components := 4; - else { else must be same colorspace as in file } - cinfo^.out_color_components := cinfo^.num_components; - end; - if (cinfo^.quantize_colors) then - cinfo^.output_components := 1 - else - cinfo^.output_components := cinfo^.out_color_components; - - { See if upsampler will want to emit more than one row at a time } - if (use_merged_upsample(cinfo)) then - cinfo^.rec_outbuf_height := cinfo^.max_v_samp_factor - else - cinfo^.rec_outbuf_height := 1; -end; - - -{ Several decompression processes need to range-limit values to the range - 0..MAXJSAMPLE; the input value may fall somewhat outside this range - due to noise introduced by quantization, roundoff error, etc. These - processes are inner loops and need to be as fast as possible. On most - machines, particularly CPUs with pipelines or instruction prefetch, - a (subscript-check-less) C table lookup - x := sample_range_limit[x]; - is faster than explicit tests - if (x < 0) x := 0; - else if (x > MAXJSAMPLE) x := MAXJSAMPLE; - These processes all use a common table prepared by the routine below. - - For most steps we can mathematically guarantee that the initial value - of x is within MAXJSAMPLE+1 of the legal range, so a table running from - -(MAXJSAMPLE+1) to 2*MAXJSAMPLE+1 is sufficient. But for the initial - limiting step (just after the IDCT), a wildly out-of-range value is - possible if the input data is corrupt. To avoid any chance of indexing - off the end of memory and getting a bad-pointer trap, we perform the - post-IDCT limiting thus: - x := range_limit[x & MASK]; - where MASK is 2 bits wider than legal sample data, ie 10 bits for 8-bit - samples. Under normal circumstances this is more than enough range and - a correct output will be generated; with bogus input data the mask will - cause wraparound, and we will safely generate a bogus-but-in-range output. - For the post-IDCT step, we want to convert the data from signed to unsigned - representation by adding CENTERJSAMPLE at the same time that we limit it. - So the post-IDCT limiting table ends up looking like this: - CENTERJSAMPLE,CENTERJSAMPLE+1,...,MAXJSAMPLE, - MAXJSAMPLE (repeat 2*(MAXJSAMPLE+1)-CENTERJSAMPLE times), - 0 (repeat 2*(MAXJSAMPLE+1)-CENTERJSAMPLE times), - 0,1,...,CENTERJSAMPLE-1 - Negative inputs select values from the upper half of the table after - masking. - - We can save some space by overlapping the start of the post-IDCT table - with the simpler range limiting table. The post-IDCT table begins at - sample_range_limit + CENTERJSAMPLE. - - Note that the table is allocated in near data space on PCs; it's small - enough and used often enough to justify this. } - -{LOCAL} -procedure prepare_range_limit_table (cinfo : j_decompress_ptr); -{ Allocate and fill in the sample_range_limit table } -var - table : range_limit_table_ptr; - idct_table : JSAMPROW; - i : int; -begin - table := range_limit_table_ptr ( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - (5 * (MAXJSAMPLE+1) + CENTERJSAMPLE) * SIZEOF(JSAMPLE)) ); - - { First segment of "simple" table: limit[x] := 0 for x < 0 } - MEMZERO(table, (MAXJSAMPLE+1) * SIZEOF(JSAMPLE)); - - cinfo^.sample_range_limit := (table); - { allow negative subscripts of simple table } - { is noop, handled via type definition (Nomssi) } - { Main part of "simple" table: limit[x] := x } - for i := 0 to MAXJSAMPLE do - table^[i] := JSAMPLE (i); - idct_table := JSAMPROW(@ table^[CENTERJSAMPLE]); - { Point to where post-IDCT table starts } - { End of simple table, rest of first half of post-IDCT table } - for i := CENTERJSAMPLE to pred(2*(MAXJSAMPLE+1)) do - idct_table^[i] := MAXJSAMPLE; - { Second half of post-IDCT table } - MEMZERO(@(idct_table^[2 * (MAXJSAMPLE+1)]), - (2 * (MAXJSAMPLE+1) - CENTERJSAMPLE) * SIZEOF(JSAMPLE)); - MEMCOPY(@(idct_table^[(4 * (MAXJSAMPLE+1) - CENTERJSAMPLE)]), - @cinfo^.sample_range_limit^[0], CENTERJSAMPLE * SIZEOF(JSAMPLE)); - -end; - - -{ Master selection of decompression modules. - This is done once at jpeg_start_decompress time. We determine - which modules will be used and give them appropriate initialization calls. - We also initialize the decompressor input side to begin consuming data. - - Since jpeg_read_header has finished, we know what is in the SOF - and (first) SOS markers. We also have all the application parameter - settings. } - -{LOCAL} -procedure master_selection (cinfo : j_decompress_ptr); -var - master : my_master_ptr; - use_c_buffer : boolean; - samplesperrow : long; - jd_samplesperrow : JDIMENSION; -var - nscans : int; -begin - master := my_master_ptr (cinfo^.master); - - { Initialize dimensions and other stuff } - jpeg_calc_output_dimensions(cinfo); - prepare_range_limit_table(cinfo); - - { Width of an output scanline must be representable as JDIMENSION. } - samplesperrow := long(cinfo^.output_width) * long (cinfo^.out_color_components); - jd_samplesperrow := JDIMENSION (samplesperrow); - if (long(jd_samplesperrow) <> samplesperrow) then - ERREXIT(j_common_ptr(cinfo), JERR_WIDTH_OVERFLOW); - - { Initialize my private state } - master^.pass_number := 0; - master^.using_merged_upsample := use_merged_upsample(cinfo); - - { Color quantizer selection } - master^.quantizer_1pass := NIL; - master^.quantizer_2pass := NIL; - { No mode changes if not using buffered-image mode. } - if (not cinfo^.quantize_colors) or (not cinfo^.buffered_image) then - begin - cinfo^.enable_1pass_quant := FALSE; - cinfo^.enable_external_quant := FALSE; - cinfo^.enable_2pass_quant := FALSE; - end; - if (cinfo^.quantize_colors) then - begin - if (cinfo^.raw_data_out) then - ERREXIT(j_common_ptr(cinfo), JERR_NOTIMPL); - { 2-pass quantizer only works in 3-component color space. } - if (cinfo^.out_color_components <> 3) then - begin - cinfo^.enable_1pass_quant := TRUE; - cinfo^.enable_external_quant := FALSE; - cinfo^.enable_2pass_quant := FALSE; - cinfo^.colormap := NIL; - end - else - if (cinfo^.colormap <> NIL) then - begin - cinfo^.enable_external_quant := TRUE; - end - else - if (cinfo^.two_pass_quantize) then - begin - cinfo^.enable_2pass_quant := TRUE; - end - else - begin - cinfo^.enable_1pass_quant := TRUE; - end; - - if (cinfo^.enable_1pass_quant) then - begin -{$ifdef QUANT_1PASS_SUPPORTED} - jinit_1pass_quantizer(cinfo); - master^.quantizer_1pass := cinfo^.cquantize; -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} - end; - - { We use the 2-pass code to map to external colormaps. } - if (cinfo^.enable_2pass_quant) or (cinfo^.enable_external_quant) then - begin -{$ifdef QUANT_2PASS_SUPPORTED} - jinit_2pass_quantizer(cinfo); - master^.quantizer_2pass := cinfo^.cquantize; -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} - end; - { If both quantizers are initialized, the 2-pass one is left active; - this is necessary for starting with quantization to an external map. } - end; - - { Post-processing: in particular, color conversion first } - if (not cinfo^.raw_data_out) then - begin - if (master^.using_merged_upsample) then - begin -{$ifdef UPSAMPLE_MERGING_SUPPORTED} - jinit_merged_upsampler(cinfo); { does color conversion too } -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} - end - else - begin - jinit_color_deconverter(cinfo); - jinit_upsampler(cinfo); - end; - jinit_d_post_controller(cinfo, cinfo^.enable_2pass_quant); - end; - { Inverse DCT } - jinit_inverse_dct(cinfo); - { Entropy decoding: either Huffman or arithmetic coding. } - if (cinfo^.arith_code) then - begin - ERREXIT(j_common_ptr(cinfo), JERR_ARITH_NOTIMPL); - end - else - begin - if (cinfo^.progressive_mode) then - begin -{$ifdef D_PROGRESSIVE_SUPPORTED} - jinit_phuff_decoder(cinfo); -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} - end - else - jinit_huff_decoder(cinfo); - end; - - { Initialize principal buffer controllers. } - use_c_buffer := cinfo^.inputctl^.has_multiple_scans or cinfo^.buffered_image; - jinit_d_coef_controller(cinfo, use_c_buffer); - - if (not cinfo^.raw_data_out) then - jinit_d_main_controller(cinfo, FALSE { never need full buffer here }); - - { We can now tell the memory manager to allocate virtual arrays. } - cinfo^.mem^.realize_virt_arrays (j_common_ptr(cinfo)); - - { Initialize input side of decompressor to consume first scan. } - cinfo^.inputctl^.start_input_pass (cinfo); - -{$ifdef D_MULTISCAN_FILES_SUPPORTED} - { If jpeg_start_decompress will read the whole file, initialize - progress monitoring appropriately. The input step is counted - as one pass. } - - if (cinfo^.progress <> NIL) and (not cinfo^.buffered_image) and - (cinfo^.inputctl^.has_multiple_scans) then - begin - - { Estimate number of scans to set pass_limit. } - if (cinfo^.progressive_mode) then - begin - { Arbitrarily estimate 2 interleaved DC scans + 3 AC scans/component. } - nscans := 2 + 3 * cinfo^.num_components; - end - else - begin - { For a nonprogressive multiscan file, estimate 1 scan per component. } - nscans := cinfo^.num_components; - end; - cinfo^.progress^.pass_counter := Long(0); - cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows) * nscans; - cinfo^.progress^.completed_passes := 0; - if cinfo^.enable_2pass_quant then - cinfo^.progress^.total_passes := 3 - else - cinfo^.progress^.total_passes := 2; - { Count the input pass as done } - Inc(master^.pass_number); - end; -{$endif} { D_MULTISCAN_FILES_SUPPORTED } -end; - - -{ Per-pass setup. - This is called at the beginning of each output pass. We determine which - modules will be active during this pass and give them appropriate - start_pass calls. We also set is_dummy_pass to indicate whether this - is a "real" output pass or a dummy pass for color quantization. - (In the latter case, jdapistd.c will crank the pass to completion.) } - -{METHODDEF} -procedure prepare_for_output_pass (cinfo : j_decompress_ptr); -var - master : my_master_ptr; -begin - master := my_master_ptr (cinfo^.master); - - if (master^.pub.is_dummy_pass) then - begin -{$ifdef QUANT_2PASS_SUPPORTED} - { Final pass of 2-pass quantization } - master^.pub.is_dummy_pass := FALSE; - cinfo^.cquantize^.start_pass (cinfo, FALSE); - cinfo^.post^.start_pass (cinfo, JBUF_CRANK_DEST); - cinfo^.main^.start_pass (cinfo, JBUF_CRANK_DEST); -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); -{$endif} { QUANT_2PASS_SUPPORTED } - end - else - begin - if (cinfo^.quantize_colors) and (cinfo^.colormap = NIL) then - begin - { Select new quantization method } - if (cinfo^.two_pass_quantize) and (cinfo^.enable_2pass_quant) then - begin - cinfo^.cquantize := master^.quantizer_2pass; - master^.pub.is_dummy_pass := TRUE; - end - else - if (cinfo^.enable_1pass_quant) then - begin - cinfo^.cquantize := master^.quantizer_1pass; - end - else - begin - ERREXIT(j_common_ptr(cinfo), JERR_MODE_CHANGE); - end; - end; - cinfo^.idct^.start_pass (cinfo); - cinfo^.coef^.start_output_pass (cinfo); - if (not cinfo^.raw_data_out) then - begin - if (not master^.using_merged_upsample) then - cinfo^.cconvert^.start_pass (cinfo); - cinfo^.upsample^.start_pass (cinfo); - if (cinfo^.quantize_colors) then - cinfo^.cquantize^.start_pass (cinfo, master^.pub.is_dummy_pass); - if master^.pub.is_dummy_pass then - cinfo^.post^.start_pass (cinfo, JBUF_SAVE_AND_PASS) - else - cinfo^.post^.start_pass (cinfo, JBUF_PASS_THRU); - cinfo^.main^.start_pass (cinfo, JBUF_PASS_THRU); - end; - end; - - { Set up progress monitor's pass info if present } - if (cinfo^.progress <> NIL) then - begin - cinfo^.progress^.completed_passes := master^.pass_number; - if master^.pub.is_dummy_pass then - cinfo^.progress^.total_passes := master^.pass_number + 2 - else - cinfo^.progress^.total_passes := master^.pass_number + 1; - { In buffered-image mode, we assume one more output pass if EOI not - yet reached, but no more passes if EOI has been reached. } - - if (cinfo^.buffered_image) and (not cinfo^.inputctl^.eoi_reached) then - begin - if cinfo^.enable_2pass_quant then - Inc(cinfo^.progress^.total_passes, 2) - else - Inc(cinfo^.progress^.total_passes, 1); - end; - end; -end; - - -{ Finish up at end of an output pass. } - -{METHODDEF} -procedure finish_output_pass (cinfo : j_decompress_ptr); -var - master : my_master_ptr; -begin - master := my_master_ptr (cinfo^.master); - - if (cinfo^.quantize_colors) then - cinfo^.cquantize^.finish_pass (cinfo); - Inc(master^.pass_number); -end; - - -{$ifdef D_MULTISCAN_FILES_SUPPORTED} - -{ Switch to a new external colormap between output passes. } - -{GLOBAL} -procedure jpeg_new_colormap (cinfo : j_decompress_ptr); -var - master : my_master_ptr; -begin - master := my_master_ptr (cinfo^.master); - - { Prevent application from calling me at wrong times } - if (cinfo^.global_state <> DSTATE_BUFIMAGE) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); - - if (cinfo^.quantize_colors) and (cinfo^.enable_external_quant) and - (cinfo^.colormap <> NIL) then - begin - { Select 2-pass quantizer for external colormap use } - cinfo^.cquantize := master^.quantizer_2pass; - { Notify quantizer of colormap change } - cinfo^.cquantize^.new_color_map (cinfo); - master^.pub.is_dummy_pass := FALSE; { just in case } - end - else - ERREXIT(j_common_ptr(cinfo), JERR_MODE_CHANGE); -end; - -{$endif} { D_MULTISCAN_FILES_SUPPORTED } - - -{ Initialize master decompression control and select active modules. - This is performed at the start of jpeg_start_decompress. } - -{GLOBAL} -procedure jinit_master_decompress (cinfo : j_decompress_ptr); -var - master : my_master_ptr; -begin - master := my_master_ptr ( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_decomp_master)) ); - cinfo^.master := jpeg_decomp_master_ptr(master); - master^.pub.prepare_for_output_pass := prepare_for_output_pass; - master^.pub.finish_output_pass := finish_output_pass; - - master^.pub.is_dummy_pass := FALSE; - - master_selection(cinfo); -end; - -end. +unit imjdmaster; + +{ This file contains master control logic for the JPEG decompressor. + These routines are concerned with selecting the modules to be executed + and with determining the number of passes and the work to be done in each + pass. } + +{ Original: jdmaster.c ; Copyright (C) 1991-1998, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjutils, + imjerror, + imjdeferr, + imjdcolor, imjdsample, imjdpostct, imjddctmgr, imjdphuff, + imjdhuff, imjdcoefct, imjdmainct, +{$ifdef QUANT_1PASS_SUPPORTED} + imjquant1, +{$endif} +{$ifdef QUANT_2PASS_SUPPORTED} + imjquant2, +{$endif} +{$ifdef UPSAMPLE_MERGING_SUPPORTED} + imjdmerge, +{$endif} + imjpeglib; + + +{ Compute output image dimensions and related values. + NOTE: this is exported for possible use by application. + Hence it mustn't do anything that can't be done twice. + Also note that it may be called before the master module is initialized! } + +{GLOBAL} +procedure jpeg_calc_output_dimensions (cinfo : j_decompress_ptr); +{ Do computations that are needed before master selection phase } + + +{$ifdef D_MULTISCAN_FILES_SUPPORTED} + +{GLOBAL} +procedure jpeg_new_colormap (cinfo : j_decompress_ptr); + +{$endif} + +{ Initialize master decompression control and select active modules. + This is performed at the start of jpeg_start_decompress. } + +{GLOBAL} +procedure jinit_master_decompress (cinfo : j_decompress_ptr); + +implementation + +{ Private state } + +type + my_master_ptr = ^my_decomp_master; + my_decomp_master = record + pub : jpeg_decomp_master; { public fields } + + pass_number : int; { # of passes completed } + + using_merged_upsample : boolean; { TRUE if using merged upsample/cconvert } + + { Saved references to initialized quantizer modules, + in case we need to switch modes. } + + quantizer_1pass : jpeg_color_quantizer_ptr; + quantizer_2pass : jpeg_color_quantizer_ptr; + end; + +{ Determine whether merged upsample/color conversion should be used. + CRUCIAL: this must match the actual capabilities of jdmerge.c! } + +{LOCAL} +function use_merged_upsample (cinfo : j_decompress_ptr) : boolean; +var + compptr : jpeg_component_info_list_ptr; +begin + compptr := cinfo^.comp_info; + +{$ifdef UPSAMPLE_MERGING_SUPPORTED} + { Merging is the equivalent of plain box-filter upsampling } + if (cinfo^.do_fancy_upsampling) or (cinfo^.CCIR601_sampling) then + begin + use_merged_upsample := FALSE; + exit; + end; + { jdmerge.c only supports YCC=>RGB color conversion } + if (cinfo^.jpeg_color_space <> JCS_YCbCr) or (cinfo^.num_components <> 3) + or (cinfo^.out_color_space <> JCS_RGB) + or (cinfo^.out_color_components <> RGB_PIXELSIZE) then + begin + use_merged_upsample := FALSE; + exit; + end; + + { and it only handles 2h1v or 2h2v sampling ratios } + if (compptr^[0].h_samp_factor <> 2) or + (compptr^[1].h_samp_factor <> 1) or + (compptr^[2].h_samp_factor <> 1) or + (compptr^[0].v_samp_factor > 2) or + (compptr^[1].v_samp_factor <> 1) or + (compptr^[2].v_samp_factor <> 1) then + begin + use_merged_upsample := FALSE; + exit; + end; + { furthermore, it doesn't work if we've scaled the IDCTs differently } + if (compptr^[0].DCT_scaled_size <> cinfo^.min_DCT_scaled_size) or + (compptr^[1].DCT_scaled_size <> cinfo^.min_DCT_scaled_size) or + (compptr^[2].DCT_scaled_size <> cinfo^.min_DCT_scaled_size) then + begin + use_merged_upsample := FALSE; + exit; + end; + { ??? also need to test for upsample-time rescaling, when & if supported } + use_merged_upsample := TRUE; { by golly, it'll work... } +{$else} + use_merged_upsample := FALSE; +{$endif} +end; + + +{ Compute output image dimensions and related values. + NOTE: this is exported for possible use by application. + Hence it mustn't do anything that can't be done twice. + Also note that it may be called before the master module is initialized! } + +{GLOBAL} +procedure jpeg_calc_output_dimensions (cinfo : j_decompress_ptr); +{ Do computations that are needed before master selection phase } +{$ifdef IDCT_SCALING_SUPPORTED} +var + ci : int; + compptr : jpeg_component_info_ptr; +{$endif} +var + ssize : int; +begin + { Prevent application from calling me at wrong times } + if (cinfo^.global_state <> DSTATE_READY) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + +{$ifdef IDCT_SCALING_SUPPORTED} + + { Compute actual output image dimensions and DCT scaling choices. } + if (cinfo^.scale_num * 8 <= cinfo^.scale_denom) then + begin + { Provide 1/8 scaling } + cinfo^.output_width := JDIMENSION ( + jdiv_round_up( long(cinfo^.image_width), long(8)) ); + cinfo^.output_height := JDIMENSION ( + jdiv_round_up( long(cinfo^.image_height), long(8)) ); + cinfo^.min_DCT_scaled_size := 1; + end + else + if (cinfo^.scale_num * 4 <= cinfo^.scale_denom) then + begin + { Provide 1/4 scaling } + cinfo^.output_width := JDIMENSION ( + jdiv_round_up( long (cinfo^.image_width), long(4)) ); + cinfo^.output_height := JDIMENSION ( + jdiv_round_up( long (cinfo^.image_height), long(4)) ); + cinfo^.min_DCT_scaled_size := 2; + end + else + if (cinfo^.scale_num * 2 <= cinfo^.scale_denom) then + begin + { Provide 1/2 scaling } + cinfo^.output_width := JDIMENSION ( + jdiv_round_up( long(cinfo^.image_width), long(2)) ); + cinfo^.output_height := JDIMENSION ( + jdiv_round_up( long(cinfo^.image_height), long(2)) ); + cinfo^.min_DCT_scaled_size := 4; + end + else + begin + { Provide 1/1 scaling } + cinfo^.output_width := cinfo^.image_width; + cinfo^.output_height := cinfo^.image_height; + cinfo^.min_DCT_scaled_size := DCTSIZE; + end; + { In selecting the actual DCT scaling for each component, we try to + scale up the chroma components via IDCT scaling rather than upsampling. + This saves time if the upsampler gets to use 1:1 scaling. + Note this code assumes that the supported DCT scalings are powers of 2. } + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + ssize := cinfo^.min_DCT_scaled_size; + while (ssize < DCTSIZE) and + ((compptr^.h_samp_factor * ssize * 2 <= + cinfo^.max_h_samp_factor * cinfo^.min_DCT_scaled_size) and + (compptr^.v_samp_factor * ssize * 2 <= + cinfo^.max_v_samp_factor * cinfo^.min_DCT_scaled_size)) do + begin + ssize := ssize * 2; + end; + compptr^.DCT_scaled_size := ssize; + Inc(compptr); + end; + + { Recompute downsampled dimensions of components; + application needs to know these if using raw downsampled data. } + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + { Size in samples, after IDCT scaling } + compptr^.downsampled_width := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_width) * + long (compptr^.h_samp_factor * compptr^.DCT_scaled_size), + long (cinfo^.max_h_samp_factor * DCTSIZE)) ); + compptr^.downsampled_height := JDIMENSION ( + jdiv_round_up(long (cinfo^.image_height) * + long (compptr^.v_samp_factor * compptr^.DCT_scaled_size), + long (cinfo^.max_v_samp_factor * DCTSIZE)) ); + Inc(compptr); + end; + +{$else} { !IDCT_SCALING_SUPPORTED } + + { Hardwire it to "no scaling" } + cinfo^.output_width := cinfo^.image_width; + cinfo^.output_height := cinfo^.image_height; + { jdinput.c has already initialized DCT_scaled_size to DCTSIZE, + and has computed unscaled downsampled_width and downsampled_height. } + +{$endif} { IDCT_SCALING_SUPPORTED } + + { Report number of components in selected colorspace. } + { Probably this should be in the color conversion module... } + case (cinfo^.out_color_space) of + JCS_GRAYSCALE: + cinfo^.out_color_components := 1; +{$ifndef RGB_PIXELSIZE_IS_3} + JCS_RGB: + cinfo^.out_color_components := RGB_PIXELSIZE; +{$else} + JCS_RGB, +{$endif} { else share code with YCbCr } + JCS_YCbCr: + cinfo^.out_color_components := 3; + JCS_CMYK, + JCS_YCCK: + cinfo^.out_color_components := 4; + else { else must be same colorspace as in file } + cinfo^.out_color_components := cinfo^.num_components; + end; + if (cinfo^.quantize_colors) then + cinfo^.output_components := 1 + else + cinfo^.output_components := cinfo^.out_color_components; + + { See if upsampler will want to emit more than one row at a time } + if (use_merged_upsample(cinfo)) then + cinfo^.rec_outbuf_height := cinfo^.max_v_samp_factor + else + cinfo^.rec_outbuf_height := 1; +end; + + +{ Several decompression processes need to range-limit values to the range + 0..MAXJSAMPLE; the input value may fall somewhat outside this range + due to noise introduced by quantization, roundoff error, etc. These + processes are inner loops and need to be as fast as possible. On most + machines, particularly CPUs with pipelines or instruction prefetch, + a (subscript-check-less) C table lookup + x := sample_range_limit[x]; + is faster than explicit tests + if (x < 0) x := 0; + else if (x > MAXJSAMPLE) x := MAXJSAMPLE; + These processes all use a common table prepared by the routine below. + + For most steps we can mathematically guarantee that the initial value + of x is within MAXJSAMPLE+1 of the legal range, so a table running from + -(MAXJSAMPLE+1) to 2*MAXJSAMPLE+1 is sufficient. But for the initial + limiting step (just after the IDCT), a wildly out-of-range value is + possible if the input data is corrupt. To avoid any chance of indexing + off the end of memory and getting a bad-pointer trap, we perform the + post-IDCT limiting thus: + x := range_limit[x & MASK]; + where MASK is 2 bits wider than legal sample data, ie 10 bits for 8-bit + samples. Under normal circumstances this is more than enough range and + a correct output will be generated; with bogus input data the mask will + cause wraparound, and we will safely generate a bogus-but-in-range output. + For the post-IDCT step, we want to convert the data from signed to unsigned + representation by adding CENTERJSAMPLE at the same time that we limit it. + So the post-IDCT limiting table ends up looking like this: + CENTERJSAMPLE,CENTERJSAMPLE+1,...,MAXJSAMPLE, + MAXJSAMPLE (repeat 2*(MAXJSAMPLE+1)-CENTERJSAMPLE times), + 0 (repeat 2*(MAXJSAMPLE+1)-CENTERJSAMPLE times), + 0,1,...,CENTERJSAMPLE-1 + Negative inputs select values from the upper half of the table after + masking. + + We can save some space by overlapping the start of the post-IDCT table + with the simpler range limiting table. The post-IDCT table begins at + sample_range_limit + CENTERJSAMPLE. + + Note that the table is allocated in near data space on PCs; it's small + enough and used often enough to justify this. } + +{LOCAL} +procedure prepare_range_limit_table (cinfo : j_decompress_ptr); +{ Allocate and fill in the sample_range_limit table } +var + table : range_limit_table_ptr; + idct_table : JSAMPROW; + i : int; +begin + table := range_limit_table_ptr ( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + (5 * (MAXJSAMPLE+1) + CENTERJSAMPLE) * SIZEOF(JSAMPLE)) ); + + { First segment of "simple" table: limit[x] := 0 for x < 0 } + MEMZERO(table, (MAXJSAMPLE+1) * SIZEOF(JSAMPLE)); + + cinfo^.sample_range_limit := (table); + { allow negative subscripts of simple table } + { is noop, handled via type definition (Nomssi) } + { Main part of "simple" table: limit[x] := x } + for i := 0 to MAXJSAMPLE do + table^[i] := JSAMPLE (i); + idct_table := JSAMPROW(@ table^[CENTERJSAMPLE]); + { Point to where post-IDCT table starts } + { End of simple table, rest of first half of post-IDCT table } + for i := CENTERJSAMPLE to pred(2*(MAXJSAMPLE+1)) do + idct_table^[i] := MAXJSAMPLE; + { Second half of post-IDCT table } + MEMZERO(@(idct_table^[2 * (MAXJSAMPLE+1)]), + (2 * (MAXJSAMPLE+1) - CENTERJSAMPLE) * SIZEOF(JSAMPLE)); + MEMCOPY(@(idct_table^[(4 * (MAXJSAMPLE+1) - CENTERJSAMPLE)]), + @cinfo^.sample_range_limit^[0], CENTERJSAMPLE * SIZEOF(JSAMPLE)); + +end; + + +{ Master selection of decompression modules. + This is done once at jpeg_start_decompress time. We determine + which modules will be used and give them appropriate initialization calls. + We also initialize the decompressor input side to begin consuming data. + + Since jpeg_read_header has finished, we know what is in the SOF + and (first) SOS markers. We also have all the application parameter + settings. } + +{LOCAL} +procedure master_selection (cinfo : j_decompress_ptr); +var + master : my_master_ptr; + use_c_buffer : boolean; + samplesperrow : long; + jd_samplesperrow : JDIMENSION; +var + nscans : int; +begin + master := my_master_ptr (cinfo^.master); + + { Initialize dimensions and other stuff } + jpeg_calc_output_dimensions(cinfo); + prepare_range_limit_table(cinfo); + + { Width of an output scanline must be representable as JDIMENSION. } + samplesperrow := long(cinfo^.output_width) * long (cinfo^.out_color_components); + jd_samplesperrow := JDIMENSION (samplesperrow); + if (long(jd_samplesperrow) <> samplesperrow) then + ERREXIT(j_common_ptr(cinfo), JERR_WIDTH_OVERFLOW); + + { Initialize my private state } + master^.pass_number := 0; + master^.using_merged_upsample := use_merged_upsample(cinfo); + + { Color quantizer selection } + master^.quantizer_1pass := NIL; + master^.quantizer_2pass := NIL; + { No mode changes if not using buffered-image mode. } + if (not cinfo^.quantize_colors) or (not cinfo^.buffered_image) then + begin + cinfo^.enable_1pass_quant := FALSE; + cinfo^.enable_external_quant := FALSE; + cinfo^.enable_2pass_quant := FALSE; + end; + if (cinfo^.quantize_colors) then + begin + if (cinfo^.raw_data_out) then + ERREXIT(j_common_ptr(cinfo), JERR_NOTIMPL); + { 2-pass quantizer only works in 3-component color space. } + if (cinfo^.out_color_components <> 3) then + begin + cinfo^.enable_1pass_quant := TRUE; + cinfo^.enable_external_quant := FALSE; + cinfo^.enable_2pass_quant := FALSE; + cinfo^.colormap := NIL; + end + else + if (cinfo^.colormap <> NIL) then + begin + cinfo^.enable_external_quant := TRUE; + end + else + if (cinfo^.two_pass_quantize) then + begin + cinfo^.enable_2pass_quant := TRUE; + end + else + begin + cinfo^.enable_1pass_quant := TRUE; + end; + + if (cinfo^.enable_1pass_quant) then + begin +{$ifdef QUANT_1PASS_SUPPORTED} + jinit_1pass_quantizer(cinfo); + master^.quantizer_1pass := cinfo^.cquantize; +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} + end; + + { We use the 2-pass code to map to external colormaps. } + if (cinfo^.enable_2pass_quant) or (cinfo^.enable_external_quant) then + begin +{$ifdef QUANT_2PASS_SUPPORTED} + jinit_2pass_quantizer(cinfo); + master^.quantizer_2pass := cinfo^.cquantize; +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} + end; + { If both quantizers are initialized, the 2-pass one is left active; + this is necessary for starting with quantization to an external map. } + end; + + { Post-processing: in particular, color conversion first } + if (not cinfo^.raw_data_out) then + begin + if (master^.using_merged_upsample) then + begin +{$ifdef UPSAMPLE_MERGING_SUPPORTED} + jinit_merged_upsampler(cinfo); { does color conversion too } +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} + end + else + begin + jinit_color_deconverter(cinfo); + jinit_upsampler(cinfo); + end; + jinit_d_post_controller(cinfo, cinfo^.enable_2pass_quant); + end; + { Inverse DCT } + jinit_inverse_dct(cinfo); + { Entropy decoding: either Huffman or arithmetic coding. } + if (cinfo^.arith_code) then + begin + ERREXIT(j_common_ptr(cinfo), JERR_ARITH_NOTIMPL); + end + else + begin + if (cinfo^.progressive_mode) then + begin +{$ifdef D_PROGRESSIVE_SUPPORTED} + jinit_phuff_decoder(cinfo); +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} + end + else + jinit_huff_decoder(cinfo); + end; + + { Initialize principal buffer controllers. } + use_c_buffer := cinfo^.inputctl^.has_multiple_scans or cinfo^.buffered_image; + jinit_d_coef_controller(cinfo, use_c_buffer); + + if (not cinfo^.raw_data_out) then + jinit_d_main_controller(cinfo, FALSE { never need full buffer here }); + + { We can now tell the memory manager to allocate virtual arrays. } + cinfo^.mem^.realize_virt_arrays (j_common_ptr(cinfo)); + + { Initialize input side of decompressor to consume first scan. } + cinfo^.inputctl^.start_input_pass (cinfo); + +{$ifdef D_MULTISCAN_FILES_SUPPORTED} + { If jpeg_start_decompress will read the whole file, initialize + progress monitoring appropriately. The input step is counted + as one pass. } + + if (cinfo^.progress <> NIL) and (not cinfo^.buffered_image) and + (cinfo^.inputctl^.has_multiple_scans) then + begin + + { Estimate number of scans to set pass_limit. } + if (cinfo^.progressive_mode) then + begin + { Arbitrarily estimate 2 interleaved DC scans + 3 AC scans/component. } + nscans := 2 + 3 * cinfo^.num_components; + end + else + begin + { For a nonprogressive multiscan file, estimate 1 scan per component. } + nscans := cinfo^.num_components; + end; + cinfo^.progress^.pass_counter := Long(0); + cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows) * nscans; + cinfo^.progress^.completed_passes := 0; + if cinfo^.enable_2pass_quant then + cinfo^.progress^.total_passes := 3 + else + cinfo^.progress^.total_passes := 2; + { Count the input pass as done } + Inc(master^.pass_number); + end; +{$endif} { D_MULTISCAN_FILES_SUPPORTED } +end; + + +{ Per-pass setup. + This is called at the beginning of each output pass. We determine which + modules will be active during this pass and give them appropriate + start_pass calls. We also set is_dummy_pass to indicate whether this + is a "real" output pass or a dummy pass for color quantization. + (In the latter case, jdapistd.c will crank the pass to completion.) } + +{METHODDEF} +procedure prepare_for_output_pass (cinfo : j_decompress_ptr); +var + master : my_master_ptr; +begin + master := my_master_ptr (cinfo^.master); + + if (master^.pub.is_dummy_pass) then + begin +{$ifdef QUANT_2PASS_SUPPORTED} + { Final pass of 2-pass quantization } + master^.pub.is_dummy_pass := FALSE; + cinfo^.cquantize^.start_pass (cinfo, FALSE); + cinfo^.post^.start_pass (cinfo, JBUF_CRANK_DEST); + cinfo^.main^.start_pass (cinfo, JBUF_CRANK_DEST); +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); +{$endif} { QUANT_2PASS_SUPPORTED } + end + else + begin + if (cinfo^.quantize_colors) and (cinfo^.colormap = NIL) then + begin + { Select new quantization method } + if (cinfo^.two_pass_quantize) and (cinfo^.enable_2pass_quant) then + begin + cinfo^.cquantize := master^.quantizer_2pass; + master^.pub.is_dummy_pass := TRUE; + end + else + if (cinfo^.enable_1pass_quant) then + begin + cinfo^.cquantize := master^.quantizer_1pass; + end + else + begin + ERREXIT(j_common_ptr(cinfo), JERR_MODE_CHANGE); + end; + end; + cinfo^.idct^.start_pass (cinfo); + cinfo^.coef^.start_output_pass (cinfo); + if (not cinfo^.raw_data_out) then + begin + if (not master^.using_merged_upsample) then + cinfo^.cconvert^.start_pass (cinfo); + cinfo^.upsample^.start_pass (cinfo); + if (cinfo^.quantize_colors) then + cinfo^.cquantize^.start_pass (cinfo, master^.pub.is_dummy_pass); + if master^.pub.is_dummy_pass then + cinfo^.post^.start_pass (cinfo, JBUF_SAVE_AND_PASS) + else + cinfo^.post^.start_pass (cinfo, JBUF_PASS_THRU); + cinfo^.main^.start_pass (cinfo, JBUF_PASS_THRU); + end; + end; + + { Set up progress monitor's pass info if present } + if (cinfo^.progress <> NIL) then + begin + cinfo^.progress^.completed_passes := master^.pass_number; + if master^.pub.is_dummy_pass then + cinfo^.progress^.total_passes := master^.pass_number + 2 + else + cinfo^.progress^.total_passes := master^.pass_number + 1; + { In buffered-image mode, we assume one more output pass if EOI not + yet reached, but no more passes if EOI has been reached. } + + if (cinfo^.buffered_image) and (not cinfo^.inputctl^.eoi_reached) then + begin + if cinfo^.enable_2pass_quant then + Inc(cinfo^.progress^.total_passes, 2) + else + Inc(cinfo^.progress^.total_passes, 1); + end; + end; +end; + + +{ Finish up at end of an output pass. } + +{METHODDEF} +procedure finish_output_pass (cinfo : j_decompress_ptr); +var + master : my_master_ptr; +begin + master := my_master_ptr (cinfo^.master); + + if (cinfo^.quantize_colors) then + cinfo^.cquantize^.finish_pass (cinfo); + Inc(master^.pass_number); +end; + + +{$ifdef D_MULTISCAN_FILES_SUPPORTED} + +{ Switch to a new external colormap between output passes. } + +{GLOBAL} +procedure jpeg_new_colormap (cinfo : j_decompress_ptr); +var + master : my_master_ptr; +begin + master := my_master_ptr (cinfo^.master); + + { Prevent application from calling me at wrong times } + if (cinfo^.global_state <> DSTATE_BUFIMAGE) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state); + + if (cinfo^.quantize_colors) and (cinfo^.enable_external_quant) and + (cinfo^.colormap <> NIL) then + begin + { Select 2-pass quantizer for external colormap use } + cinfo^.cquantize := master^.quantizer_2pass; + { Notify quantizer of colormap change } + cinfo^.cquantize^.new_color_map (cinfo); + master^.pub.is_dummy_pass := FALSE; { just in case } + end + else + ERREXIT(j_common_ptr(cinfo), JERR_MODE_CHANGE); +end; + +{$endif} { D_MULTISCAN_FILES_SUPPORTED } + + +{ Initialize master decompression control and select active modules. + This is performed at the start of jpeg_start_decompress. } + +{GLOBAL} +procedure jinit_master_decompress (cinfo : j_decompress_ptr); +var + master : my_master_ptr; +begin + master := my_master_ptr ( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_decomp_master)) ); + cinfo^.master := jpeg_decomp_master_ptr(master); + master^.pub.prepare_for_output_pass := prepare_for_output_pass; + master^.pub.finish_output_pass := finish_output_pass; + + master^.pub.is_dummy_pass := FALSE; + + master_selection(cinfo); +end; + +end. diff --git a/Imaging/JpegLib/imjdmerge.pas b/Imaging/JpegLib/imjdmerge.pas index 3e9c7fb..1b0387e 100644 --- a/Imaging/JpegLib/imjdmerge.pas +++ b/Imaging/JpegLib/imjdmerge.pas @@ -1,514 +1,514 @@ -unit imjdmerge; - -{ This file contains code for merged upsampling/color conversion. - - This file combines functions from jdsample.c and jdcolor.c; - read those files first to understand what's going on. - - When the chroma components are to be upsampled by simple replication - (ie, box filtering), we can save some work in color conversion by - calculating all the output pixels corresponding to a pair of chroma - samples at one time. In the conversion equations - R := Y + K1 * Cr - G := Y + K2 * Cb + K3 * Cr - B := Y + K4 * Cb - only the Y term varies among the group of pixels corresponding to a pair - of chroma samples, so the rest of the terms can be calculated just once. - At typical sampling ratios, this eliminates half or three-quarters of the - multiplications needed for color conversion. - - This file currently provides implementations for the following cases: - YCbCr => RGB color conversion only. - Sampling ratios of 2h1v or 2h2v. - No scaling needed at upsample time. - Corner-aligned (non-CCIR601) sampling alignment. - Other special cases could be added, but in most applications these are - the only common cases. (For uncommon cases we fall back on the more - general code in jdsample.c and jdcolor.c.) } - -{ Original: jdmerge.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib, - imjutils; - -{ Module initialization routine for merged upsampling/color conversion. - - NB: this is called under the conditions determined by use_merged_upsample() - in jdmaster.c. That routine MUST correspond to the actual capabilities - of this module; no safety checks are made here. } - -{GLOBAL} -procedure jinit_merged_upsampler (cinfo : j_decompress_ptr); - -implementation - - -{ Private subobject } - -type { the same definition as in JdColor } - int_Color_Table = array[0..MAXJSAMPLE+1-1] of int; - int_CConvertPtr = ^int_Color_Table; - INT32_Color_Table = array[0..MAXJSAMPLE+1-1] of INT32; - INT32_CConvertPtr = ^INT32_Color_Table; - -type - my_upsample_ptr = ^my_upsampler; - my_upsampler = record - pub : jpeg_upsampler; { public fields } - - { Pointer to routine to do actual upsampling/conversion of one row group } - upmethod : procedure (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - in_row_group_ctr : JDIMENSION; - output_buf : JSAMPARRAY); - - { Private state for YCC->RGB conversion } - Cr_r_tab : int_CConvertPtr; { => table for Cr to R conversion } - Cb_b_tab : int_CConvertPtr; { => table for Cb to B conversion } - Cr_g_tab : INT32_CConvertPtr; { => table for Cr to G conversion } - Cb_g_tab : INT32_CConvertPtr; { => table for Cb to G conversion } - - { For 2:1 vertical sampling, we produce two output rows at a time. - We need a "spare" row buffer to hold the second output row if the - application provides just a one-row buffer; we also use the spare - to discard the dummy last row if the image height is odd. } - - spare_row : JSAMPROW; - spare_full : boolean; { TRUE if spare buffer is occupied } - - out_row_width : JDIMENSION; { samples per output row } - rows_to_go : JDIMENSION; { counts rows remaining in image } - end; {my_upsampler;} - - -const - SCALEBITS = 16; { speediest right-shift on some machines } - ONE_HALF = (INT32(1) shl (SCALEBITS-1)); - - -{ Initialize tables for YCC->RGB colorspace conversion. - This is taken directly from jdcolor.c; see that file for more info. } - -{LOCAL} -procedure build_ycc_rgb_table (cinfo : j_decompress_ptr); -const - FIX_1_40200 = INT32( Round(1.40200 * (INT32(1) shl SCALEBITS)) ); - FIX_1_77200 = INT32( Round(1.77200 * (INT32(1) shl SCALEBITS)) ); - FIX_0_71414 = INT32( Round(0.71414 * (INT32(1) shl SCALEBITS)) ); - FIX_0_34414 = INT32( Round(0.34414 * (INT32(1) shl SCALEBITS)) ); -var - upsample : my_upsample_ptr; - i : int; - x : INT32; -var - shift_temp : INT32; -begin - upsample := my_upsample_ptr (cinfo^.upsample); - - upsample^.Cr_r_tab := int_CConvertPtr ( - cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, - (MAXJSAMPLE+1) * SIZEOF(int)) ); - upsample^.Cb_b_tab := int_CConvertPtr ( - cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, - (MAXJSAMPLE+1) * SIZEOF(int)) ); - upsample^.Cr_g_tab := INT32_CConvertPtr ( - cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, - (MAXJSAMPLE+1) * SIZEOF(INT32)) ); - upsample^.Cb_g_tab := INT32_CConvertPtr ( - cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, - (MAXJSAMPLE+1) * SIZEOF(INT32)) ); - - x := -CENTERJSAMPLE; - for i := 0 to pred(MAXJSAMPLE) do - begin - { i is the actual input pixel value, in the range 0..MAXJSAMPLE } - { The Cb or Cr value we are thinking of is x := i - CENTERJSAMPLE } - { Cr=>R value is nearest int to 1.40200 * x } - {upsample^.Cr_r_tab^[i] := int( - RIGHT_SHIFT(FIX_1_40200 * x + ONE_HALF, SCALEBITS) );} - shift_temp := FIX_1_40200 * x + ONE_HALF; - if shift_temp < 0 then { SHIFT arithmetic RIGHT } - upsample^.Cr_r_tab^[i] := int((shift_temp shr SCALEBITS) - or ( (not INT32(0)) shl (32-SCALEBITS))) - else - upsample^.Cr_r_tab^[i] := int(shift_temp shr SCALEBITS); - - - { Cb=>B value is nearest int to 1.77200 * x } - {upsample^.Cb_b_tab^[i] := int( - RIGHT_SHIFT(FIX_1_77200 * x + ONE_HALF, SCALEBITS) );} - shift_temp := FIX_1_77200 * x + ONE_HALF; - if shift_temp < 0 then { SHIFT arithmetic RIGHT } - upsample^.Cb_b_tab^[i] := int((shift_temp shr SCALEBITS) - or ( (not INT32(0)) shl (32-SCALEBITS))) - else - upsample^.Cb_b_tab^[i] := int(shift_temp shr SCALEBITS); - - { Cr=>G value is scaled-up -0.71414 * x } - upsample^.Cr_g_tab^[i] := (- FIX_0_71414) * x; - { Cb=>G value is scaled-up -0.34414 * x } - { We also add in ONE_HALF so that need not do it in inner loop } - upsample^.Cb_g_tab^[i] := (- FIX_0_34414) * x + ONE_HALF; - Inc(x); - end; -end; - - -{ Initialize for an upsampling pass. } - -{METHODDEF} -procedure start_pass_merged_upsample (cinfo : j_decompress_ptr); -var - upsample : my_upsample_ptr; -begin - upsample := my_upsample_ptr (cinfo^.upsample); - - { Mark the spare buffer empty } - upsample^.spare_full := FALSE; - { Initialize total-height counter for detecting bottom of image } - upsample^.rows_to_go := cinfo^.output_height; -end; - - -{ Control routine to do upsampling (and color conversion). - - The control routine just handles the row buffering considerations. } - -{METHODDEF} -procedure merged_2v_upsample (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); -{ 2:1 vertical sampling case: may need a spare row. } -var - upsample : my_upsample_ptr; - work_ptrs : array[0..2-1] of JSAMPROW; - num_rows : JDIMENSION; { number of rows returned to caller } -begin - upsample := my_upsample_ptr (cinfo^.upsample); - - if (upsample^.spare_full) then - begin - { If we have a spare row saved from a previous cycle, just return it. } - jcopy_sample_rows(JSAMPARRAY(@upsample^.spare_row), - 0, - JSAMPARRAY(@ output_buf^[out_row_ctr]), - 0, 1, upsample^.out_row_width); - num_rows := 1; - upsample^.spare_full := FALSE; - end - else - begin - { Figure number of rows to return to caller. } - num_rows := 2; - { Not more than the distance to the end of the image. } - if (num_rows > upsample^.rows_to_go) then - num_rows := upsample^.rows_to_go; - { And not more than what the client can accept: } - Dec(out_rows_avail, {var} out_row_ctr); - if (num_rows > out_rows_avail) then - num_rows := out_rows_avail; - { Create output pointer array for upsampler. } - work_ptrs[0] := output_buf^[out_row_ctr]; - if (num_rows > 1) then - begin - work_ptrs[1] := output_buf^[out_row_ctr + 1]; - end - else - begin - work_ptrs[1] := upsample^.spare_row; - upsample^.spare_full := TRUE; - end; - { Now do the upsampling. } - upsample^.upmethod (cinfo, input_buf, {var}in_row_group_ctr, - JSAMPARRAY(@work_ptrs)); - end; - - { Adjust counts } - Inc(out_row_ctr, num_rows); - Dec(upsample^.rows_to_go, num_rows); - { When the buffer is emptied, declare this input row group consumed } - if (not upsample^.spare_full) then - Inc(in_row_group_ctr); -end; - - -{METHODDEF} -procedure merged_1v_upsample (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); -{ 1:1 vertical sampling case: much easier, never need a spare row. } -var - upsample : my_upsample_ptr; -begin - upsample := my_upsample_ptr (cinfo^.upsample); - - { Just do the upsampling. } - upsample^.upmethod (cinfo, input_buf, in_row_group_ctr, - JSAMPARRAY(@ output_buf^[out_row_ctr])); - { Adjust counts } - Inc(out_row_ctr); - Inc(in_row_group_ctr); -end; - - -{ These are the routines invoked by the control routines to do - the actual upsampling/conversion. One row group is processed per call. - - Note: since we may be writing directly into application-supplied buffers, - we have to be honest about the output width; we can't assume the buffer - has been rounded up to an even width. } - - -{ Upsample and color convert for the case of 2:1 horizontal and 1:1 vertical. } - -{METHODDEF} -procedure h2v1_merged_upsample (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - in_row_group_ctr : JDIMENSION; - output_buf : JSAMPARRAY); -var - upsample : my_upsample_ptr; - {register} y, cred, cgreen, cblue : int; - cb, cr : int; - {register} outptr : JSAMPROW; - inptr0, inptr1, inptr2 : JSAMPLE_PTR; - col : JDIMENSION; - { copy these pointers into registers if possible } - {register} range_limit : range_limit_table_ptr; - Crrtab : int_CConvertPtr; - Cbbtab : int_CConvertPtr; - Crgtab : INT32_CConvertPtr; - Cbgtab : INT32_CConvertPtr; -var - shift_temp : INT32; -begin - upsample := my_upsample_ptr (cinfo^.upsample); - range_limit := cinfo^.sample_range_limit; - Crrtab := upsample^.Cr_r_tab; - Cbbtab := upsample^.Cb_b_tab; - Crgtab := upsample^.Cr_g_tab; - Cbgtab := upsample^.Cb_g_tab; - - inptr0 := JSAMPLE_PTR(input_buf^[0]^[in_row_group_ctr]); - inptr1 := JSAMPLE_PTR(input_buf^[1]^[in_row_group_ctr]); - inptr2 := JSAMPLE_PTR(input_buf^[2]^[in_row_group_ctr]); - outptr := output_buf^[0]; - { Loop for each pair of output pixels } - for col := pred(cinfo^.output_width shr 1) downto 0 do - begin - { Do the chroma part of the calculation } - cb := GETJSAMPLE(inptr1^); - Inc(inptr1); - cr := GETJSAMPLE(inptr2^); - Inc(inptr2); - cred := Crrtab^[cr]; - {cgreen := int( RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS) );} - shift_temp := Cbgtab^[cb] + Crgtab^[cr]; - if shift_temp < 0 then { SHIFT arithmetic RIGHT } - cgreen := int((shift_temp shr SCALEBITS) - or ( (not INT32(0)) shl (32-SCALEBITS))) - else - cgreen := int(shift_temp shr SCALEBITS); - - cblue := Cbbtab^[cb]; - { Fetch 2 Y values and emit 2 pixels } - y := GETJSAMPLE(inptr0^); - Inc(inptr0); - outptr^[RGB_RED] := range_limit^[y + cred]; - outptr^[RGB_GREEN] := range_limit^[y + cgreen]; - outptr^[RGB_BLUE] := range_limit^[y + cblue]; - Inc(JSAMPLE_PTR(outptr), RGB_PIXELSIZE); - y := GETJSAMPLE(inptr0^); - Inc(inptr0); - outptr^[RGB_RED] := range_limit^[y + cred]; - outptr^[RGB_GREEN] := range_limit^[y + cgreen]; - outptr^[RGB_BLUE] := range_limit^[y + cblue]; - Inc(JSAMPLE_PTR(outptr), RGB_PIXELSIZE); - end; - { If image width is odd, do the last output column separately } - if Odd(cinfo^.output_width) then - begin - cb := GETJSAMPLE(inptr1^); - cr := GETJSAMPLE(inptr2^); - cred := Crrtab^[cr]; - {cgreen := int ( RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS) );} - shift_temp := Cbgtab^[cb] + Crgtab^[cr]; - if shift_temp < 0 then { SHIFT arithmetic RIGHT } - cgreen := int((shift_temp shr SCALEBITS) - or ( (not INT32(0)) shl (32-SCALEBITS))) - else - cgreen := int(shift_temp shr SCALEBITS); - - cblue := Cbbtab^[cb]; - y := GETJSAMPLE(inptr0^); - outptr^[RGB_RED] := range_limit^[y + cred]; - outptr^[RGB_GREEN] := range_limit^[y + cgreen]; - outptr^[RGB_BLUE] := range_limit^[y + cblue]; - end; -end; - - -{ Upsample and color convert for the case of 2:1 horizontal and 2:1 vertical. } - -{METHODDEF} -procedure h2v2_merged_upsample (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - in_row_group_ctr : JDIMENSION; - output_buf : JSAMPARRAY); -var - upsample : my_upsample_ptr; - {register} y, cred, cgreen, cblue : int; - cb, cr : int; - {register} outptr0, outptr1 : JSAMPROW; - inptr00, inptr01, inptr1, inptr2 : JSAMPLE_PTR; - col : JDIMENSION; - { copy these pointers into registers if possible } - {register} range_limit : range_limit_table_ptr; - Crrtab : int_CConvertPtr; - Cbbtab : int_CConvertPtr; - Crgtab : INT32_CConvertPtr; - Cbgtab : INT32_CConvertPtr; -var - shift_temp : INT32; -begin - upsample := my_upsample_ptr (cinfo^.upsample); - range_limit := cinfo^.sample_range_limit; - Crrtab := upsample^.Cr_r_tab; - Cbbtab := upsample^.Cb_b_tab; - Crgtab := upsample^.Cr_g_tab; - Cbgtab := upsample^.Cb_g_tab; - - inptr00 := JSAMPLE_PTR(input_buf^[0]^[in_row_group_ctr*2]); - inptr01 := JSAMPLE_PTR(input_buf^[0]^[in_row_group_ctr*2 + 1]); - inptr1 := JSAMPLE_PTR(input_buf^[1]^[in_row_group_ctr]); - inptr2 := JSAMPLE_PTR(input_buf^[2]^[in_row_group_ctr]); - outptr0 := output_buf^[0]; - outptr1 := output_buf^[1]; - { Loop for each group of output pixels } - for col := pred(cinfo^.output_width shr 1) downto 0 do - begin - { Do the chroma part of the calculation } - cb := GETJSAMPLE(inptr1^); - Inc(inptr1); - cr := GETJSAMPLE(inptr2^); - Inc(inptr2); - cred := Crrtab^[cr]; - {cgreen := int( RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS) );} - shift_temp := Cbgtab^[cb] + Crgtab^[cr]; - if shift_temp < 0 then { SHIFT arithmetic RIGHT } - cgreen := int((shift_temp shr SCALEBITS) - or ( (not INT32(0)) shl (32-SCALEBITS))) - else - cgreen := int(shift_temp shr SCALEBITS); - - cblue := Cbbtab^[cb]; - { Fetch 4 Y values and emit 4 pixels } - y := GETJSAMPLE(inptr00^); - Inc(inptr00); - outptr0^[RGB_RED] := range_limit^[y + cred]; - outptr0^[RGB_GREEN] := range_limit^[y + cgreen]; - outptr0^[RGB_BLUE] := range_limit^[y + cblue]; - Inc(JSAMPLE_PTR(outptr0), RGB_PIXELSIZE); - y := GETJSAMPLE(inptr00^); - Inc(inptr00); - outptr0^[RGB_RED] := range_limit^[y + cred]; - outptr0^[RGB_GREEN] := range_limit^[y + cgreen]; - outptr0^[RGB_BLUE] := range_limit^[y + cblue]; - Inc(JSAMPLE_PTR(outptr0), RGB_PIXELSIZE); - y := GETJSAMPLE(inptr01^); - Inc(inptr01); - outptr1^[RGB_RED] := range_limit^[y + cred]; - outptr1^[RGB_GREEN] := range_limit^[y + cgreen]; - outptr1^[RGB_BLUE] := range_limit^[y + cblue]; - Inc(JSAMPLE_PTR(outptr1), RGB_PIXELSIZE); - y := GETJSAMPLE(inptr01^); - Inc(inptr01); - outptr1^[RGB_RED] := range_limit^[y + cred]; - outptr1^[RGB_GREEN] := range_limit^[y + cgreen]; - outptr1^[RGB_BLUE] := range_limit^[y + cblue]; - Inc(JSAMPLE_PTR(outptr1), RGB_PIXELSIZE); - end; - { If image width is odd, do the last output column separately } - if Odd(cinfo^.output_width) then - begin - cb := GETJSAMPLE(inptr1^); - cr := GETJSAMPLE(inptr2^); - cred := Crrtab^[cr]; - {cgreen := int (RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS));} - shift_temp := Cbgtab^[cb] + Crgtab^[cr]; - if shift_temp < 0 then { SHIFT arithmetic RIGHT } - cgreen := int((shift_temp shr SCALEBITS) - or ( (not INT32(0)) shl (32-SCALEBITS))) - else - cgreen := int(shift_temp shr SCALEBITS); - - cblue := Cbbtab^[cb]; - y := GETJSAMPLE(inptr00^); - outptr0^[RGB_RED] := range_limit^[y + cred]; - outptr0^[RGB_GREEN] := range_limit^[y + cgreen]; - outptr0^[RGB_BLUE] := range_limit^[y + cblue]; - y := GETJSAMPLE(inptr01^); - outptr1^[RGB_RED] := range_limit^[y + cred]; - outptr1^[RGB_GREEN] := range_limit^[y + cgreen]; - outptr1^[RGB_BLUE] := range_limit^[y + cblue]; - end; -end; - - -{ Module initialization routine for merged upsampling/color conversion. - - NB: this is called under the conditions determined by use_merged_upsample() - in jdmaster.c. That routine MUST correspond to the actual capabilities - of this module; no safety checks are made here. } - - -{GLOBAL} -procedure jinit_merged_upsampler (cinfo : j_decompress_ptr); -var - upsample : my_upsample_ptr; -begin - upsample := my_upsample_ptr ( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_upsampler)) ); - cinfo^.upsample := jpeg_upsampler_ptr (upsample); - upsample^.pub.start_pass := start_pass_merged_upsample; - upsample^.pub.need_context_rows := FALSE; - - upsample^.out_row_width := cinfo^.output_width * JDIMENSION(cinfo^.out_color_components); - - if (cinfo^.max_v_samp_factor = 2) then - begin - upsample^.pub.upsample := merged_2v_upsample; - upsample^.upmethod := h2v2_merged_upsample; - { Allocate a spare row buffer } - upsample^.spare_row := JSAMPROW( - cinfo^.mem^.alloc_large ( j_common_ptr(cinfo), JPOOL_IMAGE, - size_t (upsample^.out_row_width * SIZEOF(JSAMPLE))) ); - end - else - begin - upsample^.pub.upsample := merged_1v_upsample; - upsample^.upmethod := h2v1_merged_upsample; - { No spare row needed } - upsample^.spare_row := NIL; - end; - - build_ycc_rgb_table(cinfo); -end; - -end. +unit imjdmerge; + +{ This file contains code for merged upsampling/color conversion. + + This file combines functions from jdsample.c and jdcolor.c; + read those files first to understand what's going on. + + When the chroma components are to be upsampled by simple replication + (ie, box filtering), we can save some work in color conversion by + calculating all the output pixels corresponding to a pair of chroma + samples at one time. In the conversion equations + R := Y + K1 * Cr + G := Y + K2 * Cb + K3 * Cr + B := Y + K4 * Cb + only the Y term varies among the group of pixels corresponding to a pair + of chroma samples, so the rest of the terms can be calculated just once. + At typical sampling ratios, this eliminates half or three-quarters of the + multiplications needed for color conversion. + + This file currently provides implementations for the following cases: + YCbCr => RGB color conversion only. + Sampling ratios of 2h1v or 2h2v. + No scaling needed at upsample time. + Corner-aligned (non-CCIR601) sampling alignment. + Other special cases could be added, but in most applications these are + the only common cases. (For uncommon cases we fall back on the more + general code in jdsample.c and jdcolor.c.) } + +{ Original: jdmerge.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib, + imjutils; + +{ Module initialization routine for merged upsampling/color conversion. + + NB: this is called under the conditions determined by use_merged_upsample() + in jdmaster.c. That routine MUST correspond to the actual capabilities + of this module; no safety checks are made here. } + +{GLOBAL} +procedure jinit_merged_upsampler (cinfo : j_decompress_ptr); + +implementation + + +{ Private subobject } + +type { the same definition as in JdColor } + int_Color_Table = array[0..MAXJSAMPLE+1-1] of int; + int_CConvertPtr = ^int_Color_Table; + INT32_Color_Table = array[0..MAXJSAMPLE+1-1] of INT32; + INT32_CConvertPtr = ^INT32_Color_Table; + +type + my_upsample_ptr = ^my_upsampler; + my_upsampler = record + pub : jpeg_upsampler; { public fields } + + { Pointer to routine to do actual upsampling/conversion of one row group } + upmethod : procedure (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + in_row_group_ctr : JDIMENSION; + output_buf : JSAMPARRAY); + + { Private state for YCC->RGB conversion } + Cr_r_tab : int_CConvertPtr; { => table for Cr to R conversion } + Cb_b_tab : int_CConvertPtr; { => table for Cb to B conversion } + Cr_g_tab : INT32_CConvertPtr; { => table for Cr to G conversion } + Cb_g_tab : INT32_CConvertPtr; { => table for Cb to G conversion } + + { For 2:1 vertical sampling, we produce two output rows at a time. + We need a "spare" row buffer to hold the second output row if the + application provides just a one-row buffer; we also use the spare + to discard the dummy last row if the image height is odd. } + + spare_row : JSAMPROW; + spare_full : boolean; { TRUE if spare buffer is occupied } + + out_row_width : JDIMENSION; { samples per output row } + rows_to_go : JDIMENSION; { counts rows remaining in image } + end; {my_upsampler;} + + +const + SCALEBITS = 16; { speediest right-shift on some machines } + ONE_HALF = (INT32(1) shl (SCALEBITS-1)); + + +{ Initialize tables for YCC->RGB colorspace conversion. + This is taken directly from jdcolor.c; see that file for more info. } + +{LOCAL} +procedure build_ycc_rgb_table (cinfo : j_decompress_ptr); +const + FIX_1_40200 = INT32( Round(1.40200 * (INT32(1) shl SCALEBITS)) ); + FIX_1_77200 = INT32( Round(1.77200 * (INT32(1) shl SCALEBITS)) ); + FIX_0_71414 = INT32( Round(0.71414 * (INT32(1) shl SCALEBITS)) ); + FIX_0_34414 = INT32( Round(0.34414 * (INT32(1) shl SCALEBITS)) ); +var + upsample : my_upsample_ptr; + i : int; + x : INT32; +var + shift_temp : INT32; +begin + upsample := my_upsample_ptr (cinfo^.upsample); + + upsample^.Cr_r_tab := int_CConvertPtr ( + cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, + (MAXJSAMPLE+1) * SIZEOF(int)) ); + upsample^.Cb_b_tab := int_CConvertPtr ( + cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, + (MAXJSAMPLE+1) * SIZEOF(int)) ); + upsample^.Cr_g_tab := INT32_CConvertPtr ( + cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, + (MAXJSAMPLE+1) * SIZEOF(INT32)) ); + upsample^.Cb_g_tab := INT32_CConvertPtr ( + cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, + (MAXJSAMPLE+1) * SIZEOF(INT32)) ); + + x := -CENTERJSAMPLE; + for i := 0 to pred(MAXJSAMPLE) do + begin + { i is the actual input pixel value, in the range 0..MAXJSAMPLE } + { The Cb or Cr value we are thinking of is x := i - CENTERJSAMPLE } + { Cr=>R value is nearest int to 1.40200 * x } + {upsample^.Cr_r_tab^[i] := int( + RIGHT_SHIFT(FIX_1_40200 * x + ONE_HALF, SCALEBITS) );} + shift_temp := FIX_1_40200 * x + ONE_HALF; + if shift_temp < 0 then { SHIFT arithmetic RIGHT } + upsample^.Cr_r_tab^[i] := int((shift_temp shr SCALEBITS) + or ( (not INT32(0)) shl (32-SCALEBITS))) + else + upsample^.Cr_r_tab^[i] := int(shift_temp shr SCALEBITS); + + + { Cb=>B value is nearest int to 1.77200 * x } + {upsample^.Cb_b_tab^[i] := int( + RIGHT_SHIFT(FIX_1_77200 * x + ONE_HALF, SCALEBITS) );} + shift_temp := FIX_1_77200 * x + ONE_HALF; + if shift_temp < 0 then { SHIFT arithmetic RIGHT } + upsample^.Cb_b_tab^[i] := int((shift_temp shr SCALEBITS) + or ( (not INT32(0)) shl (32-SCALEBITS))) + else + upsample^.Cb_b_tab^[i] := int(shift_temp shr SCALEBITS); + + { Cr=>G value is scaled-up -0.71414 * x } + upsample^.Cr_g_tab^[i] := (- FIX_0_71414) * x; + { Cb=>G value is scaled-up -0.34414 * x } + { We also add in ONE_HALF so that need not do it in inner loop } + upsample^.Cb_g_tab^[i] := (- FIX_0_34414) * x + ONE_HALF; + Inc(x); + end; +end; + + +{ Initialize for an upsampling pass. } + +{METHODDEF} +procedure start_pass_merged_upsample (cinfo : j_decompress_ptr); +var + upsample : my_upsample_ptr; +begin + upsample := my_upsample_ptr (cinfo^.upsample); + + { Mark the spare buffer empty } + upsample^.spare_full := FALSE; + { Initialize total-height counter for detecting bottom of image } + upsample^.rows_to_go := cinfo^.output_height; +end; + + +{ Control routine to do upsampling (and color conversion). + + The control routine just handles the row buffering considerations. } + +{METHODDEF} +procedure merged_2v_upsample (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); +{ 2:1 vertical sampling case: may need a spare row. } +var + upsample : my_upsample_ptr; + work_ptrs : array[0..2-1] of JSAMPROW; + num_rows : JDIMENSION; { number of rows returned to caller } +begin + upsample := my_upsample_ptr (cinfo^.upsample); + + if (upsample^.spare_full) then + begin + { If we have a spare row saved from a previous cycle, just return it. } + jcopy_sample_rows(JSAMPARRAY(@upsample^.spare_row), + 0, + JSAMPARRAY(@ output_buf^[out_row_ctr]), + 0, 1, upsample^.out_row_width); + num_rows := 1; + upsample^.spare_full := FALSE; + end + else + begin + { Figure number of rows to return to caller. } + num_rows := 2; + { Not more than the distance to the end of the image. } + if (num_rows > upsample^.rows_to_go) then + num_rows := upsample^.rows_to_go; + { And not more than what the client can accept: } + Dec(out_rows_avail, {var} out_row_ctr); + if (num_rows > out_rows_avail) then + num_rows := out_rows_avail; + { Create output pointer array for upsampler. } + work_ptrs[0] := output_buf^[out_row_ctr]; + if (num_rows > 1) then + begin + work_ptrs[1] := output_buf^[out_row_ctr + 1]; + end + else + begin + work_ptrs[1] := upsample^.spare_row; + upsample^.spare_full := TRUE; + end; + { Now do the upsampling. } + upsample^.upmethod (cinfo, input_buf, {var}in_row_group_ctr, + JSAMPARRAY(@work_ptrs)); + end; + + { Adjust counts } + Inc(out_row_ctr, num_rows); + Dec(upsample^.rows_to_go, num_rows); + { When the buffer is emptied, declare this input row group consumed } + if (not upsample^.spare_full) then + Inc(in_row_group_ctr); +end; + + +{METHODDEF} +procedure merged_1v_upsample (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); +{ 1:1 vertical sampling case: much easier, never need a spare row. } +var + upsample : my_upsample_ptr; +begin + upsample := my_upsample_ptr (cinfo^.upsample); + + { Just do the upsampling. } + upsample^.upmethod (cinfo, input_buf, in_row_group_ctr, + JSAMPARRAY(@ output_buf^[out_row_ctr])); + { Adjust counts } + Inc(out_row_ctr); + Inc(in_row_group_ctr); +end; + + +{ These are the routines invoked by the control routines to do + the actual upsampling/conversion. One row group is processed per call. + + Note: since we may be writing directly into application-supplied buffers, + we have to be honest about the output width; we can't assume the buffer + has been rounded up to an even width. } + + +{ Upsample and color convert for the case of 2:1 horizontal and 1:1 vertical. } + +{METHODDEF} +procedure h2v1_merged_upsample (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + in_row_group_ctr : JDIMENSION; + output_buf : JSAMPARRAY); +var + upsample : my_upsample_ptr; + {register} y, cred, cgreen, cblue : int; + cb, cr : int; + {register} outptr : JSAMPROW; + inptr0, inptr1, inptr2 : JSAMPLE_PTR; + col : JDIMENSION; + { copy these pointers into registers if possible } + {register} range_limit : range_limit_table_ptr; + Crrtab : int_CConvertPtr; + Cbbtab : int_CConvertPtr; + Crgtab : INT32_CConvertPtr; + Cbgtab : INT32_CConvertPtr; +var + shift_temp : INT32; +begin + upsample := my_upsample_ptr (cinfo^.upsample); + range_limit := cinfo^.sample_range_limit; + Crrtab := upsample^.Cr_r_tab; + Cbbtab := upsample^.Cb_b_tab; + Crgtab := upsample^.Cr_g_tab; + Cbgtab := upsample^.Cb_g_tab; + + inptr0 := JSAMPLE_PTR(input_buf^[0]^[in_row_group_ctr]); + inptr1 := JSAMPLE_PTR(input_buf^[1]^[in_row_group_ctr]); + inptr2 := JSAMPLE_PTR(input_buf^[2]^[in_row_group_ctr]); + outptr := output_buf^[0]; + { Loop for each pair of output pixels } + for col := pred(cinfo^.output_width shr 1) downto 0 do + begin + { Do the chroma part of the calculation } + cb := GETJSAMPLE(inptr1^); + Inc(inptr1); + cr := GETJSAMPLE(inptr2^); + Inc(inptr2); + cred := Crrtab^[cr]; + {cgreen := int( RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS) );} + shift_temp := Cbgtab^[cb] + Crgtab^[cr]; + if shift_temp < 0 then { SHIFT arithmetic RIGHT } + cgreen := int((shift_temp shr SCALEBITS) + or ( (not INT32(0)) shl (32-SCALEBITS))) + else + cgreen := int(shift_temp shr SCALEBITS); + + cblue := Cbbtab^[cb]; + { Fetch 2 Y values and emit 2 pixels } + y := GETJSAMPLE(inptr0^); + Inc(inptr0); + outptr^[RGB_RED] := range_limit^[y + cred]; + outptr^[RGB_GREEN] := range_limit^[y + cgreen]; + outptr^[RGB_BLUE] := range_limit^[y + cblue]; + Inc(JSAMPLE_PTR(outptr), RGB_PIXELSIZE); + y := GETJSAMPLE(inptr0^); + Inc(inptr0); + outptr^[RGB_RED] := range_limit^[y + cred]; + outptr^[RGB_GREEN] := range_limit^[y + cgreen]; + outptr^[RGB_BLUE] := range_limit^[y + cblue]; + Inc(JSAMPLE_PTR(outptr), RGB_PIXELSIZE); + end; + { If image width is odd, do the last output column separately } + if Odd(cinfo^.output_width) then + begin + cb := GETJSAMPLE(inptr1^); + cr := GETJSAMPLE(inptr2^); + cred := Crrtab^[cr]; + {cgreen := int ( RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS) );} + shift_temp := Cbgtab^[cb] + Crgtab^[cr]; + if shift_temp < 0 then { SHIFT arithmetic RIGHT } + cgreen := int((shift_temp shr SCALEBITS) + or ( (not INT32(0)) shl (32-SCALEBITS))) + else + cgreen := int(shift_temp shr SCALEBITS); + + cblue := Cbbtab^[cb]; + y := GETJSAMPLE(inptr0^); + outptr^[RGB_RED] := range_limit^[y + cred]; + outptr^[RGB_GREEN] := range_limit^[y + cgreen]; + outptr^[RGB_BLUE] := range_limit^[y + cblue]; + end; +end; + + +{ Upsample and color convert for the case of 2:1 horizontal and 2:1 vertical. } + +{METHODDEF} +procedure h2v2_merged_upsample (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + in_row_group_ctr : JDIMENSION; + output_buf : JSAMPARRAY); +var + upsample : my_upsample_ptr; + {register} y, cred, cgreen, cblue : int; + cb, cr : int; + {register} outptr0, outptr1 : JSAMPROW; + inptr00, inptr01, inptr1, inptr2 : JSAMPLE_PTR; + col : JDIMENSION; + { copy these pointers into registers if possible } + {register} range_limit : range_limit_table_ptr; + Crrtab : int_CConvertPtr; + Cbbtab : int_CConvertPtr; + Crgtab : INT32_CConvertPtr; + Cbgtab : INT32_CConvertPtr; +var + shift_temp : INT32; +begin + upsample := my_upsample_ptr (cinfo^.upsample); + range_limit := cinfo^.sample_range_limit; + Crrtab := upsample^.Cr_r_tab; + Cbbtab := upsample^.Cb_b_tab; + Crgtab := upsample^.Cr_g_tab; + Cbgtab := upsample^.Cb_g_tab; + + inptr00 := JSAMPLE_PTR(input_buf^[0]^[in_row_group_ctr*2]); + inptr01 := JSAMPLE_PTR(input_buf^[0]^[in_row_group_ctr*2 + 1]); + inptr1 := JSAMPLE_PTR(input_buf^[1]^[in_row_group_ctr]); + inptr2 := JSAMPLE_PTR(input_buf^[2]^[in_row_group_ctr]); + outptr0 := output_buf^[0]; + outptr1 := output_buf^[1]; + { Loop for each group of output pixels } + for col := pred(cinfo^.output_width shr 1) downto 0 do + begin + { Do the chroma part of the calculation } + cb := GETJSAMPLE(inptr1^); + Inc(inptr1); + cr := GETJSAMPLE(inptr2^); + Inc(inptr2); + cred := Crrtab^[cr]; + {cgreen := int( RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS) );} + shift_temp := Cbgtab^[cb] + Crgtab^[cr]; + if shift_temp < 0 then { SHIFT arithmetic RIGHT } + cgreen := int((shift_temp shr SCALEBITS) + or ( (not INT32(0)) shl (32-SCALEBITS))) + else + cgreen := int(shift_temp shr SCALEBITS); + + cblue := Cbbtab^[cb]; + { Fetch 4 Y values and emit 4 pixels } + y := GETJSAMPLE(inptr00^); + Inc(inptr00); + outptr0^[RGB_RED] := range_limit^[y + cred]; + outptr0^[RGB_GREEN] := range_limit^[y + cgreen]; + outptr0^[RGB_BLUE] := range_limit^[y + cblue]; + Inc(JSAMPLE_PTR(outptr0), RGB_PIXELSIZE); + y := GETJSAMPLE(inptr00^); + Inc(inptr00); + outptr0^[RGB_RED] := range_limit^[y + cred]; + outptr0^[RGB_GREEN] := range_limit^[y + cgreen]; + outptr0^[RGB_BLUE] := range_limit^[y + cblue]; + Inc(JSAMPLE_PTR(outptr0), RGB_PIXELSIZE); + y := GETJSAMPLE(inptr01^); + Inc(inptr01); + outptr1^[RGB_RED] := range_limit^[y + cred]; + outptr1^[RGB_GREEN] := range_limit^[y + cgreen]; + outptr1^[RGB_BLUE] := range_limit^[y + cblue]; + Inc(JSAMPLE_PTR(outptr1), RGB_PIXELSIZE); + y := GETJSAMPLE(inptr01^); + Inc(inptr01); + outptr1^[RGB_RED] := range_limit^[y + cred]; + outptr1^[RGB_GREEN] := range_limit^[y + cgreen]; + outptr1^[RGB_BLUE] := range_limit^[y + cblue]; + Inc(JSAMPLE_PTR(outptr1), RGB_PIXELSIZE); + end; + { If image width is odd, do the last output column separately } + if Odd(cinfo^.output_width) then + begin + cb := GETJSAMPLE(inptr1^); + cr := GETJSAMPLE(inptr2^); + cred := Crrtab^[cr]; + {cgreen := int (RIGHT_SHIFT(Cbgtab[cb] + Crgtab[cr], SCALEBITS));} + shift_temp := Cbgtab^[cb] + Crgtab^[cr]; + if shift_temp < 0 then { SHIFT arithmetic RIGHT } + cgreen := int((shift_temp shr SCALEBITS) + or ( (not INT32(0)) shl (32-SCALEBITS))) + else + cgreen := int(shift_temp shr SCALEBITS); + + cblue := Cbbtab^[cb]; + y := GETJSAMPLE(inptr00^); + outptr0^[RGB_RED] := range_limit^[y + cred]; + outptr0^[RGB_GREEN] := range_limit^[y + cgreen]; + outptr0^[RGB_BLUE] := range_limit^[y + cblue]; + y := GETJSAMPLE(inptr01^); + outptr1^[RGB_RED] := range_limit^[y + cred]; + outptr1^[RGB_GREEN] := range_limit^[y + cgreen]; + outptr1^[RGB_BLUE] := range_limit^[y + cblue]; + end; +end; + + +{ Module initialization routine for merged upsampling/color conversion. + + NB: this is called under the conditions determined by use_merged_upsample() + in jdmaster.c. That routine MUST correspond to the actual capabilities + of this module; no safety checks are made here. } + + +{GLOBAL} +procedure jinit_merged_upsampler (cinfo : j_decompress_ptr); +var + upsample : my_upsample_ptr; +begin + upsample := my_upsample_ptr ( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_upsampler)) ); + cinfo^.upsample := jpeg_upsampler_ptr (upsample); + upsample^.pub.start_pass := start_pass_merged_upsample; + upsample^.pub.need_context_rows := FALSE; + + upsample^.out_row_width := cinfo^.output_width * JDIMENSION(cinfo^.out_color_components); + + if (cinfo^.max_v_samp_factor = 2) then + begin + upsample^.pub.upsample := merged_2v_upsample; + upsample^.upmethod := h2v2_merged_upsample; + { Allocate a spare row buffer } + upsample^.spare_row := JSAMPROW( + cinfo^.mem^.alloc_large ( j_common_ptr(cinfo), JPOOL_IMAGE, + size_t (upsample^.out_row_width * SIZEOF(JSAMPLE))) ); + end + else + begin + upsample^.pub.upsample := merged_1v_upsample; + upsample^.upmethod := h2v1_merged_upsample; + { No spare row needed } + upsample^.spare_row := NIL; + end; + + build_ycc_rgb_table(cinfo); +end; + +end. diff --git a/Imaging/JpegLib/imjdphuff.pas b/Imaging/JpegLib/imjdphuff.pas index a49bed1..f5cf0df 100644 --- a/Imaging/JpegLib/imjdphuff.pas +++ b/Imaging/JpegLib/imjdphuff.pas @@ -1,1061 +1,1061 @@ -unit imjdphuff; - -{ This file contains Huffman entropy decoding routines for progressive JPEG. - - Much of the complexity here has to do with supporting input suspension. - If the data source module demands suspension, we want to be able to back - up to the start of the current MCU. To do this, we copy state variables - into local working storage, and update them back to the permanent - storage only upon successful completion of an MCU. } - -{ Original: jdphuff.c ; Copyright (C) 1995-1997, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib, - imjdeferr, - imjerror, - imjutils, - imjdhuff; { Declarations shared with jdhuff.c } - - -{GLOBAL} -procedure jinit_phuff_decoder (cinfo : j_decompress_ptr); - -implementation - -{ Expanded entropy decoder object for progressive Huffman decoding. - - The savable_state subrecord contains fields that change within an MCU, - but must not be updated permanently until we complete the MCU. } - -type - savable_state = record - EOBRUN : uInt; { remaining EOBs in EOBRUN } - last_dc_val : array[00..MAX_COMPS_IN_SCAN-1] of int; - { last DC coef for each component } - end; - - -type - phuff_entropy_ptr = ^phuff_entropy_decoder; - phuff_entropy_decoder = record - pub : jpeg_entropy_decoder; { public fields } - - { These fields are loaded into local variables at start of each MCU. - In case of suspension, we exit WITHOUT updating them. } - - bitstate : bitread_perm_state; { Bit buffer at start of MCU } - saved : savable_state; { Other state at start of MCU } - - { These fields are NOT loaded into local working state. } - restarts_to_go : uInt; { MCUs left in this restart interval } - - { Pointers to derived tables (these workspaces have image lifespan) } - derived_tbls : array[0..NUM_HUFF_TBLS-1] of d_derived_tbl_ptr; - - ac_derived_tbl : d_derived_tbl_ptr; { active table during an AC scan } - end; - - - -{ Forward declarations } -{METHODDEF} -function decode_mcu_DC_first (cinfo : j_decompress_ptr; - var MCU_data : array of JBLOCKROW) : boolean; - forward; -{METHODDEF} -function decode_mcu_AC_first (cinfo : j_decompress_ptr; - var MCU_data : array of JBLOCKROW) : boolean; - forward; -{METHODDEF} -function decode_mcu_DC_refine (cinfo : j_decompress_ptr; - var MCU_data : array of JBLOCKROW) : boolean; - forward; -{METHODDEF} -function decode_mcu_AC_refine (cinfo : j_decompress_ptr; - var MCU_data : array of JBLOCKROW) : boolean; - forward; - -{ Initialize for a Huffman-compressed scan. } - -{METHODDEF} -procedure start_pass_phuff_decoder (cinfo : j_decompress_ptr); -var - entropy : phuff_entropy_ptr; - is_DC_band, bad : boolean; - ci, coefi, tbl : int; - coef_bit_ptr : coef_bits_ptr; - compptr : jpeg_component_info_ptr; -var - cindex : int; - expected : int; -begin - entropy := phuff_entropy_ptr (cinfo^.entropy); - - is_DC_band := (cinfo^.Ss = 0); - - { Validate scan parameters } - bad := FALSE; - if (is_DC_band) then - begin - if (cinfo^.Se <> 0) then - bad := TRUE; - end - else - begin - { need not check Ss/Se < 0 since they came from unsigned bytes } - if (cinfo^.Ss > cinfo^.Se) or (cinfo^.Se >= DCTSIZE2) then - bad := TRUE; - { AC scans may have only one component } - if (cinfo^.comps_in_scan <> 1) then - bad := TRUE; - end; - if (cinfo^.Ah <> 0) then - begin - { Successive approximation refinement scan: must have Al = Ah-1. } - if (cinfo^.Al <> cinfo^.Ah-1) then - bad := TRUE; - end; - if (cinfo^.Al > 13) then { need not check for < 0 } - bad := TRUE; - { Arguably the maximum Al value should be less than 13 for 8-bit precision, - but the spec doesn't say so, and we try to be liberal about what we - accept. Note: large Al values could result in out-of-range DC - coefficients during early scans, leading to bizarre displays due to - overflows in the IDCT math. But we won't crash. } - - if (bad) then - ERREXIT4(j_common_ptr(cinfo), JERR_BAD_PROGRESSION, - cinfo^.Ss, cinfo^.Se, cinfo^.Ah, cinfo^.Al); - { Update progression status, and verify that scan order is legal. - Note that inter-scan inconsistencies are treated as warnings - not fatal errors ... not clear if this is right way to behave. } - - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - cindex := cinfo^.cur_comp_info[ci]^.component_index; - coef_bit_ptr := coef_bits_ptr(@(cinfo^.coef_bits^[cindex])); {^[0] ??? - Nomssi } - if (not is_DC_band) and (coef_bit_ptr^[0] < 0) then - { AC without prior DC scan } - WARNMS2(j_common_ptr(cinfo), JWRN_BOGUS_PROGRESSION, cindex, 0); - for coefi := cinfo^.Ss to cinfo^.Se do - begin - if (coef_bit_ptr^[coefi] < 0) then - expected := 0 - else - expected := coef_bit_ptr^[coefi]; - if (cinfo^.Ah <> expected) then - WARNMS2(j_common_ptr(cinfo), JWRN_BOGUS_PROGRESSION, cindex, coefi); - coef_bit_ptr^[coefi] := cinfo^.Al; - end; - end; - - { Select MCU decoding routine } - if (cinfo^.Ah = 0) then - begin - if (is_DC_band) then - entropy^.pub.decode_mcu := decode_mcu_DC_first - else - entropy^.pub.decode_mcu := decode_mcu_AC_first; - end - else - begin - if (is_DC_band) then - entropy^.pub.decode_mcu := decode_mcu_DC_refine - else - entropy^.pub.decode_mcu := decode_mcu_AC_refine; - end; - - for ci := 0 to pred(cinfo^.comps_in_scan) do - begin - compptr := cinfo^.cur_comp_info[ci]; - { Make sure requested tables are present, and compute derived tables. - We may build same derived table more than once, but it's not expensive. } - - if (is_DC_band) then - begin - if (cinfo^.Ah = 0) then - begin { DC refinement needs no table } - tbl := compptr^.dc_tbl_no; - jpeg_make_d_derived_tbl(cinfo, TRUE, tbl, - entropy^.derived_tbls[tbl]); - end; - end - else - begin - tbl := compptr^.ac_tbl_no; - jpeg_make_d_derived_tbl(cinfo, FALSE, tbl, - entropy^.derived_tbls[tbl]); - { remember the single active table } - entropy^.ac_derived_tbl := entropy^.derived_tbls[tbl]; - end; - { Initialize DC predictions to 0 } - entropy^.saved.last_dc_val[ci] := 0; - end; - - { Initialize bitread state variables } - entropy^.bitstate.bits_left := 0; - entropy^.bitstate.get_buffer := 0; { unnecessary, but keeps Purify quiet } - entropy^.pub.insufficient_data := FALSE; - - { Initialize private state variables } - entropy^.saved.EOBRUN := 0; - - { Initialize restart counter } - entropy^.restarts_to_go := cinfo^.restart_interval; -end; - - -{ Figure F.12: extend sign bit. - On some machines, a shift and add will be faster than a table lookup. } - -{$ifdef AVOID_TABLES} - -#define HUFF_EXTEND(x,s) - ((x) < (1shl((s)-1)) ? (x) + (((-1)shl(s)) + 1) : (x)) - -{$else} - -{ #define HUFF_EXTEND(x,s) - if (x) < extend_test[s] then - (x) + extend_offset[s] - else - (x)} - -const - extend_test : Array[0..16-1] of int = { entry n is 2**(n-1) } - ($0000, $0001, $0002, $0004, $0008, $0010, $0020, $0040, - $0080, $0100, $0200, $0400, $0800, $1000, $2000, $4000); - -const - extend_offset : array[0..16-1] of int = { entry n is (-1 shl n) + 1 } - ( 0, ((-1) shl 1) + 1, ((-1) shl 2) + 1, ((-1) shl 3) + 1, ((-1) shl 4) + 1, - ((-1) shl 5) + 1, ((-1) shl 6) + 1, ((-1) shl 7) + 1, ((-1) shl 8) + 1, - ((-1) shl 9) + 1, ((-1) shl 10) + 1, ((-1) shl 11) + 1, ((-1) shl 12) + 1, - ((-1) shl 13) + 1, ((-1) shl 14) + 1, ((-1) shl 15) + 1 ); - -{$endif} { AVOID_TABLES } - - -{ Check for a restart marker & resynchronize decoder. - return:=s FALSE if must suspend. } - -{LOCAL} -function process_restart (cinfo : j_decompress_ptr) : boolean; -var - entropy : phuff_entropy_ptr; - ci : int; -begin - entropy := phuff_entropy_ptr (cinfo^.entropy); - - { Throw away any unused bits remaining in bit buffer; } - { include any full bytes in next_marker's count of discarded bytes } - Inc(cinfo^.marker^.discarded_bytes, entropy^.bitstate.bits_left div 8); - entropy^.bitstate.bits_left := 0; - - { Advance past the RSTn marker } - if (not cinfo^.marker^.read_restart_marker (cinfo)) then - begin - process_restart := FALSE; - exit; - end; - - { Re-initialize DC predictions to 0 } - for ci := 0 to pred(cinfo^.comps_in_scan) do - entropy^.saved.last_dc_val[ci] := 0; - { Re-init EOB run count, too } - entropy^.saved.EOBRUN := 0; - - { Reset restart counter } - entropy^.restarts_to_go := cinfo^.restart_interval; - - { Reset out-of-data flag, unless read_restart_marker left us smack up - against a marker. In that case we will end up treating the next data - segment as empty, and we can avoid producing bogus output pixels by - leaving the flag set. } - if (cinfo^.unread_marker = 0) then - entropy^.pub.insufficient_data := FALSE; - - process_restart := TRUE; -end; - - -{ Huffman MCU decoding. - Each of these routines decodes and returns one MCU's worth of - Huffman-compressed coefficients. - The coefficients are reordered from zigzag order into natural array order, - but are not dequantized. - - The i'th block of the MCU is stored into the block pointed to by - MCU_data[i]. WE ASSUME THIS AREA IS INITIALLY ZEROED BY THE CALLER. - - We return FALSE if data source requested suspension. In that case no - changes have been made to permanent state. (Exception: some output - coefficients may already have been assigned. This is harmless for - spectral selection, since we'll just re-assign them on the next call. - Successive approximation AC refinement has to be more careful, however.) } - - -{ MCU decoding for DC initial scan (either spectral selection, - or first pass of successive approximation). } - -{METHODDEF} -function decode_mcu_DC_first (cinfo : j_decompress_ptr; - var MCU_data : array of JBLOCKROW) : boolean; -label - label1; -var - entropy : phuff_entropy_ptr; - Al : int; - {register} s, r : int; - blkn, ci : int; - block : JBLOCK_PTR; - {BITREAD_STATE_VARS;} - get_buffer : bit_buf_type ; {register} - bits_left : int; {register} - br_state : bitread_working_state; - - state : savable_state; - tbl : d_derived_tbl_ptr; - compptr : jpeg_component_info_ptr; -var - nb, look : int; {register} -begin - entropy := phuff_entropy_ptr (cinfo^.entropy); - Al := cinfo^.Al; - - { Process restart marker if needed; may have to suspend } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - if (not process_restart(cinfo)) then - begin - decode_mcu_DC_first := FALSE; - exit; - end; - end; - - { If we've run out of data, just leave the MCU set to zeroes. - This way, we return uniform gray for the remainder of the segment. } - - if not entropy^.pub.insufficient_data then - begin - - { Load up working state } - {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);} - br_state.cinfo := cinfo; - br_state.next_input_byte := cinfo^.src^.next_input_byte; - br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer; - get_buffer := entropy^.bitstate.get_buffer; - bits_left := entropy^.bitstate.bits_left; - - {ASSIGN_STATE(state, entropy^.saved);} - state := entropy^.saved; - - { Outer loop handles each block in the MCU } - - for blkn := 0 to pred(cinfo^.blocks_in_MCU) do - begin - block := JBLOCK_PTR(MCU_data[blkn]); - ci := cinfo^.MCU_membership[blkn]; - compptr := cinfo^.cur_comp_info[ci]; - tbl := entropy^.derived_tbls[compptr^.dc_tbl_no]; - - { Decode a single block's worth of coefficients } - - { Section F.2.2.1: decode the DC coefficient difference } - {HUFF_DECODE(s, br_state, tbl, return FALSE, label1);} - if (bits_left < HUFF_LOOKAHEAD) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then - begin - decode_mcu_DC_first := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - if (bits_left < HUFF_LOOKAHEAD) then - begin - nb := 1; - goto label1; - end; - end; - {look := PEEK_BITS(HUFF_LOOKAHEAD);} - look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and - pred(1 shl HUFF_LOOKAHEAD); - - nb := tbl^.look_nbits[look]; - if (nb <> 0) then - begin - {DROP_BITS(nb);} - Dec(bits_left, nb); - - s := tbl^.look_sym[look]; - end - else - begin - nb := HUFF_LOOKAHEAD+1; - label1: - s := jpeg_huff_decode(br_state,get_buffer,bits_left,tbl,nb); - if (s < 0) then - begin - decode_mcu_DC_first := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - if (s <> 0) then - begin - {CHECK_BIT_BUFFER(br_state, s, return FALSE);} - if (bits_left < s) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then - begin - decode_mcu_DC_first := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {r := GET_BITS(s);} - Dec(bits_left, s); - r := (int(get_buffer shr bits_left)) and ( pred(1 shl s) ); - - {s := HUFF_EXTEND(r, s);} - if (r < extend_test[s]) then - s := r + extend_offset[s] - else - s := r; - end; - - { Convert DC difference to actual value, update last_dc_val } - Inc(s, state.last_dc_val[ci]); - state.last_dc_val[ci] := s; - { Scale and output the DC coefficient (assumes jpeg_natural_order[0]=0) } - block^[0] := JCOEF (s shl Al); - end; - - { Completed MCU, so update state } - {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);} - cinfo^.src^.next_input_byte := br_state.next_input_byte; - cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer; - entropy^.bitstate.get_buffer := get_buffer; - entropy^.bitstate.bits_left := bits_left; - - {ASSIGN_STATE(entropy^.saved, state);} - entropy^.saved := state; - end; - - { Account for restart interval (no-op if not using restarts) } - Dec(entropy^.restarts_to_go); - - decode_mcu_DC_first := TRUE; -end; - - -{ MCU decoding for AC initial scan (either spectral selection, - or first pass of successive approximation). } - -{METHODDEF} -function decode_mcu_AC_first (cinfo : j_decompress_ptr; - var MCU_data : array of JBLOCKROW) : boolean; -label - label2; -var - entropy : phuff_entropy_ptr; - Se : int; - Al : int; - {register} s, k, r : int; - EOBRUN : uInt; - block : JBLOCK_PTR; - {BITREAD_STATE_VARS;} - get_buffer : bit_buf_type ; {register} - bits_left : int; {register} - br_state : bitread_working_state; - - tbl : d_derived_tbl_ptr; -var - nb, look : int; {register} -begin - entropy := phuff_entropy_ptr (cinfo^.entropy); - Se := cinfo^.Se; - Al := cinfo^.Al; - - { Process restart marker if needed; may have to suspend } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - if (not process_restart(cinfo)) then - begin - decode_mcu_AC_first := FALSE; - exit; - end; - end; - - { If we've run out of data, just leave the MCU set to zeroes. - This way, we return uniform gray for the remainder of the segment. } - if not entropy^.pub.insufficient_data then - begin - - { Load up working state. - We can avoid loading/saving bitread state if in an EOB run. } - - EOBRUN := entropy^.saved.EOBRUN; { only part of saved state we care about } - - { There is always only one block per MCU } - - if (EOBRUN > 0) then { if it's a band of zeroes... } - Dec(EOBRUN) { ...process it now (we do nothing) } - else - begin - {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);} - br_state.cinfo := cinfo; - br_state.next_input_byte := cinfo^.src^.next_input_byte; - br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer; - get_buffer := entropy^.bitstate.get_buffer; - bits_left := entropy^.bitstate.bits_left; - - block := JBLOCK_PTR(MCU_data[0]); - tbl := entropy^.ac_derived_tbl; - - k := cinfo^.Ss; - while (k <= Se) do - begin - {HUFF_DECODE(s, br_state, tbl, return FALSE, label2);} - if (bits_left < HUFF_LOOKAHEAD) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then - begin - decode_mcu_AC_first := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - if (bits_left < HUFF_LOOKAHEAD) then - begin - nb := 1; - goto label2; - end; - end; - {look := PEEK_BITS(HUFF_LOOKAHEAD);} - look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and - pred(1 shl HUFF_LOOKAHEAD); - - nb := tbl^.look_nbits[look]; - if (nb <> 0) then - begin - {DROP_BITS(nb);} - Dec(bits_left, nb); - - s := tbl^.look_sym[look]; - end - else - begin - nb := HUFF_LOOKAHEAD+1; - label2: - s := jpeg_huff_decode(br_state,get_buffer,bits_left,tbl,nb); - if (s < 0) then - begin - decode_mcu_AC_first := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - r := s shr 4; - s := s and 15; - if (s <> 0) then - begin - Inc(k, r); - {CHECK_BIT_BUFFER(br_state, s, return FALSE);} - if (bits_left < s) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then - begin - decode_mcu_AC_first := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {r := GET_BITS(s);} - Dec(bits_left, s); - r := (int(get_buffer shr bits_left)) and ( pred(1 shl s) ); - - {s := HUFF_EXTEND(r, s);} - if (r < extend_test[s]) then - s := r + extend_offset[s] - else - s := r; - - { Scale and output coefficient in natural (dezigzagged) order } - block^[jpeg_natural_order[k]] := JCOEF (s shl Al); - end - else - begin - if (r = 15) then - begin { ZRL } - Inc(k, 15); { skip 15 zeroes in band } - end - else - begin { EOBr, run length is 2^r + appended bits } - EOBRUN := 1 shl r; - if (r <> 0) then - begin { EOBr, r > 0 } - {CHECK_BIT_BUFFER(br_state, r, return FALSE);} - if (bits_left < r) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,r)) then - begin - decode_mcu_AC_first := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {r := GET_BITS(r);} - Dec(bits_left, r); - r := (int(get_buffer shr bits_left)) and ( pred(1 shl r) ); - - Inc(EOBRUN, r); - end; - Dec(EOBRUN); { this band is processed at this moment } - break; { force end-of-band } - end; - end; - Inc(k); - end; - - {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);} - cinfo^.src^.next_input_byte := br_state.next_input_byte; - cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer; - entropy^.bitstate.get_buffer := get_buffer; - entropy^.bitstate.bits_left := bits_left; - end; - - { Completed MCU, so update state } - entropy^.saved.EOBRUN := EOBRUN; { only part of saved state we care about } - end; - - { Account for restart interval (no-op if not using restarts) } - Dec(entropy^.restarts_to_go); - - decode_mcu_AC_first := TRUE; -end; - - -{ MCU decoding for DC successive approximation refinement scan. - Note: we assume such scans can be multi-component, although the spec - is not very clear on the point. } - -{METHODDEF} -function decode_mcu_DC_refine (cinfo : j_decompress_ptr; - var MCU_data : array of JBLOCKROW) : boolean; - -var - entropy : phuff_entropy_ptr; - p1 : int; { 1 in the bit position being coded } - blkn : int; - block : JBLOCK_PTR; - {BITREAD_STATE_VARS;} - get_buffer : bit_buf_type ; {register} - bits_left : int; {register} - br_state : bitread_working_state; -begin - entropy := phuff_entropy_ptr (cinfo^.entropy); - p1 := 1 shl cinfo^.Al; - - { Process restart marker if needed; may have to suspend } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - if (not process_restart(cinfo)) then - begin - decode_mcu_DC_refine := FALSE; - exit; - end; - end; - - { Not worth the cycles to check insufficient_data here, - since we will not change the data anyway if we read zeroes. } - - { Load up working state } - {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);} - br_state.cinfo := cinfo; - br_state.next_input_byte := cinfo^.src^.next_input_byte; - br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer; - get_buffer := entropy^.bitstate.get_buffer; - bits_left := entropy^.bitstate.bits_left; - - { Outer loop handles each block in the MCU } - - for blkn := 0 to pred(cinfo^.blocks_in_MCU) do - begin - block := JBLOCK_PTR(MCU_data[blkn]); - - { Encoded data is simply the next bit of the two's-complement DC value } - {CHECK_BIT_BUFFER(br_state, 1, return FALSE);} - if (bits_left < 1) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then - begin - decode_mcu_DC_refine := FALSE; - exit; - end; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {if (GET_BITS(1)) then} - Dec(bits_left); - if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) ) <> 0 then - block^[0] := block^[0] or p1; - { Note: since we use OR, repeating the assignment later is safe } - end; - - { Completed MCU, so update state } - {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);} - cinfo^.src^.next_input_byte := br_state.next_input_byte; - cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer; - entropy^.bitstate.get_buffer := get_buffer; - entropy^.bitstate.bits_left := bits_left; - - { Account for restart interval (no-op if not using restarts) } - Dec(entropy^.restarts_to_go); - - decode_mcu_DC_refine := TRUE; -end; - - -{ MCU decoding for AC successive approximation refinement scan. } - -{METHODDEF} -function decode_mcu_AC_refine (cinfo : j_decompress_ptr; - var MCU_data : array of JBLOCKROW) : boolean; -label - undoit, label3; -var - entropy : phuff_entropy_ptr; - Se : int; - p1 : int; { 1 in the bit position being coded } - m1 : int; { -1 in the bit position being coded } - {register} s, k, r : int; - EOBRUN : uInt; - block : JBLOCK_PTR; - thiscoef : JCOEF_PTR; - {BITREAD_STATE_VARS;} - get_buffer : bit_buf_type ; {register} - bits_left : int; {register} - br_state : bitread_working_state; - - tbl : d_derived_tbl_ptr; - num_newnz : int; - newnz_pos : array[0..DCTSIZE2-1] of int; -var - pos : int; -var - nb, look : int; {register} -begin - num_newnz := 0; - block := nil; - - entropy := phuff_entropy_ptr (cinfo^.entropy); - Se := cinfo^.Se; - p1 := 1 shl cinfo^.Al; { 1 in the bit position being coded } - m1 := (-1) shl cinfo^.Al; { -1 in the bit position being coded } - - { Process restart marker if needed; may have to suspend } - if (cinfo^.restart_interval <> 0) then - begin - if (entropy^.restarts_to_go = 0) then - if (not process_restart(cinfo)) then - begin - decode_mcu_AC_refine := FALSE; - exit; - end; - end; - - { If we've run out of data, don't modify the MCU. } - if not entropy^.pub.insufficient_data then - begin - - { Load up working state } - {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);} - br_state.cinfo := cinfo; - br_state.next_input_byte := cinfo^.src^.next_input_byte; - br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer; - get_buffer := entropy^.bitstate.get_buffer; - bits_left := entropy^.bitstate.bits_left; - - EOBRUN := entropy^.saved.EOBRUN; { only part of saved state we care about } - - { There is always only one block per MCU } - block := JBLOCK_PTR(MCU_data[0]); - tbl := entropy^.ac_derived_tbl; - - { If we are forced to suspend, we must undo the assignments to any newly - nonzero coefficients in the block, because otherwise we'd get confused - next time about which coefficients were already nonzero. - But we need not undo addition of bits to already-nonzero coefficients; - instead, we can test the current bit position to see if we already did it.} - - num_newnz := 0; - - { initialize coefficient loop counter to start of band } - k := cinfo^.Ss; - - if (EOBRUN = 0) then - begin - while (k <= Se) do - begin - {HUFF_DECODE(s, br_state, tbl, goto undoit, label3);} - if (bits_left < HUFF_LOOKAHEAD) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then - goto undoit; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - if (bits_left < HUFF_LOOKAHEAD) then - begin - nb := 1; - goto label3; - end; - end; - {look := PEEK_BITS(HUFF_LOOKAHEAD);} - look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and - pred(1 shl HUFF_LOOKAHEAD); - - nb := tbl^.look_nbits[look]; - if (nb <> 0) then - begin - {DROP_BITS(nb);} - Dec(bits_left, nb); - - s := tbl^.look_sym[look]; - end - else - begin - nb := HUFF_LOOKAHEAD+1; - label3: - s := jpeg_huff_decode(br_state,get_buffer,bits_left,tbl,nb); - if (s < 0) then - goto undoit; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - r := s shr 4; - s := s and 15; - if (s <> 0) then - begin - if (s <> 1) then { size of new coef should always be 1 } - WARNMS(j_common_ptr(cinfo), JWRN_HUFF_BAD_CODE); - {CHECK_BIT_BUFFER(br_state, 1, goto undoit);} - if (bits_left < 1) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then - goto undoit; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {if (GET_BITS(1)) then} - Dec(bits_left); - if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) )<>0 then - s := p1 { newly nonzero coef is positive } - else - s := m1; { newly nonzero coef is negative } - end - else - begin - if (r <> 15) then - begin - EOBRUN := 1 shl r; { EOBr, run length is 2^r + appended bits } - if (r <> 0) then - begin - {CHECK_BIT_BUFFER(br_state, r, goto undoit);} - if (bits_left < r) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,r)) then - goto undoit; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {r := GET_BITS(r);} - Dec(bits_left, r); - r := (int(get_buffer shr bits_left)) and ( pred(1 shl r) ); - - Inc(EOBRUN, r); - end; - break; { rest of block is handled by EOB logic } - end; - { note s := 0 for processing ZRL } - end; - { Advance over already-nonzero coefs and r still-zero coefs, - appending correction bits to the nonzeroes. A correction bit is 1 - if the absolute value of the coefficient must be increased. } - - repeat - thiscoef :=@(block^[jpeg_natural_order[k]]); - if (thiscoef^ <> 0) then - begin - {CHECK_BIT_BUFFER(br_state, 1, goto undoit);} - if (bits_left < 1) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then - goto undoit; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {if (GET_BITS(1)) then} - Dec(bits_left); - if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) )<>0 then - begin - if ((thiscoef^ and p1) = 0) then - begin { do nothing if already set it } - if (thiscoef^ >= 0) then - Inc(thiscoef^, p1) - else - Inc(thiscoef^, m1); - end; - end; - end - else - begin - Dec(r); - if (r < 0) then - break; { reached target zero coefficient } - end; - Inc(k); - until (k > Se); - if (s <> 0) then - begin - pos := jpeg_natural_order[k]; - { Output newly nonzero coefficient } - block^[pos] := JCOEF (s); - { Remember its position in case we have to suspend } - newnz_pos[num_newnz] := pos; - Inc(num_newnz); - end; - Inc(k); - end; - end; - - if (EOBRUN > 0) then - begin - { Scan any remaining coefficient positions after the end-of-band - (the last newly nonzero coefficient, if any). Append a correction - bit to each already-nonzero coefficient. A correction bit is 1 - if the absolute value of the coefficient must be increased. } - - while (k <= Se) do - begin - thiscoef := @(block^[jpeg_natural_order[k]]); - if (thiscoef^ <> 0) then - begin - {CHECK_BIT_BUFFER(br_state, 1, goto undoit);} - if (bits_left < 1) then - begin - if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then - goto undoit; - get_buffer := br_state.get_buffer; - bits_left := br_state.bits_left; - end; - - {if (GET_BITS(1)) then} - Dec(bits_left); - if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) )<>0 then - begin - if ((thiscoef^ and p1) = 0) then - begin { do nothing if already changed it } - if (thiscoef^ >= 0) then - Inc(thiscoef^, p1) - else - Inc(thiscoef^, m1); - end; - end; - end; - Inc(k); - end; - { Count one block completed in EOB run } - Dec(EOBRUN); - end; - - { Completed MCU, so update state } - {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);} - cinfo^.src^.next_input_byte := br_state.next_input_byte; - cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer; - entropy^.bitstate.get_buffer := get_buffer; - entropy^.bitstate.bits_left := bits_left; - - entropy^.saved.EOBRUN := EOBRUN; { only part of saved state we care about } - end; - - { Account for restart interval (no-op if not using restarts) } - Dec(entropy^.restarts_to_go); - - decode_mcu_AC_refine := TRUE; - exit; - -undoit: - { Re-zero any output coefficients that we made newly nonzero } - while (num_newnz > 0) do - begin - Dec(num_newnz); - block^[newnz_pos[num_newnz]] := 0; - end; - - decode_mcu_AC_refine := FALSE; -end; - - -{ Module initialization routine for progressive Huffman entropy decoding. } - -{GLOBAL} -procedure jinit_phuff_decoder (cinfo : j_decompress_ptr); -var - entropy : phuff_entropy_ptr; - coef_bit_ptr : int_ptr; - ci, i : int; -begin - entropy := phuff_entropy_ptr( - cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, - SIZEOF(phuff_entropy_decoder)) ); - cinfo^.entropy := jpeg_entropy_decoder_ptr (entropy); - entropy^.pub.start_pass := start_pass_phuff_decoder; - - { Mark derived tables unallocated } - for i := 0 to pred(NUM_HUFF_TBLS) do - begin - entropy^.derived_tbls[i] := NIL; - end; - - { Create progression status table } - cinfo^.coef_bits := coef_bits_ptrrow ( - cinfo^.mem^.alloc_small ( j_common_ptr (cinfo), JPOOL_IMAGE, - cinfo^.num_components*DCTSIZE2*SIZEOF(int)) ); - coef_bit_ptr := @cinfo^.coef_bits^[0][0]; - for ci := 0 to pred(cinfo^.num_components) do - for i := 0 to pred(DCTSIZE2) do - begin - coef_bit_ptr^ := -1; - Inc(coef_bit_ptr); - end; -end; - -end. +unit imjdphuff; + +{ This file contains Huffman entropy decoding routines for progressive JPEG. + + Much of the complexity here has to do with supporting input suspension. + If the data source module demands suspension, we want to be able to back + up to the start of the current MCU. To do this, we copy state variables + into local working storage, and update them back to the permanent + storage only upon successful completion of an MCU. } + +{ Original: jdphuff.c ; Copyright (C) 1995-1997, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib, + imjdeferr, + imjerror, + imjutils, + imjdhuff; { Declarations shared with jdhuff.c } + + +{GLOBAL} +procedure jinit_phuff_decoder (cinfo : j_decompress_ptr); + +implementation + +{ Expanded entropy decoder object for progressive Huffman decoding. + + The savable_state subrecord contains fields that change within an MCU, + but must not be updated permanently until we complete the MCU. } + +type + savable_state = record + EOBRUN : uInt; { remaining EOBs in EOBRUN } + last_dc_val : array[00..MAX_COMPS_IN_SCAN-1] of int; + { last DC coef for each component } + end; + + +type + phuff_entropy_ptr = ^phuff_entropy_decoder; + phuff_entropy_decoder = record + pub : jpeg_entropy_decoder; { public fields } + + { These fields are loaded into local variables at start of each MCU. + In case of suspension, we exit WITHOUT updating them. } + + bitstate : bitread_perm_state; { Bit buffer at start of MCU } + saved : savable_state; { Other state at start of MCU } + + { These fields are NOT loaded into local working state. } + restarts_to_go : uInt; { MCUs left in this restart interval } + + { Pointers to derived tables (these workspaces have image lifespan) } + derived_tbls : array[0..NUM_HUFF_TBLS-1] of d_derived_tbl_ptr; + + ac_derived_tbl : d_derived_tbl_ptr; { active table during an AC scan } + end; + + + +{ Forward declarations } +{METHODDEF} +function decode_mcu_DC_first (cinfo : j_decompress_ptr; + var MCU_data : array of JBLOCKROW) : boolean; + forward; +{METHODDEF} +function decode_mcu_AC_first (cinfo : j_decompress_ptr; + var MCU_data : array of JBLOCKROW) : boolean; + forward; +{METHODDEF} +function decode_mcu_DC_refine (cinfo : j_decompress_ptr; + var MCU_data : array of JBLOCKROW) : boolean; + forward; +{METHODDEF} +function decode_mcu_AC_refine (cinfo : j_decompress_ptr; + var MCU_data : array of JBLOCKROW) : boolean; + forward; + +{ Initialize for a Huffman-compressed scan. } + +{METHODDEF} +procedure start_pass_phuff_decoder (cinfo : j_decompress_ptr); +var + entropy : phuff_entropy_ptr; + is_DC_band, bad : boolean; + ci, coefi, tbl : int; + coef_bit_ptr : coef_bits_ptr; + compptr : jpeg_component_info_ptr; +var + cindex : int; + expected : int; +begin + entropy := phuff_entropy_ptr (cinfo^.entropy); + + is_DC_band := (cinfo^.Ss = 0); + + { Validate scan parameters } + bad := FALSE; + if (is_DC_band) then + begin + if (cinfo^.Se <> 0) then + bad := TRUE; + end + else + begin + { need not check Ss/Se < 0 since they came from unsigned bytes } + if (cinfo^.Ss > cinfo^.Se) or (cinfo^.Se >= DCTSIZE2) then + bad := TRUE; + { AC scans may have only one component } + if (cinfo^.comps_in_scan <> 1) then + bad := TRUE; + end; + if (cinfo^.Ah <> 0) then + begin + { Successive approximation refinement scan: must have Al = Ah-1. } + if (cinfo^.Al <> cinfo^.Ah-1) then + bad := TRUE; + end; + if (cinfo^.Al > 13) then { need not check for < 0 } + bad := TRUE; + { Arguably the maximum Al value should be less than 13 for 8-bit precision, + but the spec doesn't say so, and we try to be liberal about what we + accept. Note: large Al values could result in out-of-range DC + coefficients during early scans, leading to bizarre displays due to + overflows in the IDCT math. But we won't crash. } + + if (bad) then + ERREXIT4(j_common_ptr(cinfo), JERR_BAD_PROGRESSION, + cinfo^.Ss, cinfo^.Se, cinfo^.Ah, cinfo^.Al); + { Update progression status, and verify that scan order is legal. + Note that inter-scan inconsistencies are treated as warnings + not fatal errors ... not clear if this is right way to behave. } + + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + cindex := cinfo^.cur_comp_info[ci]^.component_index; + coef_bit_ptr := coef_bits_ptr(@(cinfo^.coef_bits^[cindex])); {^[0] ??? + Nomssi } + if (not is_DC_band) and (coef_bit_ptr^[0] < 0) then + { AC without prior DC scan } + WARNMS2(j_common_ptr(cinfo), JWRN_BOGUS_PROGRESSION, cindex, 0); + for coefi := cinfo^.Ss to cinfo^.Se do + begin + if (coef_bit_ptr^[coefi] < 0) then + expected := 0 + else + expected := coef_bit_ptr^[coefi]; + if (cinfo^.Ah <> expected) then + WARNMS2(j_common_ptr(cinfo), JWRN_BOGUS_PROGRESSION, cindex, coefi); + coef_bit_ptr^[coefi] := cinfo^.Al; + end; + end; + + { Select MCU decoding routine } + if (cinfo^.Ah = 0) then + begin + if (is_DC_band) then + entropy^.pub.decode_mcu := decode_mcu_DC_first + else + entropy^.pub.decode_mcu := decode_mcu_AC_first; + end + else + begin + if (is_DC_band) then + entropy^.pub.decode_mcu := decode_mcu_DC_refine + else + entropy^.pub.decode_mcu := decode_mcu_AC_refine; + end; + + for ci := 0 to pred(cinfo^.comps_in_scan) do + begin + compptr := cinfo^.cur_comp_info[ci]; + { Make sure requested tables are present, and compute derived tables. + We may build same derived table more than once, but it's not expensive. } + + if (is_DC_band) then + begin + if (cinfo^.Ah = 0) then + begin { DC refinement needs no table } + tbl := compptr^.dc_tbl_no; + jpeg_make_d_derived_tbl(cinfo, TRUE, tbl, + entropy^.derived_tbls[tbl]); + end; + end + else + begin + tbl := compptr^.ac_tbl_no; + jpeg_make_d_derived_tbl(cinfo, FALSE, tbl, + entropy^.derived_tbls[tbl]); + { remember the single active table } + entropy^.ac_derived_tbl := entropy^.derived_tbls[tbl]; + end; + { Initialize DC predictions to 0 } + entropy^.saved.last_dc_val[ci] := 0; + end; + + { Initialize bitread state variables } + entropy^.bitstate.bits_left := 0; + entropy^.bitstate.get_buffer := 0; { unnecessary, but keeps Purify quiet } + entropy^.pub.insufficient_data := FALSE; + + { Initialize private state variables } + entropy^.saved.EOBRUN := 0; + + { Initialize restart counter } + entropy^.restarts_to_go := cinfo^.restart_interval; +end; + + +{ Figure F.12: extend sign bit. + On some machines, a shift and add will be faster than a table lookup. } + +{$ifdef AVOID_TABLES} + +#define HUFF_EXTEND(x,s) + ((x) < (1shl((s)-1)) ? (x) + (((-1)shl(s)) + 1) : (x)) + +{$else} + +{ #define HUFF_EXTEND(x,s) + if (x) < extend_test[s] then + (x) + extend_offset[s] + else + (x)} + +const + extend_test : Array[0..16-1] of int = { entry n is 2**(n-1) } + ($0000, $0001, $0002, $0004, $0008, $0010, $0020, $0040, + $0080, $0100, $0200, $0400, $0800, $1000, $2000, $4000); + +const + extend_offset : array[0..16-1] of int = { entry n is (-1 shl n) + 1 } + ( 0, ((-1) shl 1) + 1, ((-1) shl 2) + 1, ((-1) shl 3) + 1, ((-1) shl 4) + 1, + ((-1) shl 5) + 1, ((-1) shl 6) + 1, ((-1) shl 7) + 1, ((-1) shl 8) + 1, + ((-1) shl 9) + 1, ((-1) shl 10) + 1, ((-1) shl 11) + 1, ((-1) shl 12) + 1, + ((-1) shl 13) + 1, ((-1) shl 14) + 1, ((-1) shl 15) + 1 ); + +{$endif} { AVOID_TABLES } + + +{ Check for a restart marker & resynchronize decoder. + return:=s FALSE if must suspend. } + +{LOCAL} +function process_restart (cinfo : j_decompress_ptr) : boolean; +var + entropy : phuff_entropy_ptr; + ci : int; +begin + entropy := phuff_entropy_ptr (cinfo^.entropy); + + { Throw away any unused bits remaining in bit buffer; } + { include any full bytes in next_marker's count of discarded bytes } + Inc(cinfo^.marker^.discarded_bytes, entropy^.bitstate.bits_left div 8); + entropy^.bitstate.bits_left := 0; + + { Advance past the RSTn marker } + if (not cinfo^.marker^.read_restart_marker (cinfo)) then + begin + process_restart := FALSE; + exit; + end; + + { Re-initialize DC predictions to 0 } + for ci := 0 to pred(cinfo^.comps_in_scan) do + entropy^.saved.last_dc_val[ci] := 0; + { Re-init EOB run count, too } + entropy^.saved.EOBRUN := 0; + + { Reset restart counter } + entropy^.restarts_to_go := cinfo^.restart_interval; + + { Reset out-of-data flag, unless read_restart_marker left us smack up + against a marker. In that case we will end up treating the next data + segment as empty, and we can avoid producing bogus output pixels by + leaving the flag set. } + if (cinfo^.unread_marker = 0) then + entropy^.pub.insufficient_data := FALSE; + + process_restart := TRUE; +end; + + +{ Huffman MCU decoding. + Each of these routines decodes and returns one MCU's worth of + Huffman-compressed coefficients. + The coefficients are reordered from zigzag order into natural array order, + but are not dequantized. + + The i'th block of the MCU is stored into the block pointed to by + MCU_data[i]. WE ASSUME THIS AREA IS INITIALLY ZEROED BY THE CALLER. + + We return FALSE if data source requested suspension. In that case no + changes have been made to permanent state. (Exception: some output + coefficients may already have been assigned. This is harmless for + spectral selection, since we'll just re-assign them on the next call. + Successive approximation AC refinement has to be more careful, however.) } + + +{ MCU decoding for DC initial scan (either spectral selection, + or first pass of successive approximation). } + +{METHODDEF} +function decode_mcu_DC_first (cinfo : j_decompress_ptr; + var MCU_data : array of JBLOCKROW) : boolean; +label + label1; +var + entropy : phuff_entropy_ptr; + Al : int; + {register} s, r : int; + blkn, ci : int; + block : JBLOCK_PTR; + {BITREAD_STATE_VARS;} + get_buffer : bit_buf_type ; {register} + bits_left : int; {register} + br_state : bitread_working_state; + + state : savable_state; + tbl : d_derived_tbl_ptr; + compptr : jpeg_component_info_ptr; +var + nb, look : int; {register} +begin + entropy := phuff_entropy_ptr (cinfo^.entropy); + Al := cinfo^.Al; + + { Process restart marker if needed; may have to suspend } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + if (not process_restart(cinfo)) then + begin + decode_mcu_DC_first := FALSE; + exit; + end; + end; + + { If we've run out of data, just leave the MCU set to zeroes. + This way, we return uniform gray for the remainder of the segment. } + + if not entropy^.pub.insufficient_data then + begin + + { Load up working state } + {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);} + br_state.cinfo := cinfo; + br_state.next_input_byte := cinfo^.src^.next_input_byte; + br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer; + get_buffer := entropy^.bitstate.get_buffer; + bits_left := entropy^.bitstate.bits_left; + + {ASSIGN_STATE(state, entropy^.saved);} + state := entropy^.saved; + + { Outer loop handles each block in the MCU } + + for blkn := 0 to pred(cinfo^.blocks_in_MCU) do + begin + block := JBLOCK_PTR(MCU_data[blkn]); + ci := cinfo^.MCU_membership[blkn]; + compptr := cinfo^.cur_comp_info[ci]; + tbl := entropy^.derived_tbls[compptr^.dc_tbl_no]; + + { Decode a single block's worth of coefficients } + + { Section F.2.2.1: decode the DC coefficient difference } + {HUFF_DECODE(s, br_state, tbl, return FALSE, label1);} + if (bits_left < HUFF_LOOKAHEAD) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then + begin + decode_mcu_DC_first := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + if (bits_left < HUFF_LOOKAHEAD) then + begin + nb := 1; + goto label1; + end; + end; + {look := PEEK_BITS(HUFF_LOOKAHEAD);} + look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and + pred(1 shl HUFF_LOOKAHEAD); + + nb := tbl^.look_nbits[look]; + if (nb <> 0) then + begin + {DROP_BITS(nb);} + Dec(bits_left, nb); + + s := tbl^.look_sym[look]; + end + else + begin + nb := HUFF_LOOKAHEAD+1; + label1: + s := jpeg_huff_decode(br_state,get_buffer,bits_left,tbl,nb); + if (s < 0) then + begin + decode_mcu_DC_first := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + if (s <> 0) then + begin + {CHECK_BIT_BUFFER(br_state, s, return FALSE);} + if (bits_left < s) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then + begin + decode_mcu_DC_first := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {r := GET_BITS(s);} + Dec(bits_left, s); + r := (int(get_buffer shr bits_left)) and ( pred(1 shl s) ); + + {s := HUFF_EXTEND(r, s);} + if (r < extend_test[s]) then + s := r + extend_offset[s] + else + s := r; + end; + + { Convert DC difference to actual value, update last_dc_val } + Inc(s, state.last_dc_val[ci]); + state.last_dc_val[ci] := s; + { Scale and output the DC coefficient (assumes jpeg_natural_order[0]=0) } + block^[0] := JCOEF (s shl Al); + end; + + { Completed MCU, so update state } + {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);} + cinfo^.src^.next_input_byte := br_state.next_input_byte; + cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer; + entropy^.bitstate.get_buffer := get_buffer; + entropy^.bitstate.bits_left := bits_left; + + {ASSIGN_STATE(entropy^.saved, state);} + entropy^.saved := state; + end; + + { Account for restart interval (no-op if not using restarts) } + Dec(entropy^.restarts_to_go); + + decode_mcu_DC_first := TRUE; +end; + + +{ MCU decoding for AC initial scan (either spectral selection, + or first pass of successive approximation). } + +{METHODDEF} +function decode_mcu_AC_first (cinfo : j_decompress_ptr; + var MCU_data : array of JBLOCKROW) : boolean; +label + label2; +var + entropy : phuff_entropy_ptr; + Se : int; + Al : int; + {register} s, k, r : int; + EOBRUN : uInt; + block : JBLOCK_PTR; + {BITREAD_STATE_VARS;} + get_buffer : bit_buf_type ; {register} + bits_left : int; {register} + br_state : bitread_working_state; + + tbl : d_derived_tbl_ptr; +var + nb, look : int; {register} +begin + entropy := phuff_entropy_ptr (cinfo^.entropy); + Se := cinfo^.Se; + Al := cinfo^.Al; + + { Process restart marker if needed; may have to suspend } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + if (not process_restart(cinfo)) then + begin + decode_mcu_AC_first := FALSE; + exit; + end; + end; + + { If we've run out of data, just leave the MCU set to zeroes. + This way, we return uniform gray for the remainder of the segment. } + if not entropy^.pub.insufficient_data then + begin + + { Load up working state. + We can avoid loading/saving bitread state if in an EOB run. } + + EOBRUN := entropy^.saved.EOBRUN; { only part of saved state we care about } + + { There is always only one block per MCU } + + if (EOBRUN > 0) then { if it's a band of zeroes... } + Dec(EOBRUN) { ...process it now (we do nothing) } + else + begin + {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);} + br_state.cinfo := cinfo; + br_state.next_input_byte := cinfo^.src^.next_input_byte; + br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer; + get_buffer := entropy^.bitstate.get_buffer; + bits_left := entropy^.bitstate.bits_left; + + block := JBLOCK_PTR(MCU_data[0]); + tbl := entropy^.ac_derived_tbl; + + k := cinfo^.Ss; + while (k <= Se) do + begin + {HUFF_DECODE(s, br_state, tbl, return FALSE, label2);} + if (bits_left < HUFF_LOOKAHEAD) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then + begin + decode_mcu_AC_first := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + if (bits_left < HUFF_LOOKAHEAD) then + begin + nb := 1; + goto label2; + end; + end; + {look := PEEK_BITS(HUFF_LOOKAHEAD);} + look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and + pred(1 shl HUFF_LOOKAHEAD); + + nb := tbl^.look_nbits[look]; + if (nb <> 0) then + begin + {DROP_BITS(nb);} + Dec(bits_left, nb); + + s := tbl^.look_sym[look]; + end + else + begin + nb := HUFF_LOOKAHEAD+1; + label2: + s := jpeg_huff_decode(br_state,get_buffer,bits_left,tbl,nb); + if (s < 0) then + begin + decode_mcu_AC_first := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + r := s shr 4; + s := s and 15; + if (s <> 0) then + begin + Inc(k, r); + {CHECK_BIT_BUFFER(br_state, s, return FALSE);} + if (bits_left < s) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,s)) then + begin + decode_mcu_AC_first := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {r := GET_BITS(s);} + Dec(bits_left, s); + r := (int(get_buffer shr bits_left)) and ( pred(1 shl s) ); + + {s := HUFF_EXTEND(r, s);} + if (r < extend_test[s]) then + s := r + extend_offset[s] + else + s := r; + + { Scale and output coefficient in natural (dezigzagged) order } + block^[jpeg_natural_order[k]] := JCOEF (s shl Al); + end + else + begin + if (r = 15) then + begin { ZRL } + Inc(k, 15); { skip 15 zeroes in band } + end + else + begin { EOBr, run length is 2^r + appended bits } + EOBRUN := 1 shl r; + if (r <> 0) then + begin { EOBr, r > 0 } + {CHECK_BIT_BUFFER(br_state, r, return FALSE);} + if (bits_left < r) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,r)) then + begin + decode_mcu_AC_first := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {r := GET_BITS(r);} + Dec(bits_left, r); + r := (int(get_buffer shr bits_left)) and ( pred(1 shl r) ); + + Inc(EOBRUN, r); + end; + Dec(EOBRUN); { this band is processed at this moment } + break; { force end-of-band } + end; + end; + Inc(k); + end; + + {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);} + cinfo^.src^.next_input_byte := br_state.next_input_byte; + cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer; + entropy^.bitstate.get_buffer := get_buffer; + entropy^.bitstate.bits_left := bits_left; + end; + + { Completed MCU, so update state } + entropy^.saved.EOBRUN := EOBRUN; { only part of saved state we care about } + end; + + { Account for restart interval (no-op if not using restarts) } + Dec(entropy^.restarts_to_go); + + decode_mcu_AC_first := TRUE; +end; + + +{ MCU decoding for DC successive approximation refinement scan. + Note: we assume such scans can be multi-component, although the spec + is not very clear on the point. } + +{METHODDEF} +function decode_mcu_DC_refine (cinfo : j_decompress_ptr; + var MCU_data : array of JBLOCKROW) : boolean; + +var + entropy : phuff_entropy_ptr; + p1 : int; { 1 in the bit position being coded } + blkn : int; + block : JBLOCK_PTR; + {BITREAD_STATE_VARS;} + get_buffer : bit_buf_type ; {register} + bits_left : int; {register} + br_state : bitread_working_state; +begin + entropy := phuff_entropy_ptr (cinfo^.entropy); + p1 := 1 shl cinfo^.Al; + + { Process restart marker if needed; may have to suspend } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + if (not process_restart(cinfo)) then + begin + decode_mcu_DC_refine := FALSE; + exit; + end; + end; + + { Not worth the cycles to check insufficient_data here, + since we will not change the data anyway if we read zeroes. } + + { Load up working state } + {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);} + br_state.cinfo := cinfo; + br_state.next_input_byte := cinfo^.src^.next_input_byte; + br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer; + get_buffer := entropy^.bitstate.get_buffer; + bits_left := entropy^.bitstate.bits_left; + + { Outer loop handles each block in the MCU } + + for blkn := 0 to pred(cinfo^.blocks_in_MCU) do + begin + block := JBLOCK_PTR(MCU_data[blkn]); + + { Encoded data is simply the next bit of the two's-complement DC value } + {CHECK_BIT_BUFFER(br_state, 1, return FALSE);} + if (bits_left < 1) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then + begin + decode_mcu_DC_refine := FALSE; + exit; + end; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {if (GET_BITS(1)) then} + Dec(bits_left); + if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) ) <> 0 then + block^[0] := block^[0] or p1; + { Note: since we use OR, repeating the assignment later is safe } + end; + + { Completed MCU, so update state } + {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);} + cinfo^.src^.next_input_byte := br_state.next_input_byte; + cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer; + entropy^.bitstate.get_buffer := get_buffer; + entropy^.bitstate.bits_left := bits_left; + + { Account for restart interval (no-op if not using restarts) } + Dec(entropy^.restarts_to_go); + + decode_mcu_DC_refine := TRUE; +end; + + +{ MCU decoding for AC successive approximation refinement scan. } + +{METHODDEF} +function decode_mcu_AC_refine (cinfo : j_decompress_ptr; + var MCU_data : array of JBLOCKROW) : boolean; +label + undoit, label3; +var + entropy : phuff_entropy_ptr; + Se : int; + p1 : int; { 1 in the bit position being coded } + m1 : int; { -1 in the bit position being coded } + {register} s, k, r : int; + EOBRUN : uInt; + block : JBLOCK_PTR; + thiscoef : JCOEF_PTR; + {BITREAD_STATE_VARS;} + get_buffer : bit_buf_type ; {register} + bits_left : int; {register} + br_state : bitread_working_state; + + tbl : d_derived_tbl_ptr; + num_newnz : int; + newnz_pos : array[0..DCTSIZE2-1] of int; +var + pos : int; +var + nb, look : int; {register} +begin + num_newnz := 0; + block := nil; + + entropy := phuff_entropy_ptr (cinfo^.entropy); + Se := cinfo^.Se; + p1 := 1 shl cinfo^.Al; { 1 in the bit position being coded } + m1 := (-1) shl cinfo^.Al; { -1 in the bit position being coded } + + { Process restart marker if needed; may have to suspend } + if (cinfo^.restart_interval <> 0) then + begin + if (entropy^.restarts_to_go = 0) then + if (not process_restart(cinfo)) then + begin + decode_mcu_AC_refine := FALSE; + exit; + end; + end; + + { If we've run out of data, don't modify the MCU. } + if not entropy^.pub.insufficient_data then + begin + + { Load up working state } + {BITREAD_LOAD_STATE(cinfo,entropy^.bitstate);} + br_state.cinfo := cinfo; + br_state.next_input_byte := cinfo^.src^.next_input_byte; + br_state.bytes_in_buffer := cinfo^.src^.bytes_in_buffer; + get_buffer := entropy^.bitstate.get_buffer; + bits_left := entropy^.bitstate.bits_left; + + EOBRUN := entropy^.saved.EOBRUN; { only part of saved state we care about } + + { There is always only one block per MCU } + block := JBLOCK_PTR(MCU_data[0]); + tbl := entropy^.ac_derived_tbl; + + { If we are forced to suspend, we must undo the assignments to any newly + nonzero coefficients in the block, because otherwise we'd get confused + next time about which coefficients were already nonzero. + But we need not undo addition of bits to already-nonzero coefficients; + instead, we can test the current bit position to see if we already did it.} + + num_newnz := 0; + + { initialize coefficient loop counter to start of band } + k := cinfo^.Ss; + + if (EOBRUN = 0) then + begin + while (k <= Se) do + begin + {HUFF_DECODE(s, br_state, tbl, goto undoit, label3);} + if (bits_left < HUFF_LOOKAHEAD) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left, 0)) then + goto undoit; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + if (bits_left < HUFF_LOOKAHEAD) then + begin + nb := 1; + goto label3; + end; + end; + {look := PEEK_BITS(HUFF_LOOKAHEAD);} + look := int(get_buffer shr (bits_left - HUFF_LOOKAHEAD)) and + pred(1 shl HUFF_LOOKAHEAD); + + nb := tbl^.look_nbits[look]; + if (nb <> 0) then + begin + {DROP_BITS(nb);} + Dec(bits_left, nb); + + s := tbl^.look_sym[look]; + end + else + begin + nb := HUFF_LOOKAHEAD+1; + label3: + s := jpeg_huff_decode(br_state,get_buffer,bits_left,tbl,nb); + if (s < 0) then + goto undoit; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + r := s shr 4; + s := s and 15; + if (s <> 0) then + begin + if (s <> 1) then { size of new coef should always be 1 } + WARNMS(j_common_ptr(cinfo), JWRN_HUFF_BAD_CODE); + {CHECK_BIT_BUFFER(br_state, 1, goto undoit);} + if (bits_left < 1) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then + goto undoit; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {if (GET_BITS(1)) then} + Dec(bits_left); + if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) )<>0 then + s := p1 { newly nonzero coef is positive } + else + s := m1; { newly nonzero coef is negative } + end + else + begin + if (r <> 15) then + begin + EOBRUN := 1 shl r; { EOBr, run length is 2^r + appended bits } + if (r <> 0) then + begin + {CHECK_BIT_BUFFER(br_state, r, goto undoit);} + if (bits_left < r) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,r)) then + goto undoit; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {r := GET_BITS(r);} + Dec(bits_left, r); + r := (int(get_buffer shr bits_left)) and ( pred(1 shl r) ); + + Inc(EOBRUN, r); + end; + break; { rest of block is handled by EOB logic } + end; + { note s := 0 for processing ZRL } + end; + { Advance over already-nonzero coefs and r still-zero coefs, + appending correction bits to the nonzeroes. A correction bit is 1 + if the absolute value of the coefficient must be increased. } + + repeat + thiscoef :=@(block^[jpeg_natural_order[k]]); + if (thiscoef^ <> 0) then + begin + {CHECK_BIT_BUFFER(br_state, 1, goto undoit);} + if (bits_left < 1) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then + goto undoit; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {if (GET_BITS(1)) then} + Dec(bits_left); + if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) )<>0 then + begin + if ((thiscoef^ and p1) = 0) then + begin { do nothing if already set it } + if (thiscoef^ >= 0) then + Inc(thiscoef^, p1) + else + Inc(thiscoef^, m1); + end; + end; + end + else + begin + Dec(r); + if (r < 0) then + break; { reached target zero coefficient } + end; + Inc(k); + until (k > Se); + if (s <> 0) then + begin + pos := jpeg_natural_order[k]; + { Output newly nonzero coefficient } + block^[pos] := JCOEF (s); + { Remember its position in case we have to suspend } + newnz_pos[num_newnz] := pos; + Inc(num_newnz); + end; + Inc(k); + end; + end; + + if (EOBRUN > 0) then + begin + { Scan any remaining coefficient positions after the end-of-band + (the last newly nonzero coefficient, if any). Append a correction + bit to each already-nonzero coefficient. A correction bit is 1 + if the absolute value of the coefficient must be increased. } + + while (k <= Se) do + begin + thiscoef := @(block^[jpeg_natural_order[k]]); + if (thiscoef^ <> 0) then + begin + {CHECK_BIT_BUFFER(br_state, 1, goto undoit);} + if (bits_left < 1) then + begin + if (not jpeg_fill_bit_buffer(br_state,get_buffer,bits_left,1)) then + goto undoit; + get_buffer := br_state.get_buffer; + bits_left := br_state.bits_left; + end; + + {if (GET_BITS(1)) then} + Dec(bits_left); + if (int(get_buffer shr bits_left)) and ( pred(1 shl 1) )<>0 then + begin + if ((thiscoef^ and p1) = 0) then + begin { do nothing if already changed it } + if (thiscoef^ >= 0) then + Inc(thiscoef^, p1) + else + Inc(thiscoef^, m1); + end; + end; + end; + Inc(k); + end; + { Count one block completed in EOB run } + Dec(EOBRUN); + end; + + { Completed MCU, so update state } + {BITREAD_SAVE_STATE(cinfo,entropy^.bitstate);} + cinfo^.src^.next_input_byte := br_state.next_input_byte; + cinfo^.src^.bytes_in_buffer := br_state.bytes_in_buffer; + entropy^.bitstate.get_buffer := get_buffer; + entropy^.bitstate.bits_left := bits_left; + + entropy^.saved.EOBRUN := EOBRUN; { only part of saved state we care about } + end; + + { Account for restart interval (no-op if not using restarts) } + Dec(entropy^.restarts_to_go); + + decode_mcu_AC_refine := TRUE; + exit; + +undoit: + { Re-zero any output coefficients that we made newly nonzero } + while (num_newnz > 0) do + begin + Dec(num_newnz); + block^[newnz_pos[num_newnz]] := 0; + end; + + decode_mcu_AC_refine := FALSE; +end; + + +{ Module initialization routine for progressive Huffman entropy decoding. } + +{GLOBAL} +procedure jinit_phuff_decoder (cinfo : j_decompress_ptr); +var + entropy : phuff_entropy_ptr; + coef_bit_ptr : int_ptr; + ci, i : int; +begin + entropy := phuff_entropy_ptr( + cinfo^.mem^.alloc_small (j_common_ptr (cinfo), JPOOL_IMAGE, + SIZEOF(phuff_entropy_decoder)) ); + cinfo^.entropy := jpeg_entropy_decoder_ptr (entropy); + entropy^.pub.start_pass := start_pass_phuff_decoder; + + { Mark derived tables unallocated } + for i := 0 to pred(NUM_HUFF_TBLS) do + begin + entropy^.derived_tbls[i] := NIL; + end; + + { Create progression status table } + cinfo^.coef_bits := coef_bits_ptrrow ( + cinfo^.mem^.alloc_small ( j_common_ptr (cinfo), JPOOL_IMAGE, + cinfo^.num_components*DCTSIZE2*SIZEOF(int)) ); + coef_bit_ptr := @cinfo^.coef_bits^[0][0]; + for ci := 0 to pred(cinfo^.num_components) do + for i := 0 to pred(DCTSIZE2) do + begin + coef_bit_ptr^ := -1; + Inc(coef_bit_ptr); + end; +end; + +end. diff --git a/Imaging/JpegLib/imjdpostct.pas b/Imaging/JpegLib/imjdpostct.pas index f3078c3..3be825a 100644 --- a/Imaging/JpegLib/imjdpostct.pas +++ b/Imaging/JpegLib/imjdpostct.pas @@ -1,341 +1,341 @@ -unit imjdpostct; - -{ Original: jdpostct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - -{ This file contains the decompression postprocessing controller. - This controller manages the upsampling, color conversion, and color - quantization/reduction steps; specifically, it controls the buffering - between upsample/color conversion and color quantization/reduction. - - If no color quantization/reduction is required, then this module has no - work to do, and it just hands off to the upsample/color conversion code. - An integrated upsample/convert/quantize process would replace this module - entirely. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjutils, - imjpeglib; - -{ Initialize postprocessing controller. } - -{GLOBAL} -procedure jinit_d_post_controller (cinfo : j_decompress_ptr; - need_full_buffer : boolean); -implementation - - -{ Private buffer controller object } - -type - my_post_ptr = ^my_post_controller; - my_post_controller = record - pub : jpeg_d_post_controller; { public fields } - - { Color quantization source buffer: this holds output data from - the upsample/color conversion step to be passed to the quantizer. - For two-pass color quantization, we need a full-image buffer; - for one-pass operation, a strip buffer is sufficient. } - - whole_image : jvirt_sarray_ptr; { virtual array, or NIL if one-pass } - buffer : JSAMPARRAY; { strip buffer, or current strip of virtual } - strip_height : JDIMENSION; { buffer size in rows } - { for two-pass mode only: } - starting_row : JDIMENSION; { row # of first row in current strip } - next_row : JDIMENSION; { index of next row to fill/empty in strip } - end; - -{ Forward declarations } -{METHODDEF} -procedure post_process_1pass(cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); forward; -{$ifdef QUANT_2PASS_SUPPORTED} -{METHODDEF} -procedure post_process_prepass(cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); forward; -{METHODDEF} -procedure post_process_2pass(cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); forward; -{$endif} - - -{ Initialize for a processing pass. } - -{METHODDEF} -procedure start_pass_dpost (cinfo : j_decompress_ptr; - pass_mode : J_BUF_MODE); -var - post : my_post_ptr; -begin - post := my_post_ptr(cinfo^.post); - - case (pass_mode) of - JBUF_PASS_THRU: - if (cinfo^.quantize_colors) then - begin - { Single-pass processing with color quantization. } - post^.pub.post_process_data := post_process_1pass; - { We could be doing buffered-image output before starting a 2-pass - color quantization; in that case, jinit_d_post_controller did not - allocate a strip buffer. Use the virtual-array buffer as workspace. } - if (post^.buffer = NIL) then - begin - post^.buffer := cinfo^.mem^.access_virt_sarray - (j_common_ptr(cinfo), post^.whole_image, - JDIMENSION(0), post^.strip_height, TRUE); - end; - end - else - begin - { For single-pass processing without color quantization, - I have no work to do; just call the upsampler directly. } - - post^.pub.post_process_data := cinfo^.upsample^.upsample; - end; - -{$ifdef QUANT_2PASS_SUPPORTED} - JBUF_SAVE_AND_PASS: - begin - { First pass of 2-pass quantization } - if (post^.whole_image = NIL) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - post^.pub.post_process_data := post_process_prepass; - end; - JBUF_CRANK_DEST: - begin - { Second pass of 2-pass quantization } - if (post^.whole_image = NIL) then - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - post^.pub.post_process_data := post_process_2pass; - end; -{$endif} { QUANT_2PASS_SUPPORTED } - else - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); - end; - post^.next_row := 0; - post^.starting_row := 0; -end; - - -{ Process some data in the one-pass (strip buffer) case. - This is used for color precision reduction as well as one-pass quantization. } - -{METHODDEF} -procedure post_process_1pass (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); -var - post : my_post_ptr; - num_rows, max_rows : JDIMENSION; -begin - post := my_post_ptr (cinfo^.post); - - { Fill the buffer, but not more than what we can dump out in one go. } - { Note we rely on the upsampler to detect bottom of image. } - max_rows := out_rows_avail - out_row_ctr; - if (max_rows > post^.strip_height) then - max_rows := post^.strip_height; - num_rows := 0; - cinfo^.upsample^.upsample (cinfo, - input_buf, - in_row_group_ctr, - in_row_groups_avail, - post^.buffer, - num_rows, { var } - max_rows); - { Quantize and emit data. } - - cinfo^.cquantize^.color_quantize (cinfo, - post^.buffer, - JSAMPARRAY(@ output_buf^[out_row_ctr]), - int(num_rows)); - - Inc(out_row_ctr, num_rows); -end; - - -{$ifdef QUANT_2PASS_SUPPORTED} - -{ Process some data in the first pass of 2-pass quantization. } - -{METHODDEF} -procedure post_process_prepass (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail:JDIMENSION); -var - post : my_post_ptr; - old_next_row, num_rows : JDIMENSION; -begin - post := my_post_ptr(cinfo^.post); - - { Reposition virtual buffer if at start of strip. } - if (post^.next_row = 0) then - begin - post^.buffer := cinfo^.mem^.access_virt_sarray - (j_common_ptr(cinfo), post^.whole_image, - post^.starting_row, post^.strip_height, TRUE); - end; - - { Upsample some data (up to a strip height's worth). } - old_next_row := post^.next_row; - cinfo^.upsample^.upsample (cinfo, - input_buf, in_row_group_ctr, in_row_groups_avail, - post^.buffer, post^.next_row, post^.strip_height); - - { Allow quantizer to scan new data. No data is emitted, } - { but we advance out_row_ctr so outer loop can tell when we're done. } - if (post^.next_row > old_next_row) then - begin - num_rows := post^.next_row - old_next_row; - - - cinfo^.cquantize^.color_quantize (cinfo, - JSAMPARRAY(@ post^.buffer^[old_next_row]), - JSAMPARRAY(NIL), - int(num_rows)); - Inc(out_row_ctr, num_rows); - end; - - { Advance if we filled the strip. } - if (post^.next_row >= post^.strip_height) then - begin - Inc(post^.starting_row, post^.strip_height); - post^.next_row := 0; - end; -end; - - -{ Process some data in the second pass of 2-pass quantization. } - -{METHODDEF} -procedure post_process_2pass (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); -var - post : my_post_ptr; - num_rows, max_rows : JDIMENSION; -begin - post := my_post_ptr(cinfo^.post); - - { Reposition virtual buffer if at start of strip. } - if (post^.next_row = 0) then - begin - post^.buffer := cinfo^.mem^.access_virt_sarray - (j_common_ptr(cinfo), post^.whole_image, - post^.starting_row, post^.strip_height, FALSE); - end; - - { Determine number of rows to emit. } - num_rows := post^.strip_height - post^.next_row; { available in strip } - max_rows := out_rows_avail - out_row_ctr; { available in output area } - if (num_rows > max_rows) then - num_rows := max_rows; - { We have to check bottom of image here, can't depend on upsampler. } - max_rows := cinfo^.output_height - post^.starting_row; - if (num_rows > max_rows) then - num_rows := max_rows; - - { Quantize and emit data. } - cinfo^.cquantize^.color_quantize (cinfo, - JSAMPARRAY(@ post^.buffer^[post^.next_row]), - JSAMPARRAY(@ output_buf^[out_row_ctr]), - int(num_rows)); - Inc(out_row_ctr, num_rows); - - { Advance if we filled the strip. } - Inc(post^.next_row, num_rows); - if (post^.next_row >= post^.strip_height) then - begin - Inc(post^.starting_row, post^.strip_height); - post^.next_row := 0; - end; -end; - -{$endif} { QUANT_2PASS_SUPPORTED } - - -{ Initialize postprocessing controller. } - -{GLOBAL} -procedure jinit_d_post_controller (cinfo : j_decompress_ptr; - need_full_buffer : boolean); -var - post : my_post_ptr; -begin - post := my_post_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_post_controller)) ); - cinfo^.post := jpeg_d_post_controller_ptr (post); - post^.pub.start_pass := start_pass_dpost; - post^.whole_image := NIL; { flag for no virtual arrays } - post^.buffer := NIL; { flag for no strip buffer } - - { Create the quantization buffer, if needed } - if (cinfo^.quantize_colors) then - begin - { The buffer strip height is max_v_samp_factor, which is typically - an efficient number of rows for upsampling to return. - (In the presence of output rescaling, we might want to be smarter?) } - - post^.strip_height := JDIMENSION (cinfo^.max_v_samp_factor); - if (need_full_buffer) then - begin - { Two-pass color quantization: need full-image storage. } - { We round up the number of rows to a multiple of the strip height. } -{$ifdef QUANT_2PASS_SUPPORTED} - post^.whole_image := cinfo^.mem^.request_virt_sarray - (j_common_ptr(cinfo), JPOOL_IMAGE, FALSE, - LongInt(cinfo^.output_width) * cinfo^.out_color_components, - JDIMENSION (jround_up( long(cinfo^.output_height), - long(post^.strip_height)) ), - post^.strip_height); -{$else} - ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); -{$endif} { QUANT_2PASS_SUPPORTED } - end - else - begin - { One-pass color quantization: just make a strip buffer. } - post^.buffer := cinfo^.mem^.alloc_sarray - (j_common_ptr (cinfo), JPOOL_IMAGE, - LongInt(cinfo^.output_width) * cinfo^.out_color_components, - post^.strip_height); - end; - end; -end; - -end. +unit imjdpostct; + +{ Original: jdpostct.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + +{ This file contains the decompression postprocessing controller. + This controller manages the upsampling, color conversion, and color + quantization/reduction steps; specifically, it controls the buffering + between upsample/color conversion and color quantization/reduction. + + If no color quantization/reduction is required, then this module has no + work to do, and it just hands off to the upsample/color conversion code. + An integrated upsample/convert/quantize process would replace this module + entirely. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjutils, + imjpeglib; + +{ Initialize postprocessing controller. } + +{GLOBAL} +procedure jinit_d_post_controller (cinfo : j_decompress_ptr; + need_full_buffer : boolean); +implementation + + +{ Private buffer controller object } + +type + my_post_ptr = ^my_post_controller; + my_post_controller = record + pub : jpeg_d_post_controller; { public fields } + + { Color quantization source buffer: this holds output data from + the upsample/color conversion step to be passed to the quantizer. + For two-pass color quantization, we need a full-image buffer; + for one-pass operation, a strip buffer is sufficient. } + + whole_image : jvirt_sarray_ptr; { virtual array, or NIL if one-pass } + buffer : JSAMPARRAY; { strip buffer, or current strip of virtual } + strip_height : JDIMENSION; { buffer size in rows } + { for two-pass mode only: } + starting_row : JDIMENSION; { row # of first row in current strip } + next_row : JDIMENSION; { index of next row to fill/empty in strip } + end; + +{ Forward declarations } +{METHODDEF} +procedure post_process_1pass(cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); forward; +{$ifdef QUANT_2PASS_SUPPORTED} +{METHODDEF} +procedure post_process_prepass(cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); forward; +{METHODDEF} +procedure post_process_2pass(cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); forward; +{$endif} + + +{ Initialize for a processing pass. } + +{METHODDEF} +procedure start_pass_dpost (cinfo : j_decompress_ptr; + pass_mode : J_BUF_MODE); +var + post : my_post_ptr; +begin + post := my_post_ptr(cinfo^.post); + + case (pass_mode) of + JBUF_PASS_THRU: + if (cinfo^.quantize_colors) then + begin + { Single-pass processing with color quantization. } + post^.pub.post_process_data := post_process_1pass; + { We could be doing buffered-image output before starting a 2-pass + color quantization; in that case, jinit_d_post_controller did not + allocate a strip buffer. Use the virtual-array buffer as workspace. } + if (post^.buffer = NIL) then + begin + post^.buffer := cinfo^.mem^.access_virt_sarray + (j_common_ptr(cinfo), post^.whole_image, + JDIMENSION(0), post^.strip_height, TRUE); + end; + end + else + begin + { For single-pass processing without color quantization, + I have no work to do; just call the upsampler directly. } + + post^.pub.post_process_data := cinfo^.upsample^.upsample; + end; + +{$ifdef QUANT_2PASS_SUPPORTED} + JBUF_SAVE_AND_PASS: + begin + { First pass of 2-pass quantization } + if (post^.whole_image = NIL) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + post^.pub.post_process_data := post_process_prepass; + end; + JBUF_CRANK_DEST: + begin + { Second pass of 2-pass quantization } + if (post^.whole_image = NIL) then + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + post^.pub.post_process_data := post_process_2pass; + end; +{$endif} { QUANT_2PASS_SUPPORTED } + else + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); + end; + post^.next_row := 0; + post^.starting_row := 0; +end; + + +{ Process some data in the one-pass (strip buffer) case. + This is used for color precision reduction as well as one-pass quantization. } + +{METHODDEF} +procedure post_process_1pass (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); +var + post : my_post_ptr; + num_rows, max_rows : JDIMENSION; +begin + post := my_post_ptr (cinfo^.post); + + { Fill the buffer, but not more than what we can dump out in one go. } + { Note we rely on the upsampler to detect bottom of image. } + max_rows := out_rows_avail - out_row_ctr; + if (max_rows > post^.strip_height) then + max_rows := post^.strip_height; + num_rows := 0; + cinfo^.upsample^.upsample (cinfo, + input_buf, + in_row_group_ctr, + in_row_groups_avail, + post^.buffer, + num_rows, { var } + max_rows); + { Quantize and emit data. } + + cinfo^.cquantize^.color_quantize (cinfo, + post^.buffer, + JSAMPARRAY(@ output_buf^[out_row_ctr]), + int(num_rows)); + + Inc(out_row_ctr, num_rows); +end; + + +{$ifdef QUANT_2PASS_SUPPORTED} + +{ Process some data in the first pass of 2-pass quantization. } + +{METHODDEF} +procedure post_process_prepass (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail:JDIMENSION); +var + post : my_post_ptr; + old_next_row, num_rows : JDIMENSION; +begin + post := my_post_ptr(cinfo^.post); + + { Reposition virtual buffer if at start of strip. } + if (post^.next_row = 0) then + begin + post^.buffer := cinfo^.mem^.access_virt_sarray + (j_common_ptr(cinfo), post^.whole_image, + post^.starting_row, post^.strip_height, TRUE); + end; + + { Upsample some data (up to a strip height's worth). } + old_next_row := post^.next_row; + cinfo^.upsample^.upsample (cinfo, + input_buf, in_row_group_ctr, in_row_groups_avail, + post^.buffer, post^.next_row, post^.strip_height); + + { Allow quantizer to scan new data. No data is emitted, } + { but we advance out_row_ctr so outer loop can tell when we're done. } + if (post^.next_row > old_next_row) then + begin + num_rows := post^.next_row - old_next_row; + + + cinfo^.cquantize^.color_quantize (cinfo, + JSAMPARRAY(@ post^.buffer^[old_next_row]), + JSAMPARRAY(NIL), + int(num_rows)); + Inc(out_row_ctr, num_rows); + end; + + { Advance if we filled the strip. } + if (post^.next_row >= post^.strip_height) then + begin + Inc(post^.starting_row, post^.strip_height); + post^.next_row := 0; + end; +end; + + +{ Process some data in the second pass of 2-pass quantization. } + +{METHODDEF} +procedure post_process_2pass (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); +var + post : my_post_ptr; + num_rows, max_rows : JDIMENSION; +begin + post := my_post_ptr(cinfo^.post); + + { Reposition virtual buffer if at start of strip. } + if (post^.next_row = 0) then + begin + post^.buffer := cinfo^.mem^.access_virt_sarray + (j_common_ptr(cinfo), post^.whole_image, + post^.starting_row, post^.strip_height, FALSE); + end; + + { Determine number of rows to emit. } + num_rows := post^.strip_height - post^.next_row; { available in strip } + max_rows := out_rows_avail - out_row_ctr; { available in output area } + if (num_rows > max_rows) then + num_rows := max_rows; + { We have to check bottom of image here, can't depend on upsampler. } + max_rows := cinfo^.output_height - post^.starting_row; + if (num_rows > max_rows) then + num_rows := max_rows; + + { Quantize and emit data. } + cinfo^.cquantize^.color_quantize (cinfo, + JSAMPARRAY(@ post^.buffer^[post^.next_row]), + JSAMPARRAY(@ output_buf^[out_row_ctr]), + int(num_rows)); + Inc(out_row_ctr, num_rows); + + { Advance if we filled the strip. } + Inc(post^.next_row, num_rows); + if (post^.next_row >= post^.strip_height) then + begin + Inc(post^.starting_row, post^.strip_height); + post^.next_row := 0; + end; +end; + +{$endif} { QUANT_2PASS_SUPPORTED } + + +{ Initialize postprocessing controller. } + +{GLOBAL} +procedure jinit_d_post_controller (cinfo : j_decompress_ptr; + need_full_buffer : boolean); +var + post : my_post_ptr; +begin + post := my_post_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_post_controller)) ); + cinfo^.post := jpeg_d_post_controller_ptr (post); + post^.pub.start_pass := start_pass_dpost; + post^.whole_image := NIL; { flag for no virtual arrays } + post^.buffer := NIL; { flag for no strip buffer } + + { Create the quantization buffer, if needed } + if (cinfo^.quantize_colors) then + begin + { The buffer strip height is max_v_samp_factor, which is typically + an efficient number of rows for upsampling to return. + (In the presence of output rescaling, we might want to be smarter?) } + + post^.strip_height := JDIMENSION (cinfo^.max_v_samp_factor); + if (need_full_buffer) then + begin + { Two-pass color quantization: need full-image storage. } + { We round up the number of rows to a multiple of the strip height. } +{$ifdef QUANT_2PASS_SUPPORTED} + post^.whole_image := cinfo^.mem^.request_virt_sarray + (j_common_ptr(cinfo), JPOOL_IMAGE, FALSE, + LongInt(cinfo^.output_width) * cinfo^.out_color_components, + JDIMENSION (jround_up( long(cinfo^.output_height), + long(post^.strip_height)) ), + post^.strip_height); +{$else} + ERREXIT(j_common_ptr(cinfo), JERR_BAD_BUFFER_MODE); +{$endif} { QUANT_2PASS_SUPPORTED } + end + else + begin + { One-pass color quantization: just make a strip buffer. } + post^.buffer := cinfo^.mem^.alloc_sarray + (j_common_ptr (cinfo), JPOOL_IMAGE, + LongInt(cinfo^.output_width) * cinfo^.out_color_components, + post^.strip_height); + end; + end; +end; + +end. diff --git a/Imaging/JpegLib/imjdsample.pas b/Imaging/JpegLib/imjdsample.pas index ed2488c..c980468 100644 --- a/Imaging/JpegLib/imjdsample.pas +++ b/Imaging/JpegLib/imjdsample.pas @@ -1,592 +1,592 @@ -unit imjdsample; - -{ Original: jdsample.c; Copyright (C) 1991-1996, Thomas G. Lane. } - -{ This file contains upsampling routines. - - Upsampling input data is counted in "row groups". A row group - is defined to be (v_samp_factor * DCT_scaled_size / min_DCT_scaled_size) - sample rows of each component. Upsampling will normally produce - max_v_samp_factor pixel rows from each row group (but this could vary - if the upsampler is applying a scale factor of its own). - - An excellent reference for image resampling is - Digital Image Warping, George Wolberg, 1990. - Pub. by IEEE Computer Society Press, Los Alamitos, CA. ISBN 0-8186-8944-7.} - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjutils, - imjpeglib, - imjdeferr, - imjerror; - - -{ Pointer to routine to upsample a single component } -type - upsample1_ptr = procedure (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - var output_data_ptr : JSAMPARRAY); - -{ Module initialization routine for upsampling. } - -{GLOBAL} -procedure jinit_upsampler (cinfo : j_decompress_ptr); - -implementation - -{ Private subobject } - -type - my_upsample_ptr = ^my_upsampler; - my_upsampler = record - pub : jpeg_upsampler; { public fields } - - { Color conversion buffer. When using separate upsampling and color - conversion steps, this buffer holds one upsampled row group until it - has been color converted and output. - Note: we do not allocate any storage for component(s) which are full-size, - ie do not need rescaling. The corresponding entry of color_buf[] is - simply set to point to the input data array, thereby avoiding copying.} - - color_buf : array[0..MAX_COMPONENTS-1] of JSAMPARRAY; - - { Per-component upsampling method pointers } - methods : array[0..MAX_COMPONENTS-1] of upsample1_ptr; - - next_row_out : int; { counts rows emitted from color_buf } - rows_to_go : JDIMENSION; { counts rows remaining in image } - - { Height of an input row group for each component. } - rowgroup_height : array[0..MAX_COMPONENTS-1] of int; - - { These arrays save pixel expansion factors so that int_expand need not - recompute them each time. They are unused for other upsampling methods.} - h_expand : array[0..MAX_COMPONENTS-1] of UINT8 ; - v_expand : array[0..MAX_COMPONENTS-1] of UINT8 ; - end; - - -{ Initialize for an upsampling pass. } - -{METHODDEF} -procedure start_pass_upsample (cinfo : j_decompress_ptr); -var - upsample : my_upsample_ptr; -begin - upsample := my_upsample_ptr (cinfo^.upsample); - - { Mark the conversion buffer empty } - upsample^.next_row_out := cinfo^.max_v_samp_factor; - { Initialize total-height counter for detecting bottom of image } - upsample^.rows_to_go := cinfo^.output_height; -end; - - -{ Control routine to do upsampling (and color conversion). - - In this version we upsample each component independently. - We upsample one row group into the conversion buffer, then apply - color conversion a row at a time. } - -{METHODDEF} -procedure sep_upsample (cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); -var - upsample : my_upsample_ptr; - ci : int; - compptr : jpeg_component_info_ptr; - num_rows : JDIMENSION; -begin - upsample := my_upsample_ptr (cinfo^.upsample); - - { Fill the conversion buffer, if it's empty } - if (upsample^.next_row_out >= cinfo^.max_v_samp_factor) then - begin - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - { Invoke per-component upsample method. Notice we pass a POINTER - to color_buf[ci], so that fullsize_upsample can change it. } - - upsample^.methods[ci] (cinfo, compptr, - JSAMPARRAY(@ input_buf^[ci]^ - [LongInt(in_row_group_ctr) * upsample^.rowgroup_height[ci]]), - upsample^.color_buf[ci]); - - Inc(compptr); - end; - upsample^.next_row_out := 0; - end; - - { Color-convert and emit rows } - - { How many we have in the buffer: } - num_rows := JDIMENSION (cinfo^.max_v_samp_factor - upsample^.next_row_out); - { Not more than the distance to the end of the image. Need this test - in case the image height is not a multiple of max_v_samp_factor: } - - if (num_rows > upsample^.rows_to_go) then - num_rows := upsample^.rows_to_go; - { And not more than what the client can accept: } - Dec(out_rows_avail, out_row_ctr); - if (num_rows > out_rows_avail) then - num_rows := out_rows_avail; - - cinfo^.cconvert^.color_convert (cinfo, - JSAMPIMAGE(@(upsample^.color_buf)), - JDIMENSION (upsample^.next_row_out), - JSAMPARRAY(@(output_buf^[out_row_ctr])), - int (num_rows)); - - { Adjust counts } - Inc(out_row_ctr, num_rows); - Dec(upsample^.rows_to_go, num_rows); - Inc(upsample^.next_row_out, num_rows); - { When the buffer is emptied, declare this input row group consumed } - if (upsample^.next_row_out >= cinfo^.max_v_samp_factor) then - Inc(in_row_group_ctr); -end; - - -{ These are the routines invoked by sep_upsample to upsample pixel values - of a single component. One row group is processed per call. } - - -{ For full-size components, we just make color_buf[ci] point at the - input buffer, and thus avoid copying any data. Note that this is - safe only because sep_upsample doesn't declare the input row group - "consumed" until we are done color converting and emitting it. } - -{METHODDEF} -procedure fullsize_upsample (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - var output_data_ptr : JSAMPARRAY); -begin - output_data_ptr := input_data; -end; - - -{ This is a no-op version used for "uninteresting" components. - These components will not be referenced by color conversion. } - -{METHODDEF} -procedure noop_upsample (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - var output_data_ptr : JSAMPARRAY); -begin - output_data_ptr := NIL; { safety check } -end; - - -{ This version handles any integral sampling ratios. - This is not used for typical JPEG files, so it need not be fast. - Nor, for that matter, is it particularly accurate: the algorithm is - simple replication of the input pixel onto the corresponding output - pixels. The hi-falutin sampling literature refers to this as a - "box filter". A box filter tends to introduce visible artifacts, - so if you are actually going to use 3:1 or 4:1 sampling ratios - you would be well advised to improve this code. } - -{METHODDEF} -procedure int_upsample (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - var output_data_ptr : JSAMPARRAY); -var - upsample : my_upsample_ptr; - output_data : JSAMPARRAY; - {register} inptr, outptr : JSAMPLE_PTR; - {register} invalue : JSAMPLE; - {register} h : int; - {outend} - h_expand, v_expand : int; - inrow, outrow : int; -var - outcount : int; { Nomssi: avoid pointer arithmetic } -begin - upsample := my_upsample_ptr (cinfo^.upsample); - output_data := output_data_ptr; - - h_expand := upsample^.h_expand[compptr^.component_index]; - v_expand := upsample^.v_expand[compptr^.component_index]; - - inrow := 0; - outrow := 0; - while (outrow < cinfo^.max_v_samp_factor) do - begin - { Generate one output row with proper horizontal expansion } - inptr := JSAMPLE_PTR(input_data^[inrow]); - outptr := JSAMPLE_PTR(output_data^[outrow]); - outcount := cinfo^.output_width; - while (outcount > 0) do { Nomssi } - begin - invalue := inptr^; { don't need GETJSAMPLE() here } - Inc(inptr); - for h := pred(h_expand) downto 0 do - begin - outptr^ := invalue; - inc(outptr); { <-- fix: this was left out in PasJpeg 1.0 } - Dec(outcount); { thanks to Jannie Gerber for the report } - end; - end; - - { Generate any additional output rows by duplicating the first one } - if (v_expand > 1) then - begin - jcopy_sample_rows(output_data, outrow, output_data, outrow+1, - v_expand-1, cinfo^.output_width); - end; - Inc(inrow); - Inc(outrow, v_expand); - end; -end; - - -{ Fast processing for the common case of 2:1 horizontal and 1:1 vertical. - It's still a box filter. } - -{METHODDEF} -procedure h2v1_upsample (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - var output_data_ptr : JSAMPARRAY); -var - output_data : JSAMPARRAY; - {register} inptr, outptr : JSAMPLE_PTR; - {register} invalue : JSAMPLE; - {outend : JSAMPROW;} - outcount : int; - inrow : int; -begin - output_data := output_data_ptr; - - for inrow := 0 to pred(cinfo^.max_v_samp_factor) do - begin - inptr := JSAMPLE_PTR(input_data^[inrow]); - outptr := JSAMPLE_PTR(output_data^[inrow]); - {outend := outptr + cinfo^.output_width;} - outcount := cinfo^.output_width; - while (outcount > 0) do - begin - invalue := inptr^; { don't need GETJSAMPLE() here } - Inc(inptr); - outptr^ := invalue; - Inc(outptr); - outptr^ := invalue; - Inc(outptr); - Dec(outcount, 2); { Nomssi: to avoid pointer arithmetic } - end; - end; -end; - - -{ Fast processing for the common case of 2:1 horizontal and 2:1 vertical. - It's still a box filter. } - -{METHODDEF} -procedure h2v2_upsample (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - var output_data_ptr : JSAMPARRAY); -var - output_data : JSAMPARRAY; - {register} inptr, outptr : JSAMPLE_PTR; - {register} invalue : JSAMPLE; - {outend : JSAMPROW;} - outcount : int; - inrow, outrow : int; -begin - output_data := output_data_ptr; - - inrow := 0; - outrow := 0; - while (outrow < cinfo^.max_v_samp_factor) do - begin - inptr := JSAMPLE_PTR(input_data^[inrow]); - outptr := JSAMPLE_PTR(output_data^[outrow]); - {outend := outptr + cinfo^.output_width;} - outcount := cinfo^.output_width; - while (outcount > 0) do - begin - invalue := inptr^; { don't need GETJSAMPLE() here } - Inc(inptr); - outptr^ := invalue; - Inc(outptr); - outptr^ := invalue; - Inc(outptr); - Dec(outcount, 2); - end; - jcopy_sample_rows(output_data, outrow, output_data, outrow+1, - 1, cinfo^.output_width); - Inc(inrow); - Inc(outrow, 2); - end; -end; - - -{ Fancy processing for the common case of 2:1 horizontal and 1:1 vertical. - - The upsampling algorithm is linear interpolation between pixel centers, - also known as a "triangle filter". This is a good compromise between - speed and visual quality. The centers of the output pixels are 1/4 and 3/4 - of the way between input pixel centers. - - A note about the "bias" calculations: when rounding fractional values to - integer, we do not want to always round 0.5 up to the next integer. - If we did that, we'd introduce a noticeable bias towards larger values. - Instead, this code is arranged so that 0.5 will be rounded up or down at - alternate pixel locations (a simple ordered dither pattern). } - -{METHODDEF} -procedure h2v1_fancy_upsample (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - var output_data_ptr : JSAMPARRAY); -var - output_data : JSAMPARRAY; - {register} pre_inptr, inptr, outptr : JSAMPLE_PTR; - {register} invalue : int; - {register} colctr : JDIMENSION; - inrow : int; -begin - output_data := output_data_ptr; - - for inrow := 0 to pred(cinfo^.max_v_samp_factor) do - begin - inptr := JSAMPLE_PTR(input_data^[inrow]); - outptr := JSAMPLE_PTR(output_data^[inrow]); - { Special case for first column } - pre_inptr := inptr; - invalue := GETJSAMPLE(inptr^); - Inc(inptr); - outptr^ := JSAMPLE (invalue); - Inc(outptr); - outptr^ := JSAMPLE ((invalue * 3 + GETJSAMPLE(inptr^) + 2) shr 2); - Inc(outptr); - - for colctr := pred(compptr^.downsampled_width - 2) downto 0 do - begin - { General case: 3/4 * nearer pixel + 1/4 * further pixel } - invalue := GETJSAMPLE(inptr^) * 3; - Inc(inptr); - outptr^ := JSAMPLE ((invalue + GETJSAMPLE(pre_inptr^) + 1) shr 2); - Inc(pre_inptr); - Inc(outptr); - outptr^ := JSAMPLE ((invalue + GETJSAMPLE(inptr^) + 2) shr 2); - Inc(outptr); - end; - - { Special case for last column } - invalue := GETJSAMPLE(inptr^); - outptr^ := JSAMPLE ((invalue * 3 + GETJSAMPLE(pre_inptr^) + 1) shr 2); - Inc(outptr); - outptr^ := JSAMPLE (invalue); - {Inc(outptr); - value never used } - end; -end; - - -{ Fancy processing for the common case of 2:1 horizontal and 2:1 vertical. - Again a triangle filter; see comments for h2v1 case, above. - - It is OK for us to reference the adjacent input rows because we demanded - context from the main buffer controller (see initialization code). } - -{METHODDEF} -procedure h2v2_fancy_upsample (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - input_data : JSAMPARRAY; - var output_data_ptr : JSAMPARRAY); -var - output_data : JSAMPARRAY; - {register} inptr0, inptr1, outptr : JSAMPLE_PTR; -{$ifdef BITS_IN_JSAMPLE_IS_8} - {register} thiscolsum, lastcolsum, nextcolsum : int; -{$else} - {register} thiscolsum, lastcolsum, nextcolsum : INT32; -{$endif} - {register} colctr : JDIMENSION; - inrow, outrow, v : int; -var - prev_input_data : JSAMPARRAY; { Nomssi work around } -begin - output_data := output_data_ptr; - - outrow := 0; - inrow := 0; - while (outrow < cinfo^.max_v_samp_factor) do - begin - for v := 0 to pred(2) do - begin - { inptr0 points to nearest input row, inptr1 points to next nearest } - inptr0 := JSAMPLE_PTR(input_data^[inrow]); - if (v = 0) then { next nearest is row above } - begin - {inptr1 := JSAMPLE_PTR(input_data^[inrow-1]);} - prev_input_data := input_data; { work around } - Dec(JSAMPROW_PTR(prev_input_data)); { negative offsets } - inptr1 := JSAMPLE_PTR(prev_input_data^[inrow]); - end - else { next nearest is row below } - inptr1 := JSAMPLE_PTR(input_data^[inrow+1]); - outptr := JSAMPLE_PTR(output_data^[outrow]); - Inc(outrow); - - { Special case for first column } - thiscolsum := GETJSAMPLE(inptr0^) * 3 + GETJSAMPLE(inptr1^); - Inc(inptr0); - Inc(inptr1); - nextcolsum := GETJSAMPLE(inptr0^) * 3 + GETJSAMPLE(inptr1^); - Inc(inptr0); - Inc(inptr1); - - outptr^ := JSAMPLE ((thiscolsum * 4 + 8) shr 4); - Inc(outptr); - outptr^ := JSAMPLE ((thiscolsum * 3 + nextcolsum + 7) shr 4); - Inc(outptr); - lastcolsum := thiscolsum; thiscolsum := nextcolsum; - - for colctr := pred(compptr^.downsampled_width - 2) downto 0 do - begin - { General case: 3/4 * nearer pixel + 1/4 * further pixel in each } - { dimension, thus 9/16, 3/16, 3/16, 1/16 overall } - nextcolsum := GETJSAMPLE(inptr0^) * 3 + GETJSAMPLE(inptr1^); - Inc(inptr0); - Inc(inptr1); - outptr^ := JSAMPLE ((thiscolsum * 3 + lastcolsum + 8) shr 4); - Inc(outptr); - outptr^ := JSAMPLE ((thiscolsum * 3 + nextcolsum + 7) shr 4); - Inc(outptr); - lastcolsum := thiscolsum; - thiscolsum := nextcolsum; - end; - - { Special case for last column } - outptr^ := JSAMPLE ((thiscolsum * 3 + lastcolsum + 8) shr 4); - Inc(outptr); - outptr^ := JSAMPLE ((thiscolsum * 4 + 7) shr 4); - {Inc(outptr); - value never used } - end; - Inc(inrow); - end; -end; - - -{ Module initialization routine for upsampling. } - -{GLOBAL} -procedure jinit_upsampler (cinfo : j_decompress_ptr); -var - upsample : my_upsample_ptr; - ci : int; - compptr : jpeg_component_info_ptr; - need_buffer, do_fancy : boolean; - h_in_group, v_in_group, h_out_group, v_out_group : int; -begin - upsample := my_upsample_ptr ( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_upsampler)) ); - cinfo^.upsample := jpeg_upsampler_ptr (upsample); - upsample^.pub.start_pass := start_pass_upsample; - upsample^.pub.upsample := sep_upsample; - upsample^.pub.need_context_rows := FALSE; { until we find out differently } - - if (cinfo^.CCIR601_sampling) then { this isn't supported } - ERREXIT(j_common_ptr(cinfo), JERR_CCIR601_NOTIMPL); - - { jdmainct.c doesn't support context rows when min_DCT_scaled_size := 1, - so don't ask for it. } - - do_fancy := cinfo^.do_fancy_upsampling and (cinfo^.min_DCT_scaled_size > 1); - - { Verify we can handle the sampling factors, select per-component methods, - and create storage as needed. } - - compptr := jpeg_component_info_ptr(cinfo^.comp_info); - for ci := 0 to pred(cinfo^.num_components) do - begin - { Compute size of an "input group" after IDCT scaling. This many samples - are to be converted to max_h_samp_factor * max_v_samp_factor pixels. } - - h_in_group := (compptr^.h_samp_factor * compptr^.DCT_scaled_size) div - cinfo^.min_DCT_scaled_size; - v_in_group := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div - cinfo^.min_DCT_scaled_size; - h_out_group := cinfo^.max_h_samp_factor; - v_out_group := cinfo^.max_v_samp_factor; - upsample^.rowgroup_height[ci] := v_in_group; { save for use later } - need_buffer := TRUE; - if (not compptr^.component_needed) then - begin - { Don't bother to upsample an uninteresting component. } - upsample^.methods[ci] := noop_upsample; - need_buffer := FALSE; - end - else - if (h_in_group = h_out_group) and (v_in_group = v_out_group) then - begin - { Fullsize components can be processed without any work. } - upsample^.methods[ci] := fullsize_upsample; - need_buffer := FALSE; - end - else - if (h_in_group * 2 = h_out_group) and - (v_in_group = v_out_group) then - begin - { Special cases for 2h1v upsampling } - if (do_fancy) and (compptr^.downsampled_width > 2) then - upsample^.methods[ci] := h2v1_fancy_upsample - else - upsample^.methods[ci] := h2v1_upsample; - end - else - if (h_in_group * 2 = h_out_group) and - (v_in_group * 2 = v_out_group) then - begin - { Special cases for 2h2v upsampling } - if (do_fancy) and (compptr^.downsampled_width > 2) then - begin - upsample^.methods[ci] := h2v2_fancy_upsample; - upsample^.pub.need_context_rows := TRUE; - end - else - upsample^.methods[ci] := h2v2_upsample; - end - else - if ((h_out_group mod h_in_group) = 0) and - ((v_out_group mod v_in_group) = 0) then - begin - { Generic integral-factors upsampling method } - upsample^.methods[ci] := int_upsample; - upsample^.h_expand[ci] := UINT8 (h_out_group div h_in_group); - upsample^.v_expand[ci] := UINT8 (v_out_group div v_in_group); - end - else - ERREXIT(j_common_ptr(cinfo), JERR_FRACT_SAMPLE_NOTIMPL); - if (need_buffer) then - begin - upsample^.color_buf[ci] := cinfo^.mem^.alloc_sarray - (j_common_ptr(cinfo), JPOOL_IMAGE, - JDIMENSION (jround_up( long (cinfo^.output_width), - long (cinfo^.max_h_samp_factor))), - JDIMENSION (cinfo^.max_v_samp_factor)); - end; - Inc(compptr); - end; -end; - -end. +unit imjdsample; + +{ Original: jdsample.c; Copyright (C) 1991-1996, Thomas G. Lane. } + +{ This file contains upsampling routines. + + Upsampling input data is counted in "row groups". A row group + is defined to be (v_samp_factor * DCT_scaled_size / min_DCT_scaled_size) + sample rows of each component. Upsampling will normally produce + max_v_samp_factor pixel rows from each row group (but this could vary + if the upsampler is applying a scale factor of its own). + + An excellent reference for image resampling is + Digital Image Warping, George Wolberg, 1990. + Pub. by IEEE Computer Society Press, Los Alamitos, CA. ISBN 0-8186-8944-7.} + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjutils, + imjpeglib, + imjdeferr, + imjerror; + + +{ Pointer to routine to upsample a single component } +type + upsample1_ptr = procedure (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + var output_data_ptr : JSAMPARRAY); + +{ Module initialization routine for upsampling. } + +{GLOBAL} +procedure jinit_upsampler (cinfo : j_decompress_ptr); + +implementation + +{ Private subobject } + +type + my_upsample_ptr = ^my_upsampler; + my_upsampler = record + pub : jpeg_upsampler; { public fields } + + { Color conversion buffer. When using separate upsampling and color + conversion steps, this buffer holds one upsampled row group until it + has been color converted and output. + Note: we do not allocate any storage for component(s) which are full-size, + ie do not need rescaling. The corresponding entry of color_buf[] is + simply set to point to the input data array, thereby avoiding copying.} + + color_buf : array[0..MAX_COMPONENTS-1] of JSAMPARRAY; + + { Per-component upsampling method pointers } + methods : array[0..MAX_COMPONENTS-1] of upsample1_ptr; + + next_row_out : int; { counts rows emitted from color_buf } + rows_to_go : JDIMENSION; { counts rows remaining in image } + + { Height of an input row group for each component. } + rowgroup_height : array[0..MAX_COMPONENTS-1] of int; + + { These arrays save pixel expansion factors so that int_expand need not + recompute them each time. They are unused for other upsampling methods.} + h_expand : array[0..MAX_COMPONENTS-1] of UINT8 ; + v_expand : array[0..MAX_COMPONENTS-1] of UINT8 ; + end; + + +{ Initialize for an upsampling pass. } + +{METHODDEF} +procedure start_pass_upsample (cinfo : j_decompress_ptr); +var + upsample : my_upsample_ptr; +begin + upsample := my_upsample_ptr (cinfo^.upsample); + + { Mark the conversion buffer empty } + upsample^.next_row_out := cinfo^.max_v_samp_factor; + { Initialize total-height counter for detecting bottom of image } + upsample^.rows_to_go := cinfo^.output_height; +end; + + +{ Control routine to do upsampling (and color conversion). + + In this version we upsample each component independently. + We upsample one row group into the conversion buffer, then apply + color conversion a row at a time. } + +{METHODDEF} +procedure sep_upsample (cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); +var + upsample : my_upsample_ptr; + ci : int; + compptr : jpeg_component_info_ptr; + num_rows : JDIMENSION; +begin + upsample := my_upsample_ptr (cinfo^.upsample); + + { Fill the conversion buffer, if it's empty } + if (upsample^.next_row_out >= cinfo^.max_v_samp_factor) then + begin + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + { Invoke per-component upsample method. Notice we pass a POINTER + to color_buf[ci], so that fullsize_upsample can change it. } + + upsample^.methods[ci] (cinfo, compptr, + JSAMPARRAY(@ input_buf^[ci]^ + [LongInt(in_row_group_ctr) * upsample^.rowgroup_height[ci]]), + upsample^.color_buf[ci]); + + Inc(compptr); + end; + upsample^.next_row_out := 0; + end; + + { Color-convert and emit rows } + + { How many we have in the buffer: } + num_rows := JDIMENSION (cinfo^.max_v_samp_factor - upsample^.next_row_out); + { Not more than the distance to the end of the image. Need this test + in case the image height is not a multiple of max_v_samp_factor: } + + if (num_rows > upsample^.rows_to_go) then + num_rows := upsample^.rows_to_go; + { And not more than what the client can accept: } + Dec(out_rows_avail, out_row_ctr); + if (num_rows > out_rows_avail) then + num_rows := out_rows_avail; + + cinfo^.cconvert^.color_convert (cinfo, + JSAMPIMAGE(@(upsample^.color_buf)), + JDIMENSION (upsample^.next_row_out), + JSAMPARRAY(@(output_buf^[out_row_ctr])), + int (num_rows)); + + { Adjust counts } + Inc(out_row_ctr, num_rows); + Dec(upsample^.rows_to_go, num_rows); + Inc(upsample^.next_row_out, num_rows); + { When the buffer is emptied, declare this input row group consumed } + if (upsample^.next_row_out >= cinfo^.max_v_samp_factor) then + Inc(in_row_group_ctr); +end; + + +{ These are the routines invoked by sep_upsample to upsample pixel values + of a single component. One row group is processed per call. } + + +{ For full-size components, we just make color_buf[ci] point at the + input buffer, and thus avoid copying any data. Note that this is + safe only because sep_upsample doesn't declare the input row group + "consumed" until we are done color converting and emitting it. } + +{METHODDEF} +procedure fullsize_upsample (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + var output_data_ptr : JSAMPARRAY); +begin + output_data_ptr := input_data; +end; + + +{ This is a no-op version used for "uninteresting" components. + These components will not be referenced by color conversion. } + +{METHODDEF} +procedure noop_upsample (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + var output_data_ptr : JSAMPARRAY); +begin + output_data_ptr := NIL; { safety check } +end; + + +{ This version handles any integral sampling ratios. + This is not used for typical JPEG files, so it need not be fast. + Nor, for that matter, is it particularly accurate: the algorithm is + simple replication of the input pixel onto the corresponding output + pixels. The hi-falutin sampling literature refers to this as a + "box filter". A box filter tends to introduce visible artifacts, + so if you are actually going to use 3:1 or 4:1 sampling ratios + you would be well advised to improve this code. } + +{METHODDEF} +procedure int_upsample (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + var output_data_ptr : JSAMPARRAY); +var + upsample : my_upsample_ptr; + output_data : JSAMPARRAY; + {register} inptr, outptr : JSAMPLE_PTR; + {register} invalue : JSAMPLE; + {register} h : int; + {outend} + h_expand, v_expand : int; + inrow, outrow : int; +var + outcount : int; { Nomssi: avoid pointer arithmetic } +begin + upsample := my_upsample_ptr (cinfo^.upsample); + output_data := output_data_ptr; + + h_expand := upsample^.h_expand[compptr^.component_index]; + v_expand := upsample^.v_expand[compptr^.component_index]; + + inrow := 0; + outrow := 0; + while (outrow < cinfo^.max_v_samp_factor) do + begin + { Generate one output row with proper horizontal expansion } + inptr := JSAMPLE_PTR(input_data^[inrow]); + outptr := JSAMPLE_PTR(output_data^[outrow]); + outcount := cinfo^.output_width; + while (outcount > 0) do { Nomssi } + begin + invalue := inptr^; { don't need GETJSAMPLE() here } + Inc(inptr); + for h := pred(h_expand) downto 0 do + begin + outptr^ := invalue; + inc(outptr); { <-- fix: this was left out in PasJpeg 1.0 } + Dec(outcount); { thanks to Jannie Gerber for the report } + end; + end; + + { Generate any additional output rows by duplicating the first one } + if (v_expand > 1) then + begin + jcopy_sample_rows(output_data, outrow, output_data, outrow+1, + v_expand-1, cinfo^.output_width); + end; + Inc(inrow); + Inc(outrow, v_expand); + end; +end; + + +{ Fast processing for the common case of 2:1 horizontal and 1:1 vertical. + It's still a box filter. } + +{METHODDEF} +procedure h2v1_upsample (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + var output_data_ptr : JSAMPARRAY); +var + output_data : JSAMPARRAY; + {register} inptr, outptr : JSAMPLE_PTR; + {register} invalue : JSAMPLE; + {outend : JSAMPROW;} + outcount : int; + inrow : int; +begin + output_data := output_data_ptr; + + for inrow := 0 to pred(cinfo^.max_v_samp_factor) do + begin + inptr := JSAMPLE_PTR(input_data^[inrow]); + outptr := JSAMPLE_PTR(output_data^[inrow]); + {outend := outptr + cinfo^.output_width;} + outcount := cinfo^.output_width; + while (outcount > 0) do + begin + invalue := inptr^; { don't need GETJSAMPLE() here } + Inc(inptr); + outptr^ := invalue; + Inc(outptr); + outptr^ := invalue; + Inc(outptr); + Dec(outcount, 2); { Nomssi: to avoid pointer arithmetic } + end; + end; +end; + + +{ Fast processing for the common case of 2:1 horizontal and 2:1 vertical. + It's still a box filter. } + +{METHODDEF} +procedure h2v2_upsample (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + var output_data_ptr : JSAMPARRAY); +var + output_data : JSAMPARRAY; + {register} inptr, outptr : JSAMPLE_PTR; + {register} invalue : JSAMPLE; + {outend : JSAMPROW;} + outcount : int; + inrow, outrow : int; +begin + output_data := output_data_ptr; + + inrow := 0; + outrow := 0; + while (outrow < cinfo^.max_v_samp_factor) do + begin + inptr := JSAMPLE_PTR(input_data^[inrow]); + outptr := JSAMPLE_PTR(output_data^[outrow]); + {outend := outptr + cinfo^.output_width;} + outcount := cinfo^.output_width; + while (outcount > 0) do + begin + invalue := inptr^; { don't need GETJSAMPLE() here } + Inc(inptr); + outptr^ := invalue; + Inc(outptr); + outptr^ := invalue; + Inc(outptr); + Dec(outcount, 2); + end; + jcopy_sample_rows(output_data, outrow, output_data, outrow+1, + 1, cinfo^.output_width); + Inc(inrow); + Inc(outrow, 2); + end; +end; + + +{ Fancy processing for the common case of 2:1 horizontal and 1:1 vertical. + + The upsampling algorithm is linear interpolation between pixel centers, + also known as a "triangle filter". This is a good compromise between + speed and visual quality. The centers of the output pixels are 1/4 and 3/4 + of the way between input pixel centers. + + A note about the "bias" calculations: when rounding fractional values to + integer, we do not want to always round 0.5 up to the next integer. + If we did that, we'd introduce a noticeable bias towards larger values. + Instead, this code is arranged so that 0.5 will be rounded up or down at + alternate pixel locations (a simple ordered dither pattern). } + +{METHODDEF} +procedure h2v1_fancy_upsample (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + var output_data_ptr : JSAMPARRAY); +var + output_data : JSAMPARRAY; + {register} pre_inptr, inptr, outptr : JSAMPLE_PTR; + {register} invalue : int; + {register} colctr : JDIMENSION; + inrow : int; +begin + output_data := output_data_ptr; + + for inrow := 0 to pred(cinfo^.max_v_samp_factor) do + begin + inptr := JSAMPLE_PTR(input_data^[inrow]); + outptr := JSAMPLE_PTR(output_data^[inrow]); + { Special case for first column } + pre_inptr := inptr; + invalue := GETJSAMPLE(inptr^); + Inc(inptr); + outptr^ := JSAMPLE (invalue); + Inc(outptr); + outptr^ := JSAMPLE ((invalue * 3 + GETJSAMPLE(inptr^) + 2) shr 2); + Inc(outptr); + + for colctr := pred(compptr^.downsampled_width - 2) downto 0 do + begin + { General case: 3/4 * nearer pixel + 1/4 * further pixel } + invalue := GETJSAMPLE(inptr^) * 3; + Inc(inptr); + outptr^ := JSAMPLE ((invalue + GETJSAMPLE(pre_inptr^) + 1) shr 2); + Inc(pre_inptr); + Inc(outptr); + outptr^ := JSAMPLE ((invalue + GETJSAMPLE(inptr^) + 2) shr 2); + Inc(outptr); + end; + + { Special case for last column } + invalue := GETJSAMPLE(inptr^); + outptr^ := JSAMPLE ((invalue * 3 + GETJSAMPLE(pre_inptr^) + 1) shr 2); + Inc(outptr); + outptr^ := JSAMPLE (invalue); + {Inc(outptr); - value never used } + end; +end; + + +{ Fancy processing for the common case of 2:1 horizontal and 2:1 vertical. + Again a triangle filter; see comments for h2v1 case, above. + + It is OK for us to reference the adjacent input rows because we demanded + context from the main buffer controller (see initialization code). } + +{METHODDEF} +procedure h2v2_fancy_upsample (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + input_data : JSAMPARRAY; + var output_data_ptr : JSAMPARRAY); +var + output_data : JSAMPARRAY; + {register} inptr0, inptr1, outptr : JSAMPLE_PTR; +{$ifdef BITS_IN_JSAMPLE_IS_8} + {register} thiscolsum, lastcolsum, nextcolsum : int; +{$else} + {register} thiscolsum, lastcolsum, nextcolsum : INT32; +{$endif} + {register} colctr : JDIMENSION; + inrow, outrow, v : int; +var + prev_input_data : JSAMPARRAY; { Nomssi work around } +begin + output_data := output_data_ptr; + + outrow := 0; + inrow := 0; + while (outrow < cinfo^.max_v_samp_factor) do + begin + for v := 0 to pred(2) do + begin + { inptr0 points to nearest input row, inptr1 points to next nearest } + inptr0 := JSAMPLE_PTR(input_data^[inrow]); + if (v = 0) then { next nearest is row above } + begin + {inptr1 := JSAMPLE_PTR(input_data^[inrow-1]);} + prev_input_data := input_data; { work around } + Dec(JSAMPROW_PTR(prev_input_data)); { negative offsets } + inptr1 := JSAMPLE_PTR(prev_input_data^[inrow]); + end + else { next nearest is row below } + inptr1 := JSAMPLE_PTR(input_data^[inrow+1]); + outptr := JSAMPLE_PTR(output_data^[outrow]); + Inc(outrow); + + { Special case for first column } + thiscolsum := GETJSAMPLE(inptr0^) * 3 + GETJSAMPLE(inptr1^); + Inc(inptr0); + Inc(inptr1); + nextcolsum := GETJSAMPLE(inptr0^) * 3 + GETJSAMPLE(inptr1^); + Inc(inptr0); + Inc(inptr1); + + outptr^ := JSAMPLE ((thiscolsum * 4 + 8) shr 4); + Inc(outptr); + outptr^ := JSAMPLE ((thiscolsum * 3 + nextcolsum + 7) shr 4); + Inc(outptr); + lastcolsum := thiscolsum; thiscolsum := nextcolsum; + + for colctr := pred(compptr^.downsampled_width - 2) downto 0 do + begin + { General case: 3/4 * nearer pixel + 1/4 * further pixel in each } + { dimension, thus 9/16, 3/16, 3/16, 1/16 overall } + nextcolsum := GETJSAMPLE(inptr0^) * 3 + GETJSAMPLE(inptr1^); + Inc(inptr0); + Inc(inptr1); + outptr^ := JSAMPLE ((thiscolsum * 3 + lastcolsum + 8) shr 4); + Inc(outptr); + outptr^ := JSAMPLE ((thiscolsum * 3 + nextcolsum + 7) shr 4); + Inc(outptr); + lastcolsum := thiscolsum; + thiscolsum := nextcolsum; + end; + + { Special case for last column } + outptr^ := JSAMPLE ((thiscolsum * 3 + lastcolsum + 8) shr 4); + Inc(outptr); + outptr^ := JSAMPLE ((thiscolsum * 4 + 7) shr 4); + {Inc(outptr); - value never used } + end; + Inc(inrow); + end; +end; + + +{ Module initialization routine for upsampling. } + +{GLOBAL} +procedure jinit_upsampler (cinfo : j_decompress_ptr); +var + upsample : my_upsample_ptr; + ci : int; + compptr : jpeg_component_info_ptr; + need_buffer, do_fancy : boolean; + h_in_group, v_in_group, h_out_group, v_out_group : int; +begin + upsample := my_upsample_ptr ( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_upsampler)) ); + cinfo^.upsample := jpeg_upsampler_ptr (upsample); + upsample^.pub.start_pass := start_pass_upsample; + upsample^.pub.upsample := sep_upsample; + upsample^.pub.need_context_rows := FALSE; { until we find out differently } + + if (cinfo^.CCIR601_sampling) then { this isn't supported } + ERREXIT(j_common_ptr(cinfo), JERR_CCIR601_NOTIMPL); + + { jdmainct.c doesn't support context rows when min_DCT_scaled_size := 1, + so don't ask for it. } + + do_fancy := cinfo^.do_fancy_upsampling and (cinfo^.min_DCT_scaled_size > 1); + + { Verify we can handle the sampling factors, select per-component methods, + and create storage as needed. } + + compptr := jpeg_component_info_ptr(cinfo^.comp_info); + for ci := 0 to pred(cinfo^.num_components) do + begin + { Compute size of an "input group" after IDCT scaling. This many samples + are to be converted to max_h_samp_factor * max_v_samp_factor pixels. } + + h_in_group := (compptr^.h_samp_factor * compptr^.DCT_scaled_size) div + cinfo^.min_DCT_scaled_size; + v_in_group := (compptr^.v_samp_factor * compptr^.DCT_scaled_size) div + cinfo^.min_DCT_scaled_size; + h_out_group := cinfo^.max_h_samp_factor; + v_out_group := cinfo^.max_v_samp_factor; + upsample^.rowgroup_height[ci] := v_in_group; { save for use later } + need_buffer := TRUE; + if (not compptr^.component_needed) then + begin + { Don't bother to upsample an uninteresting component. } + upsample^.methods[ci] := noop_upsample; + need_buffer := FALSE; + end + else + if (h_in_group = h_out_group) and (v_in_group = v_out_group) then + begin + { Fullsize components can be processed without any work. } + upsample^.methods[ci] := fullsize_upsample; + need_buffer := FALSE; + end + else + if (h_in_group * 2 = h_out_group) and + (v_in_group = v_out_group) then + begin + { Special cases for 2h1v upsampling } + if (do_fancy) and (compptr^.downsampled_width > 2) then + upsample^.methods[ci] := h2v1_fancy_upsample + else + upsample^.methods[ci] := h2v1_upsample; + end + else + if (h_in_group * 2 = h_out_group) and + (v_in_group * 2 = v_out_group) then + begin + { Special cases for 2h2v upsampling } + if (do_fancy) and (compptr^.downsampled_width > 2) then + begin + upsample^.methods[ci] := h2v2_fancy_upsample; + upsample^.pub.need_context_rows := TRUE; + end + else + upsample^.methods[ci] := h2v2_upsample; + end + else + if ((h_out_group mod h_in_group) = 0) and + ((v_out_group mod v_in_group) = 0) then + begin + { Generic integral-factors upsampling method } + upsample^.methods[ci] := int_upsample; + upsample^.h_expand[ci] := UINT8 (h_out_group div h_in_group); + upsample^.v_expand[ci] := UINT8 (v_out_group div v_in_group); + end + else + ERREXIT(j_common_ptr(cinfo), JERR_FRACT_SAMPLE_NOTIMPL); + if (need_buffer) then + begin + upsample^.color_buf[ci] := cinfo^.mem^.alloc_sarray + (j_common_ptr(cinfo), JPOOL_IMAGE, + JDIMENSION (jround_up( long (cinfo^.output_width), + long (cinfo^.max_h_samp_factor))), + JDIMENSION (cinfo^.max_v_samp_factor)); + end; + Inc(compptr); + end; +end; + +end. diff --git a/Imaging/JpegLib/imjerror.pas b/Imaging/JpegLib/imjerror.pas index 9a95e6d..cb06a1d 100644 --- a/Imaging/JpegLib/imjerror.pas +++ b/Imaging/JpegLib/imjerror.pas @@ -1,462 +1,462 @@ -unit imjerror; - -{ This file contains simple error-reporting and trace-message routines. - These are suitable for Unix-like systems and others where writing to - stderr is the right thing to do. Many applications will want to replace - some or all of these routines. - - These routines are used by both the compression and decompression code. } - -{ Source: jerror.c; Copyright (C) 1991-1996, Thomas G. Lane. } -{ note: format_message still contains a hack } -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjdeferr, - imjpeglib; -{ - jversion; -} - -const - EXIT_FAILURE = 1; { define halt() codes if not provided } - -{GLOBAL} -function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr; - - - -procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE); - -procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt); - -procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : int; p2 : int); - -procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int); - -procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int; p4 : int); - -procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE; - str : string); -{ Nonfatal errors (we can keep going, but the data is probably corrupt) } - -procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE); - -procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int); - -procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; - p1 : int; p2 : int); - -{ Informational/debugging messages } -procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE); - -procedure TRACEMS1(cinfo : j_common_ptr; lvl : int; - code : J_MESSAGE_CODE; p1 : long); - -procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; - p1 : int; - p2 : int); - -procedure TRACEMS3(cinfo : j_common_ptr; - lvl : int; - code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int); - -procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int; p4 : int); - -procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int; p4 : int; p5 : int); - -procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int; p4 : int; - p5 : int; p6 : int; p7 : int; p8 : int); - -procedure TRACEMSS(cinfo : j_common_ptr; lvl : int; - code : J_MESSAGE_CODE; str : string); - -implementation - - -{ How to format a message string, in format_message() ? } - -{$IFDEF OS2} - {$DEFINE NO_FORMAT} -{$ENDIF} -{$IFDEF FPC} - {$DEFINE NO_FORMAT} -{$ENDIF} - -uses -{$IFNDEF NO_FORMAT} - {$IFDEF VER70} - drivers, { Turbo Vision unit with FormatStr } - {$ELSE} - sysutils, { Delphi Unit with Format() } - {$ENDIF} -{$ENDIF} - imjcomapi; - -{ Error exit handler: must not return to caller. - - Applications may override this if they want to get control back after - an error. Typically one would longjmp somewhere instead of exiting. - The setjmp buffer can be made a private field within an expanded error - handler object. Note that the info needed to generate an error message - is stored in the error object, so you can generate the message now or - later, at your convenience. - You should make sure that the JPEG object is cleaned up (with jpeg_abort - or jpeg_destroy) at some point. } - - -{METHODDEF} -procedure error_exit (cinfo : j_common_ptr); -begin - { Always display the message } - cinfo^.err^.output_message(cinfo); - - { Let the memory manager delete any temp files before we die } - jpeg_destroy(cinfo); - - halt(EXIT_FAILURE); -end; - - -{ Actual output of an error or trace message. - Applications may override this method to send JPEG messages somewhere - other than stderr. } - -{ Macros to simplify using the error and trace message stuff } -{ The first parameter is either type of cinfo pointer } - -{ Fatal errors (print message and exit) } -procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.error_exit(cinfo); -end; - -procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.msg_parm.i[0] := p1; - cinfo^.err^.error_exit (cinfo); -end; - -procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; - p1 : int; p2 : int); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.msg_parm.i[0] := p1; - cinfo^.err^.msg_parm.i[1] := p2; - cinfo^.err^.error_exit (cinfo); -end; - -procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.msg_parm.i[0] := p1; - cinfo^.err^.msg_parm.i[1] := p2; - cinfo^.err^.msg_parm.i[2] := p3; - cinfo^.err^.error_exit (cinfo); -end; - -procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int; p4 : int); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.msg_parm.i[0] := p1; - cinfo^.err^.msg_parm.i[1] := p2; - cinfo^.err^.msg_parm.i[2] := p3; - cinfo^.err^.msg_parm.i[3] := p4; - cinfo^.err^.error_exit (cinfo); -end; - -procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE; - str : string); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] } - cinfo^.err^.error_exit (cinfo); -end; - -{ Nonfatal errors (we can keep going, but the data is probably corrupt) } - -procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.emit_message(cinfo, -1); -end; - -procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.msg_parm.i[0] := p1; - cinfo^.err^.emit_message (cinfo, -1); -end; - -procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; - p1 : int; p2 : int); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.msg_parm.i[0] := p1; - cinfo^.err^.msg_parm.i[1] := p2; - cinfo^.err^.emit_message (cinfo, -1); -end; - -{ Informational/debugging messages } -procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.emit_message(cinfo, lvl); -end; - -procedure TRACEMS1(cinfo : j_common_ptr; lvl : int; - code : J_MESSAGE_CODE; p1 : long); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.msg_parm.i[0] := p1; - cinfo^.err^.emit_message (cinfo, lvl); -end; - -procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; - p1 : int; - p2 : int); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.msg_parm.i[0] := p1; - cinfo^.err^.msg_parm.i[1] := p2; - cinfo^.err^.emit_message (cinfo, lvl); -end; - -procedure TRACEMS3(cinfo : j_common_ptr; - lvl : int; - code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int); -var - _mp : int8array; -begin - _mp[0] := p1; _mp[1] := p2; _mp[2] := p3; - cinfo^.err^.msg_parm.i := _mp; - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.emit_message (cinfo, lvl); -end; - - -procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int; p4 : int); -var - _mp : int8array; -begin - _mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4; - cinfo^.err^.msg_parm.i := _mp; - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.emit_message (cinfo, lvl); -end; - -procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int; p4 : int; p5 : int); -var - _mp : ^int8array; -begin - _mp := @cinfo^.err^.msg_parm.i; - _mp^[0] := p1; _mp^[1] := p2; _mp^[2] := p3; - _mp^[3] := p4; _mp^[5] := p5; - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.emit_message (cinfo, lvl); -end; - -procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; - p1 : int; p2 : int; p3 : int; p4 : int; - p5 : int; p6 : int; p7 : int; p8 : int); -var - _mp : int8array; -begin - _mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4; - _mp[4] := p5; _mp[5] := p6; _mp[6] := p7; _mp[7] := p8; - cinfo^.err^.msg_parm.i := _mp; - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.emit_message (cinfo, lvl); -end; - -procedure TRACEMSS(cinfo : j_common_ptr; lvl : int; - code : J_MESSAGE_CODE; str : string); -begin - cinfo^.err^.msg_code := ord(code); - cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX } - cinfo^.err^.emit_message (cinfo, lvl); -end; - -{METHODDEF} -procedure output_message (cinfo : j_common_ptr); -var - buffer : string; {[JMSG_LENGTH_MAX];} -begin - { Create the message } - cinfo^.err^.format_message (cinfo, buffer); - - { Send it to stderr, adding a newline } - WriteLn(output, buffer); -end; - - - -{ Decide whether to emit a trace or warning message. - msg_level is one of: - -1: recoverable corrupt-data warning, may want to abort. - 0: important advisory messages (always display to user). - 1: first level of tracing detail. - 2,3,...: successively more detailed tracing messages. - An application might override this method if it wanted to abort on warnings - or change the policy about which messages to display. } - - -{METHODDEF} -procedure emit_message (cinfo : j_common_ptr; msg_level : int); -var - err : jpeg_error_mgr_ptr; -begin - err := cinfo^.err; - if (msg_level < 0) then - begin - { It's a warning message. Since corrupt files may generate many warnings, - the policy implemented here is to show only the first warning, - unless trace_level >= 3. } - - if (err^.num_warnings = 0) or (err^.trace_level >= 3) then - err^.output_message(cinfo); - { Always count warnings in num_warnings. } - Inc( err^.num_warnings ); - end - else - begin - { It's a trace message. Show it if trace_level >= msg_level. } - if (err^.trace_level >= msg_level) then - err^.output_message (cinfo); - end; -end; - - -{ Format a message string for the most recent JPEG error or message. - The message is stored into buffer, which should be at least JMSG_LENGTH_MAX - characters. Note that no '\n' character is added to the string. - Few applications should need to override this method. } - - -{METHODDEF} -procedure format_message (cinfo : j_common_ptr; var buffer : string); -var - err : jpeg_error_mgr_ptr; - msg_code : J_MESSAGE_CODE; - msgtext : string; - isstring : boolean; -begin - err := cinfo^.err; - msg_code := J_MESSAGE_CODE(err^.msg_code); - msgtext := ''; - - { Look up message string in proper table } - if (msg_code > JMSG_NOMESSAGE) - and (msg_code <= J_MESSAGE_CODE(err^.last_jpeg_message)) then - begin - msgtext := err^.jpeg_message_table^[msg_code]; - end - else - if (err^.addon_message_table <> NIL) and - (msg_code >= err^.first_addon_message) and - (msg_code <= err^.last_addon_message) then - begin - msgtext := err^.addon_message_table^[J_MESSAGE_CODE - (ord(msg_code) - ord(err^.first_addon_message))]; - end; - - { Defend against bogus message number } - if (msgtext = '') then - begin - err^.msg_parm.i[0] := int(msg_code); - msgtext := err^.jpeg_message_table^[JMSG_NOMESSAGE]; - end; - - { Check for string parameter, as indicated by %s in the message text } - isstring := Pos('%s', msgtext) > 0; - - { Format the message into the passed buffer } - if (isstring) then - buffer := Concat(msgtext, err^.msg_parm.s) - else - begin - {$IFDEF VER70} - FormatStr(buffer, msgtext, err^.msg_parm.i); - {$ELSE} - {$IFDEF NO_FORMAT} - buffer := msgtext; - {$ELSE} - buffer := Format(msgtext, [ - err^.msg_parm.i[0], err^.msg_parm.i[1], - err^.msg_parm.i[2], err^.msg_parm.i[3], - err^.msg_parm.i[4], err^.msg_parm.i[5], - err^.msg_parm.i[6], err^.msg_parm.i[7] ]); - {$ENDIF} - {$ENDIF} - end; -end; - - - -{ Reset error state variables at start of a new image. - This is called during compression startup to reset trace/error - processing to default state, without losing any application-specific - method pointers. An application might possibly want to override - this method if it has additional error processing state. } - - -{METHODDEF} -procedure reset_error_mgr (cinfo : j_common_ptr); -begin - cinfo^.err^.num_warnings := 0; - { trace_level is not reset since it is an application-supplied parameter } - cinfo^.err^.msg_code := 0; { may be useful as a flag for "no error" } -end; - - -{ Fill in the standard error-handling methods in a jpeg_error_mgr object. - Typical call is: - cinfo : jpeg_compress_struct; - err : jpeg_error_mgr; - - cinfo.err := jpeg_std_error(@err); - after which the application may override some of the methods. } - - -{GLOBAL} -function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr; -begin - err.error_exit := error_exit; - err.emit_message := emit_message; - err.output_message := output_message; - err.format_message := format_message; - err.reset_error_mgr := reset_error_mgr; - - err.trace_level := 0; { default := no tracing } - err.num_warnings := 0; { no warnings emitted yet } - err.msg_code := 0; { may be useful as a flag for "no error" } - - { Initialize message table pointers } - err.jpeg_message_table := @jpeg_std_message_table; - err.last_jpeg_message := pred(JMSG_LASTMSGCODE); - - err.addon_message_table := NIL; - err.first_addon_message := JMSG_NOMESSAGE; { for safety } - err.last_addon_message := JMSG_NOMESSAGE; - - jpeg_std_error := @err; -end; - - -end. +unit imjerror; + +{ This file contains simple error-reporting and trace-message routines. + These are suitable for Unix-like systems and others where writing to + stderr is the right thing to do. Many applications will want to replace + some or all of these routines. + + These routines are used by both the compression and decompression code. } + +{ Source: jerror.c; Copyright (C) 1991-1996, Thomas G. Lane. } +{ note: format_message still contains a hack } +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjdeferr, + imjpeglib; +{ + jversion; +} + +const + EXIT_FAILURE = 1; { define halt() codes if not provided } + +{GLOBAL} +function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr; + + + +procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE); + +procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt); + +procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : int; p2 : int); + +procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int); + +procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int; p4 : int); + +procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE; + str : AnsiString); +{ Nonfatal errors (we can keep going, but the data is probably corrupt) } + +procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE); + +procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int); + +procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; + p1 : int; p2 : int); + +{ Informational/debugging messages } +procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE); + +procedure TRACEMS1(cinfo : j_common_ptr; lvl : int; + code : J_MESSAGE_CODE; p1 : long); + +procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; + p1 : int; + p2 : int); + +procedure TRACEMS3(cinfo : j_common_ptr; + lvl : int; + code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int); + +procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int; p4 : int); + +procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int; p4 : int; p5 : int); + +procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int; p4 : int; + p5 : int; p6 : int; p7 : int; p8 : int); + +procedure TRACEMSS(cinfo : j_common_ptr; lvl : int; + code : J_MESSAGE_CODE; str : AnsiString); + +implementation + + +{ How to format a message string, in format_message() ? } + +{$IFDEF OS2} + {$DEFINE NO_FORMAT} +{$ENDIF} +{$IFDEF FPC} + {$DEFINE NO_FORMAT} +{$ENDIF} + +uses +{$IFNDEF NO_FORMAT} + {$IFDEF VER70} + drivers, { Turbo Vision unit with FormatStr } + {$ELSE} + sysutils, { Delphi Unit with Format() } + {$ENDIF} +{$ENDIF} + imjcomapi; + +{ Error exit handler: must not return to caller. + + Applications may override this if they want to get control back after + an error. Typically one would longjmp somewhere instead of exiting. + The setjmp buffer can be made a private field within an expanded error + handler object. Note that the info needed to generate an error message + is stored in the error object, so you can generate the message now or + later, at your convenience. + You should make sure that the JPEG object is cleaned up (with jpeg_abort + or jpeg_destroy) at some point. } + + +{METHODDEF} +procedure error_exit (cinfo : j_common_ptr); +begin + { Always display the message } + cinfo^.err^.output_message(cinfo); + + { Let the memory manager delete any temp files before we die } + jpeg_destroy(cinfo); + + halt(EXIT_FAILURE); +end; + + +{ Actual output of an error or trace message. + Applications may override this method to send JPEG messages somewhere + other than stderr. } + +{ Macros to simplify using the error and trace message stuff } +{ The first parameter is either type of cinfo pointer } + +{ Fatal errors (print message and exit) } +procedure ERREXIT(cinfo : j_common_ptr; code : J_MESSAGE_CODE); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.error_exit(cinfo); +end; + +procedure ERREXIT1(cinfo : j_common_ptr; code : J_MESSAGE_CODE; p1 : uInt); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.msg_parm.i[0] := p1; + cinfo^.err^.error_exit (cinfo); +end; + +procedure ERREXIT2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; + p1 : int; p2 : int); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.msg_parm.i[0] := p1; + cinfo^.err^.msg_parm.i[1] := p2; + cinfo^.err^.error_exit (cinfo); +end; + +procedure ERREXIT3(cinfo : j_common_ptr; code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.msg_parm.i[0] := p1; + cinfo^.err^.msg_parm.i[1] := p2; + cinfo^.err^.msg_parm.i[2] := p3; + cinfo^.err^.error_exit (cinfo); +end; + +procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int; p4 : int); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.msg_parm.i[0] := p1; + cinfo^.err^.msg_parm.i[1] := p2; + cinfo^.err^.msg_parm.i[2] := p3; + cinfo^.err^.msg_parm.i[3] := p4; + cinfo^.err^.error_exit (cinfo); +end; + +procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE; + str : AnsiString); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] } + cinfo^.err^.error_exit (cinfo); +end; + +{ Nonfatal errors (we can keep going, but the data is probably corrupt) } + +procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.emit_message(cinfo, -1); +end; + +procedure WARNMS1(cinfo : j_common_ptr;code : J_MESSAGE_CODE; p1 : int); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.msg_parm.i[0] := p1; + cinfo^.err^.emit_message (cinfo, -1); +end; + +procedure WARNMS2(cinfo : j_common_ptr; code : J_MESSAGE_CODE; + p1 : int; p2 : int); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.msg_parm.i[0] := p1; + cinfo^.err^.msg_parm.i[1] := p2; + cinfo^.err^.emit_message (cinfo, -1); +end; + +{ Informational/debugging messages } +procedure TRACEMS(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.emit_message(cinfo, lvl); +end; + +procedure TRACEMS1(cinfo : j_common_ptr; lvl : int; + code : J_MESSAGE_CODE; p1 : long); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.msg_parm.i[0] := p1; + cinfo^.err^.emit_message (cinfo, lvl); +end; + +procedure TRACEMS2(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; + p1 : int; + p2 : int); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.msg_parm.i[0] := p1; + cinfo^.err^.msg_parm.i[1] := p2; + cinfo^.err^.emit_message (cinfo, lvl); +end; + +procedure TRACEMS3(cinfo : j_common_ptr; + lvl : int; + code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int); +var + _mp : int8array; +begin + _mp[0] := p1; _mp[1] := p2; _mp[2] := p3; + cinfo^.err^.msg_parm.i := _mp; + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.emit_message (cinfo, lvl); +end; + + +procedure TRACEMS4(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int; p4 : int); +var + _mp : int8array; +begin + _mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4; + cinfo^.err^.msg_parm.i := _mp; + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.emit_message (cinfo, lvl); +end; + +procedure TRACEMS5(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int; p4 : int; p5 : int); +var + _mp : ^int8array; +begin + _mp := @cinfo^.err^.msg_parm.i; + _mp^[0] := p1; _mp^[1] := p2; _mp^[2] := p3; + _mp^[3] := p4; _mp^[5] := p5; + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.emit_message (cinfo, lvl); +end; + +procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE; + p1 : int; p2 : int; p3 : int; p4 : int; + p5 : int; p6 : int; p7 : int; p8 : int); +var + _mp : int8array; +begin + _mp[0] := p1; _mp[1] := p2; _mp[2] := p3; _mp[3] := p4; + _mp[4] := p5; _mp[5] := p6; _mp[6] := p7; _mp[7] := p8; + cinfo^.err^.msg_parm.i := _mp; + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.emit_message (cinfo, lvl); +end; + +procedure TRACEMSS(cinfo : j_common_ptr; lvl : int; + code : J_MESSAGE_CODE; str : AnsiString); +begin + cinfo^.err^.msg_code := ord(code); + cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX } + cinfo^.err^.emit_message (cinfo, lvl); +end; + +{METHODDEF} +procedure output_message (cinfo : j_common_ptr); +var + buffer : AnsiString; {[JMSG_LENGTH_MAX];} +begin + { Create the message } + cinfo^.err^.format_message (cinfo, buffer); + + { Send it to stderr, adding a newline } + WriteLn(output, buffer); +end; + + + +{ Decide whether to emit a trace or warning message. + msg_level is one of: + -1: recoverable corrupt-data warning, may want to abort. + 0: important advisory messages (always display to user). + 1: first level of tracing detail. + 2,3,...: successively more detailed tracing messages. + An application might override this method if it wanted to abort on warnings + or change the policy about which messages to display. } + + +{METHODDEF} +procedure emit_message (cinfo : j_common_ptr; msg_level : int); +var + err : jpeg_error_mgr_ptr; +begin + err := cinfo^.err; + if (msg_level < 0) then + begin + { It's a warning message. Since corrupt files may generate many warnings, + the policy implemented here is to show only the first warning, + unless trace_level >= 3. } + + if (err^.num_warnings = 0) or (err^.trace_level >= 3) then + err^.output_message(cinfo); + { Always count warnings in num_warnings. } + Inc( err^.num_warnings ); + end + else + begin + { It's a trace message. Show it if trace_level >= msg_level. } + if (err^.trace_level >= msg_level) then + err^.output_message (cinfo); + end; +end; + + +{ Format a message string for the most recent JPEG error or message. + The message is stored into buffer, which should be at least JMSG_LENGTH_MAX + characters. Note that no '\n' character is added to the string. + Few applications should need to override this method. } + + +{METHODDEF} +procedure format_message (cinfo : j_common_ptr; var buffer : AnsiString); +var + err : jpeg_error_mgr_ptr; + msg_code : J_MESSAGE_CODE; + msgtext : AnsiString; + isstring : boolean; +begin + err := cinfo^.err; + msg_code := J_MESSAGE_CODE(err^.msg_code); + msgtext := ''; + + { Look up message string in proper table } + if (msg_code > JMSG_NOMESSAGE) + and (msg_code <= J_MESSAGE_CODE(err^.last_jpeg_message)) then + begin + msgtext := err^.jpeg_message_table^[msg_code]; + end + else + if (err^.addon_message_table <> NIL) and + (msg_code >= err^.first_addon_message) and + (msg_code <= err^.last_addon_message) then + begin + msgtext := err^.addon_message_table^[J_MESSAGE_CODE + (ord(msg_code) - ord(err^.first_addon_message))]; + end; + + { Defend against bogus message number } + if (msgtext = '') then + begin + err^.msg_parm.i[0] := int(msg_code); + msgtext := err^.jpeg_message_table^[JMSG_NOMESSAGE]; + end; + + { Check for string parameter, as indicated by %s in the message text } + isstring := Pos('%s', msgtext) > 0; + + { Format the message into the passed buffer } + if (isstring) then + buffer := Concat(msgtext, err^.msg_parm.s) + else + begin + {$IFDEF VER70} + FormatStr(buffer, msgtext, err^.msg_parm.i); + {$ELSE} + {$IFDEF NO_FORMAT} + buffer := msgtext; + {$ELSE} + buffer := Format(msgtext, [ + err^.msg_parm.i[0], err^.msg_parm.i[1], + err^.msg_parm.i[2], err^.msg_parm.i[3], + err^.msg_parm.i[4], err^.msg_parm.i[5], + err^.msg_parm.i[6], err^.msg_parm.i[7] ]); + {$ENDIF} + {$ENDIF} + end; +end; + + + +{ Reset error state variables at start of a new image. + This is called during compression startup to reset trace/error + processing to default state, without losing any application-specific + method pointers. An application might possibly want to override + this method if it has additional error processing state. } + + +{METHODDEF} +procedure reset_error_mgr (cinfo : j_common_ptr); +begin + cinfo^.err^.num_warnings := 0; + { trace_level is not reset since it is an application-supplied parameter } + cinfo^.err^.msg_code := 0; { may be useful as a flag for "no error" } +end; + + +{ Fill in the standard error-handling methods in a jpeg_error_mgr object. + Typical call is: + cinfo : jpeg_compress_struct; + err : jpeg_error_mgr; + + cinfo.err := jpeg_std_error(@err); + after which the application may override some of the methods. } + + +{GLOBAL} +function jpeg_std_error (var err : jpeg_error_mgr) : jpeg_error_mgr_ptr; +begin + err.error_exit := error_exit; + err.emit_message := emit_message; + err.output_message := output_message; + err.format_message := format_message; + err.reset_error_mgr := reset_error_mgr; + + err.trace_level := 0; { default := no tracing } + err.num_warnings := 0; { no warnings emitted yet } + err.msg_code := 0; { may be useful as a flag for "no error" } + + { Initialize message table pointers } + err.jpeg_message_table := @jpeg_std_message_table; + err.last_jpeg_message := pred(JMSG_LASTMSGCODE); + + err.addon_message_table := NIL; + err.first_addon_message := JMSG_NOMESSAGE; { for safety } + err.last_addon_message := JMSG_NOMESSAGE; + + jpeg_std_error := @err; +end; + + +end. diff --git a/Imaging/JpegLib/imjfdctflt.pas b/Imaging/JpegLib/imjfdctflt.pas index 28f881b..6b2155d 100644 --- a/Imaging/JpegLib/imjfdctflt.pas +++ b/Imaging/JpegLib/imjfdctflt.pas @@ -1,176 +1,175 @@ -unit imjfdctflt; - -{$N+} -{ This file contains a floating-point implementation of the - forward DCT (Discrete Cosine Transform). - - This implementation should be more accurate than either of the integer - DCT implementations. However, it may not give the same results on all - machines because of differences in roundoff behavior. Speed will depend - on the hardware's floating point capacity. - - A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT - on each column. Direct algorithms are also available, but they are - much more complex and seem not to be any faster when reduced to code. - - This implementation is based on Arai, Agui, and Nakajima's algorithm for - scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in - Japanese, but the algorithm is described in the Pennebaker & Mitchell - JPEG textbook (see REFERENCES section in file README). The following code - is based directly on figure 4-8 in P&M. - While an 8-point DCT cannot be done in less than 11 multiplies, it is - possible to arrange the computation so that many of the multiplies are - simple scalings of the final outputs. These multiplies can then be - folded into the multiplications or divisions by the JPEG quantization - table entries. The AA&N method leaves only 5 multiplies and 29 adds - to be done in the DCT itself. - The primary disadvantage of this method is that with a fixed-point - implementation, accuracy is lost due to imprecise representation of the - scaled quantization values. However, that problem does not arise if - we use floating point arithmetic. } - -{ Original : jfdctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib, - imjdct; { Private declarations for DCT subsystem } - - -{ Perform the forward DCT on one block of samples.} - -{GLOBAL} -procedure jpeg_fdct_float (var data : array of FAST_FLOAT); - -implementation - -{ This module is specialized to the case DCTSIZE = 8. } - -{$ifndef DCTSIZE_IS_8} - Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } -{$endif} - - -{ Perform the forward DCT on one block of samples.} - -{GLOBAL} -procedure jpeg_fdct_float (var data : array of FAST_FLOAT); -type - PWorkspace = ^TWorkspace; - TWorkspace = array [0..DCTSIZE2-1] of FAST_FLOAT; -var - tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT; - tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT; - z1, z2, z3, z4, z5, z11, z13 : FAST_FLOAT; - dataptr : PWorkspace; - ctr : int; -begin - { Pass 1: process rows. } - - dataptr := PWorkspace(@data); - for ctr := DCTSIZE-1 downto 0 do - begin - tmp0 := dataptr^[0] + dataptr^[7]; - tmp7 := dataptr^[0] - dataptr^[7]; - tmp1 := dataptr^[1] + dataptr^[6]; - tmp6 := dataptr^[1] - dataptr^[6]; - tmp2 := dataptr^[2] + dataptr^[5]; - tmp5 := dataptr^[2] - dataptr^[5]; - tmp3 := dataptr^[3] + dataptr^[4]; - tmp4 := dataptr^[3] - dataptr^[4]; - - { Even part } - - tmp10 := tmp0 + tmp3; { phase 2 } - tmp13 := tmp0 - tmp3; - tmp11 := tmp1 + tmp2; - tmp12 := tmp1 - tmp2; - - dataptr^[0] := tmp10 + tmp11; { phase 3 } - dataptr^[4] := tmp10 - tmp11; - - z1 := (tmp12 + tmp13) * ({FAST_FLOAT}(0.707106781)); { c4 } - dataptr^[2] := tmp13 + z1; { phase 5 } - dataptr^[6] := tmp13 - z1; - - { Odd part } - - tmp10 := tmp4 + tmp5; { phase 2 } - tmp11 := tmp5 + tmp6; - tmp12 := tmp6 + tmp7; - - { The rotator is modified from fig 4-8 to avoid extra negations. } - z5 := (tmp10 - tmp12) * ( {FAST_FLOAT}(0.382683433)); { c6 } - z2 := {FAST_FLOAT}(0.541196100) * tmp10 + z5; { c2-c6 } - z4 := {FAST_FLOAT}(1.306562965) * tmp12 + z5; { c2+c6 } - z3 := tmp11 * {FAST_FLOAT} (0.707106781); { c4 } - - z11 := tmp7 + z3; { phase 5 } - z13 := tmp7 - z3; - - dataptr^[5] := z13 + z2; { phase 6 } - dataptr^[3] := z13 - z2; - dataptr^[1] := z11 + z4; - dataptr^[7] := z11 - z4; - - Inc(FAST_FLOAT_PTR(dataptr), DCTSIZE); { advance pointer to next row } - end; - - { Pass 2: process columns. } - - dataptr := PWorkspace(@data); - for ctr := DCTSIZE-1 downto 0 do - begin - tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7]; - tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7]; - tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6]; - tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6]; - tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5]; - tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5]; - tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4]; - tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4]; - - { Even part } - - tmp10 := tmp0 + tmp3; { phase 2 } - tmp13 := tmp0 - tmp3; - tmp11 := tmp1 + tmp2; - tmp12 := tmp1 - tmp2; - - dataptr^[DCTSIZE*0] := tmp10 + tmp11; { phase 3 } - dataptr^[DCTSIZE*4] := tmp10 - tmp11; - - z1 := (tmp12 + tmp13) * {FAST_FLOAT} (0.707106781); { c4 } - dataptr^[DCTSIZE*2] := tmp13 + z1; { phase 5 } - dataptr^[DCTSIZE*6] := tmp13 - z1; - - { Odd part } - - tmp10 := tmp4 + tmp5; { phase 2 } - tmp11 := tmp5 + tmp6; - tmp12 := tmp6 + tmp7; - - { The rotator is modified from fig 4-8 to avoid extra negations. } - z5 := (tmp10 - tmp12) * {FAST_FLOAT} (0.382683433); { c6 } - z2 := {FAST_FLOAT} (0.541196100) * tmp10 + z5; { c2-c6 } - z4 := {FAST_FLOAT} (1.306562965) * tmp12 + z5; { c2+c6 } - z3 := tmp11 * {FAST_FLOAT} (0.707106781); { c4 } - - z11 := tmp7 + z3; { phase 5 } - z13 := tmp7 - z3; - - dataptr^[DCTSIZE*5] := z13 + z2; { phase 6 } - dataptr^[DCTSIZE*3] := z13 - z2; - dataptr^[DCTSIZE*1] := z11 + z4; - dataptr^[DCTSIZE*7] := z11 - z4; - - Inc(FAST_FLOAT_PTR(dataptr)); { advance pointer to next column } - end; -end; - -end. +unit imjfdctflt; + +{ This file contains a floating-point implementation of the + forward DCT (Discrete Cosine Transform). + + This implementation should be more accurate than either of the integer + DCT implementations. However, it may not give the same results on all + machines because of differences in roundoff behavior. Speed will depend + on the hardware's floating point capacity. + + A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT + on each column. Direct algorithms are also available, but they are + much more complex and seem not to be any faster when reduced to code. + + This implementation is based on Arai, Agui, and Nakajima's algorithm for + scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in + Japanese, but the algorithm is described in the Pennebaker & Mitchell + JPEG textbook (see REFERENCES section in file README). The following code + is based directly on figure 4-8 in P&M. + While an 8-point DCT cannot be done in less than 11 multiplies, it is + possible to arrange the computation so that many of the multiplies are + simple scalings of the final outputs. These multiplies can then be + folded into the multiplications or divisions by the JPEG quantization + table entries. The AA&N method leaves only 5 multiplies and 29 adds + to be done in the DCT itself. + The primary disadvantage of this method is that with a fixed-point + implementation, accuracy is lost due to imprecise representation of the + scaled quantization values. However, that problem does not arise if + we use floating point arithmetic. } + +{ Original : jfdctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib, + imjdct; { Private declarations for DCT subsystem } + + +{ Perform the forward DCT on one block of samples.} + +{GLOBAL} +procedure jpeg_fdct_float (var data : array of FAST_FLOAT); + +implementation + +{ This module is specialized to the case DCTSIZE = 8. } + +{$ifndef DCTSIZE_IS_8} + Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } +{$endif} + + +{ Perform the forward DCT on one block of samples.} + +{GLOBAL} +procedure jpeg_fdct_float (var data : array of FAST_FLOAT); +type + PWorkspace = ^TWorkspace; + TWorkspace = array [0..DCTSIZE2-1] of FAST_FLOAT; +var + tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT; + tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT; + z1, z2, z3, z4, z5, z11, z13 : FAST_FLOAT; + dataptr : PWorkspace; + ctr : int; +begin + { Pass 1: process rows. } + + dataptr := PWorkspace(@data); + for ctr := DCTSIZE-1 downto 0 do + begin + tmp0 := dataptr^[0] + dataptr^[7]; + tmp7 := dataptr^[0] - dataptr^[7]; + tmp1 := dataptr^[1] + dataptr^[6]; + tmp6 := dataptr^[1] - dataptr^[6]; + tmp2 := dataptr^[2] + dataptr^[5]; + tmp5 := dataptr^[2] - dataptr^[5]; + tmp3 := dataptr^[3] + dataptr^[4]; + tmp4 := dataptr^[3] - dataptr^[4]; + + { Even part } + + tmp10 := tmp0 + tmp3; { phase 2 } + tmp13 := tmp0 - tmp3; + tmp11 := tmp1 + tmp2; + tmp12 := tmp1 - tmp2; + + dataptr^[0] := tmp10 + tmp11; { phase 3 } + dataptr^[4] := tmp10 - tmp11; + + z1 := (tmp12 + tmp13) * ({FAST_FLOAT}(0.707106781)); { c4 } + dataptr^[2] := tmp13 + z1; { phase 5 } + dataptr^[6] := tmp13 - z1; + + { Odd part } + + tmp10 := tmp4 + tmp5; { phase 2 } + tmp11 := tmp5 + tmp6; + tmp12 := tmp6 + tmp7; + + { The rotator is modified from fig 4-8 to avoid extra negations. } + z5 := (tmp10 - tmp12) * ( {FAST_FLOAT}(0.382683433)); { c6 } + z2 := {FAST_FLOAT}(0.541196100) * tmp10 + z5; { c2-c6 } + z4 := {FAST_FLOAT}(1.306562965) * tmp12 + z5; { c2+c6 } + z3 := tmp11 * {FAST_FLOAT} (0.707106781); { c4 } + + z11 := tmp7 + z3; { phase 5 } + z13 := tmp7 - z3; + + dataptr^[5] := z13 + z2; { phase 6 } + dataptr^[3] := z13 - z2; + dataptr^[1] := z11 + z4; + dataptr^[7] := z11 - z4; + + Inc(FAST_FLOAT_PTR(dataptr), DCTSIZE); { advance pointer to next row } + end; + + { Pass 2: process columns. } + + dataptr := PWorkspace(@data); + for ctr := DCTSIZE-1 downto 0 do + begin + tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7]; + tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7]; + tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6]; + tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6]; + tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5]; + tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5]; + tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4]; + tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4]; + + { Even part } + + tmp10 := tmp0 + tmp3; { phase 2 } + tmp13 := tmp0 - tmp3; + tmp11 := tmp1 + tmp2; + tmp12 := tmp1 - tmp2; + + dataptr^[DCTSIZE*0] := tmp10 + tmp11; { phase 3 } + dataptr^[DCTSIZE*4] := tmp10 - tmp11; + + z1 := (tmp12 + tmp13) * {FAST_FLOAT} (0.707106781); { c4 } + dataptr^[DCTSIZE*2] := tmp13 + z1; { phase 5 } + dataptr^[DCTSIZE*6] := tmp13 - z1; + + { Odd part } + + tmp10 := tmp4 + tmp5; { phase 2 } + tmp11 := tmp5 + tmp6; + tmp12 := tmp6 + tmp7; + + { The rotator is modified from fig 4-8 to avoid extra negations. } + z5 := (tmp10 - tmp12) * {FAST_FLOAT} (0.382683433); { c6 } + z2 := {FAST_FLOAT} (0.541196100) * tmp10 + z5; { c2-c6 } + z4 := {FAST_FLOAT} (1.306562965) * tmp12 + z5; { c2+c6 } + z3 := tmp11 * {FAST_FLOAT} (0.707106781); { c4 } + + z11 := tmp7 + z3; { phase 5 } + z13 := tmp7 - z3; + + dataptr^[DCTSIZE*5] := z13 + z2; { phase 6 } + dataptr^[DCTSIZE*3] := z13 - z2; + dataptr^[DCTSIZE*1] := z11 + z4; + dataptr^[DCTSIZE*7] := z11 - z4; + + Inc(FAST_FLOAT_PTR(dataptr)); { advance pointer to next column } + end; +end; + +end. diff --git a/Imaging/JpegLib/imjfdctfst.pas b/Imaging/JpegLib/imjfdctfst.pas index 51e4bc6..0569282 100644 --- a/Imaging/JpegLib/imjfdctfst.pas +++ b/Imaging/JpegLib/imjfdctfst.pas @@ -1,237 +1,237 @@ -unit imjfdctfst; - -{ This file contains a fast, not so accurate integer implementation of the - forward DCT (Discrete Cosine Transform). - - A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT - on each column. Direct algorithms are also available, but they are - much more complex and seem not to be any faster when reduced to code. - - This implementation is based on Arai, Agui, and Nakajima's algorithm for - scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in - Japanese, but the algorithm is described in the Pennebaker & Mitchell - JPEG textbook (see REFERENCES section in file README). The following code - is based directly on figure 4-8 in P&M. - While an 8-point DCT cannot be done in less than 11 multiplies, it is - possible to arrange the computation so that many of the multiplies are - simple scalings of the final outputs. These multiplies can then be - folded into the multiplications or divisions by the JPEG quantization - table entries. The AA&N method leaves only 5 multiplies and 29 adds - to be done in the DCT itself. - The primary disadvantage of this method is that with fixed-point math, - accuracy is lost due to imprecise representation of the scaled - quantization values. The smaller the quantization table entry, the less - precise the scaled value, so this implementation does worse with high- - quality-setting files than with low-quality ones. } - -{ Original: jfdctfst.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib, - imjdct; { Private declarations for DCT subsystem } - - -{ Perform the forward DCT on one block of samples. } - -{GLOBAL} -procedure jpeg_fdct_ifast (var data : array of DCTELEM); - -implementation - -{ This module is specialized to the case DCTSIZE = 8. } - -{$ifndef DCTSIZE_IS_8} - Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } -{$endif} - - -{ Scaling decisions are generally the same as in the LL&M algorithm; - see jfdctint.c for more details. However, we choose to descale - (right shift) multiplication products as soon as they are formed, - rather than carrying additional fractional bits into subsequent additions. - This compromises accuracy slightly, but it lets us save a few shifts. - More importantly, 16-bit arithmetic is then adequate (for 8-bit samples) - everywhere except in the multiplications proper; this saves a good deal - of work on 16-bit-int machines. - - Again to save a few shifts, the intermediate results between pass 1 and - pass 2 are not upscaled, but are represented only to integral precision. - - A final compromise is to represent the multiplicative constants to only - 8 fractional bits, rather than 13. This saves some shifting work on some - machines, and may also reduce the cost of multiplication (since there - are fewer one-bits in the constants). } - -const - CONST_BITS = 8; -const - CONST_SCALE = (INT32(1) shl CONST_BITS); - - -const - FIX_0_382683433 = INT32(Round(CONST_SCALE * 0.382683433)); {98} - FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {139} - FIX_0_707106781 = INT32(Round(CONST_SCALE * 0.707106781)); {181} - FIX_1_306562965 = INT32(Round(CONST_SCALE * 1.306562965)); {334} - -{ Descale and correctly round an INT32 value that's scaled by N bits. - We assume RIGHT_SHIFT rounds towards minus infinity, so adding - the fudge factor is correct for either sign of X. } - -function DESCALE(x : INT32; n : int) : INT32; -var - shift_temp : INT32; -begin -{ We can gain a little more speed, with a further compromise in accuracy, - by omitting the addition in a descaling shift. This yields an incorrectly - rounded result half the time... } -{$ifndef USE_ACCURATE_ROUNDING} - shift_temp := x; -{$else} - shift_temp := x + (INT32(1) shl (n-1)); -{$endif} - -{$ifdef RIGHT_SHIFT_IS_UNSIGNED} - if shift_temp < 0 then - Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) - else -{$endif} - Descale := (shift_temp shr n); -end; - -{ Multiply a DCTELEM variable by an INT32 constant, and immediately - descale to yield a DCTELEM result. } - - - function MULTIPLY(X : DCTELEM; Y: INT32): DCTELEM; - begin - Multiply := DeScale((X) * (Y), CONST_BITS); - end; - - -{ Perform the forward DCT on one block of samples. } - -{GLOBAL} -procedure jpeg_fdct_ifast (var data : array of DCTELEM); -type - PWorkspace = ^TWorkspace; - TWorkspace = array [0..DCTSIZE2-1] of DCTELEM; -var - tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : DCTELEM; - tmp10, tmp11, tmp12, tmp13 : DCTELEM; - z1, z2, z3, z4, z5, z11, z13 : DCTELEM; - dataptr : PWorkspace; - ctr : int; - {SHIFT_TEMPS} -begin - { Pass 1: process rows. } - - dataptr := PWorkspace(@data); - for ctr := DCTSIZE-1 downto 0 do - begin - tmp0 := dataptr^[0] + dataptr^[7]; - tmp7 := dataptr^[0] - dataptr^[7]; - tmp1 := dataptr^[1] + dataptr^[6]; - tmp6 := dataptr^[1] - dataptr^[6]; - tmp2 := dataptr^[2] + dataptr^[5]; - tmp5 := dataptr^[2] - dataptr^[5]; - tmp3 := dataptr^[3] + dataptr^[4]; - tmp4 := dataptr^[3] - dataptr^[4]; - - { Even part } - - tmp10 := tmp0 + tmp3; { phase 2 } - tmp13 := tmp0 - tmp3; - tmp11 := tmp1 + tmp2; - tmp12 := tmp1 - tmp2; - - dataptr^[0] := tmp10 + tmp11; { phase 3 } - dataptr^[4] := tmp10 - tmp11; - - z1 := MULTIPLY(tmp12 + tmp13, FIX_0_707106781); { c4 } - dataptr^[2] := tmp13 + z1; { phase 5 } - dataptr^[6] := tmp13 - z1; - - { Odd part } - - tmp10 := tmp4 + tmp5; { phase 2 } - tmp11 := tmp5 + tmp6; - tmp12 := tmp6 + tmp7; - - { The rotator is modified from fig 4-8 to avoid extra negations. } - z5 := MULTIPLY(tmp10 - tmp12, FIX_0_382683433); { c6 } - z2 := MULTIPLY(tmp10, FIX_0_541196100) + z5; { c2-c6 } - z4 := MULTIPLY(tmp12, FIX_1_306562965) + z5; { c2+c6 } - z3 := MULTIPLY(tmp11, FIX_0_707106781); { c4 } - - z11 := tmp7 + z3; { phase 5 } - z13 := tmp7 - z3; - - dataptr^[5] := z13 + z2; { phase 6 } - dataptr^[3] := z13 - z2; - dataptr^[1] := z11 + z4; - dataptr^[7] := z11 - z4; - - Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row } - end; - - { Pass 2: process columns. } - - dataptr := PWorkspace(@data); - for ctr := DCTSIZE-1 downto 0 do - begin - tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7]; - tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7]; - tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6]; - tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6]; - tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5]; - tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5]; - tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4]; - tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4]; - - { Even part } - - tmp10 := tmp0 + tmp3; { phase 2 } - tmp13 := tmp0 - tmp3; - tmp11 := tmp1 + tmp2; - tmp12 := tmp1 - tmp2; - - dataptr^[DCTSIZE*0] := tmp10 + tmp11; { phase 3 } - dataptr^[DCTSIZE*4] := tmp10 - tmp11; - - z1 := MULTIPLY(tmp12 + tmp13, FIX_0_707106781); { c4 } - dataptr^[DCTSIZE*2] := tmp13 + z1; { phase 5 } - dataptr^[DCTSIZE*6] := tmp13 - z1; - - { Odd part } - - tmp10 := tmp4 + tmp5; { phase 2 } - tmp11 := tmp5 + tmp6; - tmp12 := tmp6 + tmp7; - - { The rotator is modified from fig 4-8 to avoid extra negations. } - z5 := MULTIPLY(tmp10 - tmp12, FIX_0_382683433); { c6 } - z2 := MULTIPLY(tmp10, FIX_0_541196100) + z5; { c2-c6 } - z4 := MULTIPLY(tmp12, FIX_1_306562965) + z5; { c2+c6 } - z3 := MULTIPLY(tmp11, FIX_0_707106781); { c4 } - - z11 := tmp7 + z3; { phase 5 } - z13 := tmp7 - z3; - - dataptr^[DCTSIZE*5] := z13 + z2; { phase 6 } - dataptr^[DCTSIZE*3] := z13 - z2; - dataptr^[DCTSIZE*1] := z11 + z4; - dataptr^[DCTSIZE*7] := z11 - z4; - - Inc(DCTELEMPTR(dataptr)); { advance pointer to next column } - end; -end; - -end. +unit imjfdctfst; + +{ This file contains a fast, not so accurate integer implementation of the + forward DCT (Discrete Cosine Transform). + + A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT + on each column. Direct algorithms are also available, but they are + much more complex and seem not to be any faster when reduced to code. + + This implementation is based on Arai, Agui, and Nakajima's algorithm for + scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in + Japanese, but the algorithm is described in the Pennebaker & Mitchell + JPEG textbook (see REFERENCES section in file README). The following code + is based directly on figure 4-8 in P&M. + While an 8-point DCT cannot be done in less than 11 multiplies, it is + possible to arrange the computation so that many of the multiplies are + simple scalings of the final outputs. These multiplies can then be + folded into the multiplications or divisions by the JPEG quantization + table entries. The AA&N method leaves only 5 multiplies and 29 adds + to be done in the DCT itself. + The primary disadvantage of this method is that with fixed-point math, + accuracy is lost due to imprecise representation of the scaled + quantization values. The smaller the quantization table entry, the less + precise the scaled value, so this implementation does worse with high- + quality-setting files than with low-quality ones. } + +{ Original: jfdctfst.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib, + imjdct; { Private declarations for DCT subsystem } + + +{ Perform the forward DCT on one block of samples. } + +{GLOBAL} +procedure jpeg_fdct_ifast (var data : array of DCTELEM); + +implementation + +{ This module is specialized to the case DCTSIZE = 8. } + +{$ifndef DCTSIZE_IS_8} + Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } +{$endif} + + +{ Scaling decisions are generally the same as in the LL&M algorithm; + see jfdctint.c for more details. However, we choose to descale + (right shift) multiplication products as soon as they are formed, + rather than carrying additional fractional bits into subsequent additions. + This compromises accuracy slightly, but it lets us save a few shifts. + More importantly, 16-bit arithmetic is then adequate (for 8-bit samples) + everywhere except in the multiplications proper; this saves a good deal + of work on 16-bit-int machines. + + Again to save a few shifts, the intermediate results between pass 1 and + pass 2 are not upscaled, but are represented only to integral precision. + + A final compromise is to represent the multiplicative constants to only + 8 fractional bits, rather than 13. This saves some shifting work on some + machines, and may also reduce the cost of multiplication (since there + are fewer one-bits in the constants). } + +const + CONST_BITS = 8; +const + CONST_SCALE = (INT32(1) shl CONST_BITS); + + +const + FIX_0_382683433 = INT32(Round(CONST_SCALE * 0.382683433)); {98} + FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {139} + FIX_0_707106781 = INT32(Round(CONST_SCALE * 0.707106781)); {181} + FIX_1_306562965 = INT32(Round(CONST_SCALE * 1.306562965)); {334} + +{ Descale and correctly round an INT32 value that's scaled by N bits. + We assume RIGHT_SHIFT rounds towards minus infinity, so adding + the fudge factor is correct for either sign of X. } + +function DESCALE(x : INT32; n : int) : INT32; +var + shift_temp : INT32; +begin +{ We can gain a little more speed, with a further compromise in accuracy, + by omitting the addition in a descaling shift. This yields an incorrectly + rounded result half the time... } +{$ifndef USE_ACCURATE_ROUNDING} + shift_temp := x; +{$else} + shift_temp := x + (INT32(1) shl (n-1)); +{$endif} + +{$ifdef RIGHT_SHIFT_IS_UNSIGNED} + if shift_temp < 0 then + Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) + else +{$endif} + Descale := (shift_temp shr n); +end; + +{ Multiply a DCTELEM variable by an INT32 constant, and immediately + descale to yield a DCTELEM result. } + + + function MULTIPLY(X : DCTELEM; Y: INT32): DCTELEM; + begin + Multiply := DeScale((X) * (Y), CONST_BITS); + end; + + +{ Perform the forward DCT on one block of samples. } + +{GLOBAL} +procedure jpeg_fdct_ifast (var data : array of DCTELEM); +type + PWorkspace = ^TWorkspace; + TWorkspace = array [0..DCTSIZE2-1] of DCTELEM; +var + tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : DCTELEM; + tmp10, tmp11, tmp12, tmp13 : DCTELEM; + z1, z2, z3, z4, z5, z11, z13 : DCTELEM; + dataptr : PWorkspace; + ctr : int; + {SHIFT_TEMPS} +begin + { Pass 1: process rows. } + + dataptr := PWorkspace(@data); + for ctr := DCTSIZE-1 downto 0 do + begin + tmp0 := dataptr^[0] + dataptr^[7]; + tmp7 := dataptr^[0] - dataptr^[7]; + tmp1 := dataptr^[1] + dataptr^[6]; + tmp6 := dataptr^[1] - dataptr^[6]; + tmp2 := dataptr^[2] + dataptr^[5]; + tmp5 := dataptr^[2] - dataptr^[5]; + tmp3 := dataptr^[3] + dataptr^[4]; + tmp4 := dataptr^[3] - dataptr^[4]; + + { Even part } + + tmp10 := tmp0 + tmp3; { phase 2 } + tmp13 := tmp0 - tmp3; + tmp11 := tmp1 + tmp2; + tmp12 := tmp1 - tmp2; + + dataptr^[0] := tmp10 + tmp11; { phase 3 } + dataptr^[4] := tmp10 - tmp11; + + z1 := MULTIPLY(tmp12 + tmp13, FIX_0_707106781); { c4 } + dataptr^[2] := tmp13 + z1; { phase 5 } + dataptr^[6] := tmp13 - z1; + + { Odd part } + + tmp10 := tmp4 + tmp5; { phase 2 } + tmp11 := tmp5 + tmp6; + tmp12 := tmp6 + tmp7; + + { The rotator is modified from fig 4-8 to avoid extra negations. } + z5 := MULTIPLY(tmp10 - tmp12, FIX_0_382683433); { c6 } + z2 := MULTIPLY(tmp10, FIX_0_541196100) + z5; { c2-c6 } + z4 := MULTIPLY(tmp12, FIX_1_306562965) + z5; { c2+c6 } + z3 := MULTIPLY(tmp11, FIX_0_707106781); { c4 } + + z11 := tmp7 + z3; { phase 5 } + z13 := tmp7 - z3; + + dataptr^[5] := z13 + z2; { phase 6 } + dataptr^[3] := z13 - z2; + dataptr^[1] := z11 + z4; + dataptr^[7] := z11 - z4; + + Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row } + end; + + { Pass 2: process columns. } + + dataptr := PWorkspace(@data); + for ctr := DCTSIZE-1 downto 0 do + begin + tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7]; + tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7]; + tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6]; + tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6]; + tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5]; + tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5]; + tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4]; + tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4]; + + { Even part } + + tmp10 := tmp0 + tmp3; { phase 2 } + tmp13 := tmp0 - tmp3; + tmp11 := tmp1 + tmp2; + tmp12 := tmp1 - tmp2; + + dataptr^[DCTSIZE*0] := tmp10 + tmp11; { phase 3 } + dataptr^[DCTSIZE*4] := tmp10 - tmp11; + + z1 := MULTIPLY(tmp12 + tmp13, FIX_0_707106781); { c4 } + dataptr^[DCTSIZE*2] := tmp13 + z1; { phase 5 } + dataptr^[DCTSIZE*6] := tmp13 - z1; + + { Odd part } + + tmp10 := tmp4 + tmp5; { phase 2 } + tmp11 := tmp5 + tmp6; + tmp12 := tmp6 + tmp7; + + { The rotator is modified from fig 4-8 to avoid extra negations. } + z5 := MULTIPLY(tmp10 - tmp12, FIX_0_382683433); { c6 } + z2 := MULTIPLY(tmp10, FIX_0_541196100) + z5; { c2-c6 } + z4 := MULTIPLY(tmp12, FIX_1_306562965) + z5; { c2+c6 } + z3 := MULTIPLY(tmp11, FIX_0_707106781); { c4 } + + z11 := tmp7 + z3; { phase 5 } + z13 := tmp7 - z3; + + dataptr^[DCTSIZE*5] := z13 + z2; { phase 6 } + dataptr^[DCTSIZE*3] := z13 - z2; + dataptr^[DCTSIZE*1] := z11 + z4; + dataptr^[DCTSIZE*7] := z11 - z4; + + Inc(DCTELEMPTR(dataptr)); { advance pointer to next column } + end; +end; + +end. diff --git a/Imaging/JpegLib/imjfdctint.pas b/Imaging/JpegLib/imjfdctint.pas index bc94638..1be951c 100644 --- a/Imaging/JpegLib/imjfdctint.pas +++ b/Imaging/JpegLib/imjfdctint.pas @@ -1,297 +1,297 @@ -unit imjfdctint; - - -{ This file contains a slow-but-accurate integer implementation of the - forward DCT (Discrete Cosine Transform). - - A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT - on each column. Direct algorithms are also available, but they are - much more complex and seem not to be any faster when reduced to code. - - This implementation is based on an algorithm described in - C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT - Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics, - Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991. - The primary algorithm described there uses 11 multiplies and 29 adds. - We use their alternate method with 12 multiplies and 32 adds. - The advantage of this method is that no data path contains more than one - multiplication; this allows a very simple and accurate implementation in - scaled fixed-point arithmetic, with a minimal number of shifts. } - -{ Original : jfdctint.c ; Copyright (C) 1991-1996, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjutils, - imjpeglib, - imjdct; { Private declarations for DCT subsystem } - - -{ Perform the forward DCT on one block of samples. } - -{GLOBAL} -procedure jpeg_fdct_islow (var data : array of DCTELEM); - -implementation - -{ This module is specialized to the case DCTSIZE = 8. } - -{$ifndef DCTSIZE_IS_8} - Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } -{$endif} - - -{ The poop on this scaling stuff is as follows: - - Each 1-D DCT step produces outputs which are a factor of sqrt(N) - larger than the true DCT outputs. The final outputs are therefore - a factor of N larger than desired; since N=8 this can be cured by - a simple right shift at the end of the algorithm. The advantage of - this arrangement is that we save two multiplications per 1-D DCT, - because the y0 and y4 outputs need not be divided by sqrt(N). - In the IJG code, this factor of 8 is removed by the quantization step - (in jcdctmgr.c), NOT in this module. - - We have to do addition and subtraction of the integer inputs, which - is no problem, and multiplication by fractional constants, which is - a problem to do in integer arithmetic. We multiply all the constants - by CONST_SCALE and convert them to integer constants (thus retaining - CONST_BITS bits of precision in the constants). After doing a - multiplication we have to divide the product by CONST_SCALE, with proper - rounding, to produce the correct output. This division can be done - cheaply as a right shift of CONST_BITS bits. We postpone shifting - as long as possible so that partial sums can be added together with - full fractional precision. - - The outputs of the first pass are scaled up by PASS1_BITS bits so that - they are represented to better-than-integral precision. These outputs - require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word - with the recommended scaling. (For 12-bit sample data, the intermediate - array is INT32 anyway.) - - To avoid overflow of the 32-bit intermediate results in pass 2, we must - have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis - shows that the values given below are the most effective. } - -{$ifdef BITS_IN_JSAMPLE_IS_8} -const - CONST_BITS = 13; - PASS1_BITS = 2; -{$else} -const - CONST_BITS = 13; - PASS1_BITS = 1; { lose a little precision to avoid overflow } -{$endif} - -const - CONST_SCALE = (INT32(1) shl CONST_BITS); - -const - FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446} - FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196} - FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433} - FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270} - FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373} - FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633} - FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299} - FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137} - FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069} - FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819} - FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995} - FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172} - - -{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result. - For 8-bit samples with the recommended scaling, all the variable - and constant values involved are no more than 16 bits wide, so a - 16x16->32 bit multiply can be used instead of a full 32x32 multiply. - For 12-bit samples, a full 32-bit multiplication will be needed. } - -{$ifdef BITS_IN_JSAMPLE_IS_8} - - {MULTIPLY16C16(var,const)} - function Multiply(X, Y: int): INT32; - begin - Multiply := int(X) * INT32(Y); - end; - -{$else} - function Multiply(X, Y: INT32): INT32; - begin - Multiply := X * Y; - end; -{$endif} - -{ Descale and correctly round an INT32 value that's scaled by N bits. - We assume RIGHT_SHIFT rounds towards minus infinity, so adding - the fudge factor is correct for either sign of X. } - -function DESCALE(x : INT32; n : int) : INT32; -var - shift_temp : INT32; -begin -{$ifdef RIGHT_SHIFT_IS_UNSIGNED} - shift_temp := x + (INT32(1) shl (n-1)); - if shift_temp < 0 then - Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) - else - Descale := (shift_temp shr n); -{$else} - Descale := (x + (INT32(1) shl (n-1)) shr n; -{$endif} -end; - - -{ Perform the forward DCT on one block of samples. } - -{GLOBAL} -procedure jpeg_fdct_islow (var data : array of DCTELEM); -type - PWorkspace = ^TWorkspace; - TWorkspace = array [0..DCTSIZE2-1] of DCTELEM; -var - tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : INT32; - tmp10, tmp11, tmp12, tmp13 : INT32; - z1, z2, z3, z4, z5 : INT32; - dataptr : PWorkspace; - ctr : int; - {SHIFT_TEMPS} -begin - - { Pass 1: process rows. } - { Note results are scaled up by sqrt(8) compared to a true DCT; } - { furthermore, we scale the results by 2**PASS1_BITS. } - - dataptr := PWorkspace(@data); - for ctr := DCTSIZE-1 downto 0 do - begin - tmp0 := dataptr^[0] + dataptr^[7]; - tmp7 := dataptr^[0] - dataptr^[7]; - tmp1 := dataptr^[1] + dataptr^[6]; - tmp6 := dataptr^[1] - dataptr^[6]; - tmp2 := dataptr^[2] + dataptr^[5]; - tmp5 := dataptr^[2] - dataptr^[5]; - tmp3 := dataptr^[3] + dataptr^[4]; - tmp4 := dataptr^[3] - dataptr^[4]; - - { Even part per LL&M figure 1 --- note that published figure is faulty; - rotator "sqrt(2)*c1" should be "sqrt(2)*c6". } - - tmp10 := tmp0 + tmp3; - tmp13 := tmp0 - tmp3; - tmp11 := tmp1 + tmp2; - tmp12 := tmp1 - tmp2; - - dataptr^[0] := DCTELEM ((tmp10 + tmp11) shl PASS1_BITS); - dataptr^[4] := DCTELEM ((tmp10 - tmp11) shl PASS1_BITS); - - z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100); - dataptr^[2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865), - CONST_BITS-PASS1_BITS)); - dataptr^[6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065), - CONST_BITS-PASS1_BITS)); - - { Odd part per figure 8 --- note paper omits factor of sqrt(2). - cK represents cos(K*pi/16). - i0..i3 in the paper are tmp4..tmp7 here. } - - z1 := tmp4 + tmp7; - z2 := tmp5 + tmp6; - z3 := tmp4 + tmp6; - z4 := tmp5 + tmp7; - z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } - - tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } - tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } - tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } - tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } - z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) } - z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } - z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } - z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } - - Inc(z3, z5); - Inc(z4, z5); - - dataptr^[7] := DCTELEM(DESCALE(tmp4 + z1 + z3, CONST_BITS-PASS1_BITS)); - dataptr^[5] := DCTELEM(DESCALE(tmp5 + z2 + z4, CONST_BITS-PASS1_BITS)); - dataptr^[3] := DCTELEM(DESCALE(tmp6 + z2 + z3, CONST_BITS-PASS1_BITS)); - dataptr^[1] := DCTELEM(DESCALE(tmp7 + z1 + z4, CONST_BITS-PASS1_BITS)); - - Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row } - end; - - { Pass 2: process columns. - We remove the PASS1_BITS scaling, but leave the results scaled up - by an overall factor of 8. } - - dataptr := PWorkspace(@data); - for ctr := DCTSIZE-1 downto 0 do - begin - tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7]; - tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7]; - tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6]; - tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6]; - tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5]; - tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5]; - tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4]; - tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4]; - - { Even part per LL&M figure 1 --- note that published figure is faulty; - rotator "sqrt(2)*c1" should be "sqrt(2)*c6". } - - tmp10 := tmp0 + tmp3; - tmp13 := tmp0 - tmp3; - tmp11 := tmp1 + tmp2; - tmp12 := tmp1 - tmp2; - - dataptr^[DCTSIZE*0] := DCTELEM (DESCALE(tmp10 + tmp11, PASS1_BITS)); - dataptr^[DCTSIZE*4] := DCTELEM (DESCALE(tmp10 - tmp11, PASS1_BITS)); - - z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100); - dataptr^[DCTSIZE*2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865), - CONST_BITS+PASS1_BITS)); - dataptr^[DCTSIZE*6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065), - CONST_BITS+PASS1_BITS)); - - { Odd part per figure 8 --- note paper omits factor of sqrt(2). - cK represents cos(K*pi/16). - i0..i3 in the paper are tmp4..tmp7 here. } - - z1 := tmp4 + tmp7; - z2 := tmp5 + tmp6; - z3 := tmp4 + tmp6; - z4 := tmp5 + tmp7; - z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } - - tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } - tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } - tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } - tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } - z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) } - z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } - z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } - z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } - - Inc(z3, z5); - Inc(z4, z5); - - dataptr^[DCTSIZE*7] := DCTELEM (DESCALE(tmp4 + z1 + z3, - CONST_BITS+PASS1_BITS)); - dataptr^[DCTSIZE*5] := DCTELEM (DESCALE(tmp5 + z2 + z4, - CONST_BITS+PASS1_BITS)); - dataptr^[DCTSIZE*3] := DCTELEM (DESCALE(tmp6 + z2 + z3, - CONST_BITS+PASS1_BITS)); - dataptr^[DCTSIZE*1] := DCTELEM (DESCALE(tmp7 + z1 + z4, - CONST_BITS+PASS1_BITS)); - - Inc(DCTELEMPTR(dataptr)); { advance pointer to next column } - end; -end; - -end. +unit imjfdctint; + + +{ This file contains a slow-but-accurate integer implementation of the + forward DCT (Discrete Cosine Transform). + + A 2-D DCT can be done by 1-D DCT on each row followed by 1-D DCT + on each column. Direct algorithms are also available, but they are + much more complex and seem not to be any faster when reduced to code. + + This implementation is based on an algorithm described in + C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT + Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics, + Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991. + The primary algorithm described there uses 11 multiplies and 29 adds. + We use their alternate method with 12 multiplies and 32 adds. + The advantage of this method is that no data path contains more than one + multiplication; this allows a very simple and accurate implementation in + scaled fixed-point arithmetic, with a minimal number of shifts. } + +{ Original : jfdctint.c ; Copyright (C) 1991-1996, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjutils, + imjpeglib, + imjdct; { Private declarations for DCT subsystem } + + +{ Perform the forward DCT on one block of samples. } + +{GLOBAL} +procedure jpeg_fdct_islow (var data : array of DCTELEM); + +implementation + +{ This module is specialized to the case DCTSIZE = 8. } + +{$ifndef DCTSIZE_IS_8} + Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } +{$endif} + + +{ The poop on this scaling stuff is as follows: + + Each 1-D DCT step produces outputs which are a factor of sqrt(N) + larger than the true DCT outputs. The final outputs are therefore + a factor of N larger than desired; since N=8 this can be cured by + a simple right shift at the end of the algorithm. The advantage of + this arrangement is that we save two multiplications per 1-D DCT, + because the y0 and y4 outputs need not be divided by sqrt(N). + In the IJG code, this factor of 8 is removed by the quantization step + (in jcdctmgr.c), NOT in this module. + + We have to do addition and subtraction of the integer inputs, which + is no problem, and multiplication by fractional constants, which is + a problem to do in integer arithmetic. We multiply all the constants + by CONST_SCALE and convert them to integer constants (thus retaining + CONST_BITS bits of precision in the constants). After doing a + multiplication we have to divide the product by CONST_SCALE, with proper + rounding, to produce the correct output. This division can be done + cheaply as a right shift of CONST_BITS bits. We postpone shifting + as long as possible so that partial sums can be added together with + full fractional precision. + + The outputs of the first pass are scaled up by PASS1_BITS bits so that + they are represented to better-than-integral precision. These outputs + require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word + with the recommended scaling. (For 12-bit sample data, the intermediate + array is INT32 anyway.) + + To avoid overflow of the 32-bit intermediate results in pass 2, we must + have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis + shows that the values given below are the most effective. } + +{$ifdef BITS_IN_JSAMPLE_IS_8} +const + CONST_BITS = 13; + PASS1_BITS = 2; +{$else} +const + CONST_BITS = 13; + PASS1_BITS = 1; { lose a little precision to avoid overflow } +{$endif} + +const + CONST_SCALE = (INT32(1) shl CONST_BITS); + +const + FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446} + FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196} + FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433} + FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270} + FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373} + FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633} + FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299} + FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137} + FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069} + FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819} + FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995} + FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172} + + +{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result. + For 8-bit samples with the recommended scaling, all the variable + and constant values involved are no more than 16 bits wide, so a + 16x16->32 bit multiply can be used instead of a full 32x32 multiply. + For 12-bit samples, a full 32-bit multiplication will be needed. } + +{$ifdef BITS_IN_JSAMPLE_IS_8} + + {MULTIPLY16C16(var,const)} + function Multiply(X, Y: int): INT32; + begin + Multiply := int(X) * INT32(Y); + end; + +{$else} + function Multiply(X, Y: INT32): INT32; + begin + Multiply := X * Y; + end; +{$endif} + +{ Descale and correctly round an INT32 value that's scaled by N bits. + We assume RIGHT_SHIFT rounds towards minus infinity, so adding + the fudge factor is correct for either sign of X. } + +function DESCALE(x : INT32; n : int) : INT32; +var + shift_temp : INT32; +begin +{$ifdef RIGHT_SHIFT_IS_UNSIGNED} + shift_temp := x + (INT32(1) shl (n-1)); + if shift_temp < 0 then + Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) + else + Descale := (shift_temp shr n); +{$else} + Descale := (x + (INT32(1) shl (n-1)) shr n; +{$endif} +end; + + +{ Perform the forward DCT on one block of samples. } + +{GLOBAL} +procedure jpeg_fdct_islow (var data : array of DCTELEM); +type + PWorkspace = ^TWorkspace; + TWorkspace = array [0..DCTSIZE2-1] of DCTELEM; +var + tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : INT32; + tmp10, tmp11, tmp12, tmp13 : INT32; + z1, z2, z3, z4, z5 : INT32; + dataptr : PWorkspace; + ctr : int; + {SHIFT_TEMPS} +begin + + { Pass 1: process rows. } + { Note results are scaled up by sqrt(8) compared to a true DCT; } + { furthermore, we scale the results by 2**PASS1_BITS. } + + dataptr := PWorkspace(@data); + for ctr := DCTSIZE-1 downto 0 do + begin + tmp0 := dataptr^[0] + dataptr^[7]; + tmp7 := dataptr^[0] - dataptr^[7]; + tmp1 := dataptr^[1] + dataptr^[6]; + tmp6 := dataptr^[1] - dataptr^[6]; + tmp2 := dataptr^[2] + dataptr^[5]; + tmp5 := dataptr^[2] - dataptr^[5]; + tmp3 := dataptr^[3] + dataptr^[4]; + tmp4 := dataptr^[3] - dataptr^[4]; + + { Even part per LL&M figure 1 --- note that published figure is faulty; + rotator "sqrt(2)*c1" should be "sqrt(2)*c6". } + + tmp10 := tmp0 + tmp3; + tmp13 := tmp0 - tmp3; + tmp11 := tmp1 + tmp2; + tmp12 := tmp1 - tmp2; + + dataptr^[0] := DCTELEM ((tmp10 + tmp11) shl PASS1_BITS); + dataptr^[4] := DCTELEM ((tmp10 - tmp11) shl PASS1_BITS); + + z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100); + dataptr^[2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865), + CONST_BITS-PASS1_BITS)); + dataptr^[6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065), + CONST_BITS-PASS1_BITS)); + + { Odd part per figure 8 --- note paper omits factor of sqrt(2). + cK represents cos(K*pi/16). + i0..i3 in the paper are tmp4..tmp7 here. } + + z1 := tmp4 + tmp7; + z2 := tmp5 + tmp6; + z3 := tmp4 + tmp6; + z4 := tmp5 + tmp7; + z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } + + tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } + tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } + tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } + tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } + z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) } + z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } + z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } + z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } + + Inc(z3, z5); + Inc(z4, z5); + + dataptr^[7] := DCTELEM(DESCALE(tmp4 + z1 + z3, CONST_BITS-PASS1_BITS)); + dataptr^[5] := DCTELEM(DESCALE(tmp5 + z2 + z4, CONST_BITS-PASS1_BITS)); + dataptr^[3] := DCTELEM(DESCALE(tmp6 + z2 + z3, CONST_BITS-PASS1_BITS)); + dataptr^[1] := DCTELEM(DESCALE(tmp7 + z1 + z4, CONST_BITS-PASS1_BITS)); + + Inc(DCTELEMPTR(dataptr), DCTSIZE); { advance pointer to next row } + end; + + { Pass 2: process columns. + We remove the PASS1_BITS scaling, but leave the results scaled up + by an overall factor of 8. } + + dataptr := PWorkspace(@data); + for ctr := DCTSIZE-1 downto 0 do + begin + tmp0 := dataptr^[DCTSIZE*0] + dataptr^[DCTSIZE*7]; + tmp7 := dataptr^[DCTSIZE*0] - dataptr^[DCTSIZE*7]; + tmp1 := dataptr^[DCTSIZE*1] + dataptr^[DCTSIZE*6]; + tmp6 := dataptr^[DCTSIZE*1] - dataptr^[DCTSIZE*6]; + tmp2 := dataptr^[DCTSIZE*2] + dataptr^[DCTSIZE*5]; + tmp5 := dataptr^[DCTSIZE*2] - dataptr^[DCTSIZE*5]; + tmp3 := dataptr^[DCTSIZE*3] + dataptr^[DCTSIZE*4]; + tmp4 := dataptr^[DCTSIZE*3] - dataptr^[DCTSIZE*4]; + + { Even part per LL&M figure 1 --- note that published figure is faulty; + rotator "sqrt(2)*c1" should be "sqrt(2)*c6". } + + tmp10 := tmp0 + tmp3; + tmp13 := tmp0 - tmp3; + tmp11 := tmp1 + tmp2; + tmp12 := tmp1 - tmp2; + + dataptr^[DCTSIZE*0] := DCTELEM (DESCALE(tmp10 + tmp11, PASS1_BITS)); + dataptr^[DCTSIZE*4] := DCTELEM (DESCALE(tmp10 - tmp11, PASS1_BITS)); + + z1 := MULTIPLY(tmp12 + tmp13, FIX_0_541196100); + dataptr^[DCTSIZE*2] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp13, FIX_0_765366865), + CONST_BITS+PASS1_BITS)); + dataptr^[DCTSIZE*6] := DCTELEM (DESCALE(z1 + MULTIPLY(tmp12, - FIX_1_847759065), + CONST_BITS+PASS1_BITS)); + + { Odd part per figure 8 --- note paper omits factor of sqrt(2). + cK represents cos(K*pi/16). + i0..i3 in the paper are tmp4..tmp7 here. } + + z1 := tmp4 + tmp7; + z2 := tmp5 + tmp6; + z3 := tmp4 + tmp6; + z4 := tmp5 + tmp7; + z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } + + tmp4 := MULTIPLY(tmp4, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } + tmp5 := MULTIPLY(tmp5, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } + tmp6 := MULTIPLY(tmp6, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } + tmp7 := MULTIPLY(tmp7, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } + z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) } + z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } + z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } + z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } + + Inc(z3, z5); + Inc(z4, z5); + + dataptr^[DCTSIZE*7] := DCTELEM (DESCALE(tmp4 + z1 + z3, + CONST_BITS+PASS1_BITS)); + dataptr^[DCTSIZE*5] := DCTELEM (DESCALE(tmp5 + z2 + z4, + CONST_BITS+PASS1_BITS)); + dataptr^[DCTSIZE*3] := DCTELEM (DESCALE(tmp6 + z2 + z3, + CONST_BITS+PASS1_BITS)); + dataptr^[DCTSIZE*1] := DCTELEM (DESCALE(tmp7 + z1 + z4, + CONST_BITS+PASS1_BITS)); + + Inc(DCTELEMPTR(dataptr)); { advance pointer to next column } + end; +end; + +end. diff --git a/Imaging/JpegLib/imjidctasm.pas b/Imaging/JpegLib/imjidctasm.pas index 3cf4e70..e23a1c3 100644 --- a/Imaging/JpegLib/imjidctasm.pas +++ b/Imaging/JpegLib/imjidctasm.pas @@ -1,793 +1,793 @@ -unit imjidctasm; - -{ This file contains a slow-but-accurate integer implementation of the - inverse DCT (Discrete Cosine Transform). In the IJG code, this routine - must also perform dequantization of the input coefficients. - - A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT - on each row (or vice versa, but it's more convenient to emit a row at - a time). Direct algorithms are also available, but they are much more - complex and seem not to be any faster when reduced to code. - - This implementation is based on an algorithm described in - C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT - Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics, - Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991. - The primary algorithm described there uses 11 multiplies and 29 adds. - We use their alternate method with 12 multiplies and 32 adds. - The advantage of this method is that no data path contains more than one - multiplication; this allows a very simple and accurate implementation in - scaled fixed-point arithmetic, with a minimal number of shifts. } - -{ Original : jidctint.c ; Copyright (C) 1991-1996, Thomas G. Lane. } -{ ;------------------------------------------------------------------------- - ; JIDCTINT.ASM - ; 80386 protected mode assembly translation of JIDCTINT.C - ; **** Optimized to all hell by Jason M. Felice (jasonf@apk.net) **** - ; **** E-mail welcome **** - ; - ; ** This code does not make O/S calls -- use it for OS/2, Win95, WinNT, - ; ** DOS prot. mode., Linux, whatever... have fun. - ; - ; ** Note, this code is dependant on the structure member order in the .h - ; ** files for the following structures: - ; -- amazingly NOT j_decompress_struct... cool. - ; -- jpeg_component_info (dependant on position of dct_table element) - ; - ; Originally created with the /Fa option of MSVC 4.0 (why work when you - ; don't have to?) - ; - ; (this code, when compiled is 1K bytes smaller than the optimized MSVC - ; release build, not to mention 120-130 ms faster in my profile test with 1 - ; small color and and 1 medium black-and-white jpeg: stats using TASM 4.0 - ; and MSVC 4.0 to create a non-console app; jpeg_idct_islow accumulated - ; 5,760 hits on all trials) - ; - ; TASM -t -ml -os jidctint.asm, jidctint.obj - ;------------------------------------------------------------------------- - Converted to Delphi 2.0 BASM for PasJPEG - by Jacques NOMSSI NZALI - October 13th 1996 - * assumes Delphi "register" calling convention - first 3 parameter are in EAX,EDX,ECX - * register allocation revised -} - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib, - imjdct; { Private declarations for DCT subsystem } - -{ Perform dequantization and inverse DCT on one block of coefficients. } - -{GLOBAL} -procedure jpeg_idct_islow (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); - -implementation - -{ This module is specialized to the case DCTSIZE = 8. } - -{$ifndef DCTSIZE_IS_8} - Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } -{$endif} - -{ The poop on this scaling stuff is as follows: - - Each 1-D IDCT step produces outputs which are a factor of sqrt(N) - larger than the true IDCT outputs. The final outputs are therefore - a factor of N larger than desired; since N=8 this can be cured by - a simple right shift at the end of the algorithm. The advantage of - this arrangement is that we save two multiplications per 1-D IDCT, - because the y0 and y4 inputs need not be divided by sqrt(N). - - We have to do addition and subtraction of the integer inputs, which - is no problem, and multiplication by fractional constants, which is - a problem to do in integer arithmetic. We multiply all the constants - by CONST_SCALE and convert them to integer constants (thus retaining - CONST_BITS bits of precision in the constants). After doing a - multiplication we have to divide the product by CONST_SCALE, with proper - rounding, to produce the correct output. This division can be done - cheaply as a right shift of CONST_BITS bits. We postpone shifting - as long as possible so that partial sums can be added together with - full fractional precision. - - The outputs of the first pass are scaled up by PASS1_BITS bits so that - they are represented to better-than-integral precision. These outputs - require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word - with the recommended scaling. (To scale up 12-bit sample data further, an - intermediate INT32 array would be needed.) - - To avoid overflow of the 32-bit intermediate results in pass 2, we must - have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis - shows that the values given below are the most effective. } - -const - CONST_BITS = 13; - -{$ifdef BITS_IN_JSAMPLE_IS_8} -const - PASS1_BITS = 2; -{$else} -const - PASS1_BITS = 1; { lose a little precision to avoid overflow } -{$endif} - -const - CONST_SCALE = (INT32(1) shl CONST_BITS); - -const - FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446} - FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196} - FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433} - FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270} - FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373} - FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633} - FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299} - FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137} - FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069} - FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819} - FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995} - FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172} - - -{ for DESCALE } -const - ROUND_CONST = (INT32(1) shl (CONST_BITS-PASS1_BITS-1)); -const - ROUND_CONST_2 = (INT32(1) shl (CONST_BITS+PASS1_BITS+3-1)); - -{ Perform dequantization and inverse DCT on one block of coefficients. } - -{GLOBAL} -procedure jpeg_idct_islow (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); -type - PWorkspace = ^TWorkspace; - TWorkspace = coef_bits_field; { buffers data between passes } -const - coefDCTSIZE = DCTSIZE*SizeOf(JCOEF); - wrkDCTSIZE = DCTSIZE*SizeOf(int); -var - tmp0, tmp1, tmp2, tmp3 : INT32; - tmp10, tmp11, tmp12, tmp13 : INT32; - z1, z2, z3, z4, z5 : INT32; -var - inptr : JCOEFPTR; - quantptr : ISLOW_MULT_TYPE_FIELD_PTR; - wsptr : PWorkspace; - outptr : JSAMPROW; -var - range_limit : JSAMPROW; - ctr : int; - workspace : TWorkspace; -var - dcval : int; -var - dcval_ : JSAMPLE; -asm - push edi - push esi - push ebx - - cld { The only direction we use, might as well set it now, as opposed } - { to inside 2 loops. } - -{ Each IDCT routine is responsible for range-limiting its results and - converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could - be quite far out of range if the input data is corrupt, so a bulletproof - range-limiting step is required. We use a mask-and-table-lookup method - to do the combined operations quickly. See the comments with - prepare_range_limit_table (in jdmaster.c) for more info. } - - {range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));} - mov eax, [eax].jpeg_decompress_struct.sample_range_limit {eax=cinfo} - add eax, (MAXJSAMPLE+1 + CENTERJSAMPLE)*(Type JSAMPLE) - mov range_limit, eax - - { Pass 1: process columns from input, store into work array. } - { Note results are scaled up by sqrt(8) compared to a true IDCT; } - { furthermore, we scale the results by 2**PASS1_BITS. } - - {inptr := coef_block;} - mov esi, ecx { ecx=coef_block } - {quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);} - mov edi, [edx].jpeg_component_info.dct_table { edx=compptr } - - {wsptr := PWorkspace(@workspace);} - lea ecx, workspace - - {for ctr := pred(DCTSIZE) downto 0 do - begin} - mov ctr, DCTSIZE -@loop518: - { Due to quantization, we will usually find that many of the input - coefficients are zero, especially the AC terms. We can exploit this - by short-circuiting the IDCT calculation for any column in which all - the AC terms are zero. In that case each output is equal to the - DC coefficient (with scale factor as needed). - With typical images and quantization tables, half or more of the - column DCT calculations can be simplified this way. } - - {if ((inptr^[DCTSIZE*1]) or (inptr^[DCTSIZE*2]) or (inptr^[DCTSIZE*3]) or - (inptr^[DCTSIZE*4]) or (inptr^[DCTSIZE*5]) or (inptr^[DCTSIZE*6]) or - (inptr^[DCTSIZE*7]) = 0) then - begin} - mov eax, DWORD PTR [esi+coefDCTSIZE*1] - or eax, DWORD PTR [esi+coefDCTSIZE*2] - or eax, DWORD PTR [esi+coefDCTSIZE*3] - mov edx, DWORD PTR [esi+coefDCTSIZE*4] - or eax, edx - or eax, DWORD PTR [esi+coefDCTSIZE*5] - or eax, DWORD PTR [esi+coefDCTSIZE*6] - or eax, DWORD PTR [esi+coefDCTSIZE*7] - jne @loop520 - - { AC terms all zero } - {dcval := ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * - (quantptr^[DCTSIZE*0]) shl PASS1_BITS;} - mov eax, DWORD PTR [esi+coefDCTSIZE*0] - imul eax, DWORD PTR [edi+wrkDCTSIZE*0] - shl eax, PASS1_BITS - - {wsptr^[DCTSIZE*0] := dcval; - wsptr^[DCTSIZE*1] := dcval; - wsptr^[DCTSIZE*2] := dcval; - wsptr^[DCTSIZE*3] := dcval; - wsptr^[DCTSIZE*4] := dcval; - wsptr^[DCTSIZE*5] := dcval; - wsptr^[DCTSIZE*6] := dcval; - wsptr^[DCTSIZE*7] := dcval;} - - mov DWORD PTR [ecx+ wrkDCTSIZE*0], eax - mov DWORD PTR [ecx+ wrkDCTSIZE*1], eax - mov DWORD PTR [ecx+ wrkDCTSIZE*2], eax - mov DWORD PTR [ecx+ wrkDCTSIZE*3], eax - mov DWORD PTR [ecx+ wrkDCTSIZE*4], eax - mov DWORD PTR [ecx+ wrkDCTSIZE*5], eax - mov DWORD PTR [ecx+ wrkDCTSIZE*6], eax - mov DWORD PTR [ecx+ wrkDCTSIZE*7], eax - - {Inc(JCOEF_PTR(inptr)); { advance pointers to next column } - {Inc(ISLOW_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - continue;} - dec ctr - je @loop519 - - add esi, Type JCOEF - add edi, Type ISLOW_MULT_TYPE - add ecx, Type int { int_ptr } - jmp @loop518 - -@loop520: - - {end;} - - { Even part: reverse the even part of the forward DCT. } - { The rotator is sqrt(2)*c(-6). } - - {z2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*2]) * quantptr^[DCTSIZE*2]; - z3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*6]) * quantptr^[DCTSIZE*6]; - - z1 := (z2 + z3) * INT32(FIX_0_541196100); - tmp2 := z1 + INT32(z3) * INT32(- FIX_1_847759065); - tmp3 := z1 + INT32(z2) * INT32(FIX_0_765366865);} - - mov edx, DWORD PTR [esi+coefDCTSIZE*2] - imul edx, DWORD PTR [edi+wrkDCTSIZE*2] {z2} - - mov eax, DWORD PTR [esi+coefDCTSIZE*6] - imul eax, DWORD PTR [edi+wrkDCTSIZE*6] {z3} - - lea ebx, [eax+edx] - imul ebx, FIX_0_541196100 {z1} - - imul eax, (-FIX_1_847759065) - add eax, ebx - mov tmp2, eax - - imul edx, FIX_0_765366865 - add edx, ebx - mov tmp3, edx - - {z2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * quantptr^[DCTSIZE*0]; - z3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*4]) * quantptr^[DCTSIZE*4];} - - mov edx, DWORD PTR [esi+coefDCTSIZE*4] - imul edx, DWORD PTR [edi+wrkDCTSIZE*4] { z3 = edx } - - mov eax, DWORD PTR [esi+coefDCTSIZE*0] - imul eax, DWORD PTR [edi+wrkDCTSIZE*0] { z2 = eax } - - {tmp0 := (z2 + z3) shl CONST_BITS; - tmp1 := (z2 - z3) shl CONST_BITS;} - lea ebx,[eax+edx] - sub eax, edx - shl ebx, CONST_BITS { tmp0 = ebx } - shl eax, CONST_BITS { tmp1 = eax } - - {tmp10 := tmp0 + tmp3; - tmp13 := tmp0 - tmp3;} - mov edx, tmp3 - sub ebx, edx - mov tmp13, ebx - add edx, edx - add ebx, edx - mov tmp10, ebx - - {tmp11 := tmp1 + tmp2; - tmp12 := tmp1 - tmp2;} - mov ebx, tmp2 - sub eax, ebx - mov tmp12, eax - add ebx, ebx - add eax, ebx - mov tmp11, eax - - { Odd part per figure 8; the matrix is unitary and hence its - transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. } - - {tmp0 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*7]) * quantptr^[DCTSIZE*7];} - mov eax, DWORD PTR [esi+coefDCTSIZE*7] - imul eax, DWORD PTR [edi+wrkDCTSIZE*7] - mov edx, eax { edx = tmp0 } - {tmp0 := (tmp0) * INT32(FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } - imul eax, FIX_0_298631336 - mov tmp0, eax - - {tmp3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*1]) * quantptr^[DCTSIZE*1];} - mov eax, DWORD PTR [esi+coefDCTSIZE*1] - imul eax, DWORD PTR [edi+wrkDCTSIZE*1] - mov tmp3, eax - - {z1 := tmp0 + tmp3;} - {z1 := (z1) * INT32(- FIX_0_899976223); { sqrt(2) * (c7-c3) } - add eax, edx - imul eax, (-FIX_0_899976223) - mov z1, eax - - {tmp1 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*5]) * quantptr^[DCTSIZE*5];} - mov eax, DWORD PTR [esi+coefDCTSIZE*5] - imul eax, DWORD PTR [edi+wrkDCTSIZE*5] - mov ebx, eax { ebx = tmp1 } - {tmp1 := (tmp1) * INT32(FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } - imul eax, FIX_2_053119869 - mov tmp1, eax - - {tmp2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*3]) * quantptr^[DCTSIZE*3];} - mov eax, DWORD PTR [esi+coefDCTSIZE*3] - imul eax, DWORD PTR [edi+wrkDCTSIZE*3] - mov tmp2, eax - - {z3 := tmp0 + tmp2;} - add edx, eax { edx = z3 } - - {z2 := tmp1 + tmp2;} - {z2 := (z2) * INT32(- FIX_2_562915447); { sqrt(2) * (-c1-c3) } - add eax, ebx - imul eax, (-FIX_2_562915447) - mov z2, eax - - {z4 := tmp1 + tmp3;} - add ebx, tmp3 { ebx = z4 } - - {z5 := INT32(z3 + z4) * INT32(FIX_1_175875602); { sqrt(2) * c3 } - lea eax, [edx+ebx] - imul eax, FIX_1_175875602 { eax = z5 } - - {z4 := (z4) * INT32(- FIX_0_390180644); { sqrt(2) * (c5-c3) } - {Inc(z4, z5);} - imul ebx, (-FIX_0_390180644) - add ebx, eax - mov z4, ebx - - {z3 := (z3) * INT32(- FIX_1_961570560); { sqrt(2) * (-c3-c5) } - {Inc(z3, z5);} - imul edx, (-FIX_1_961570560) - add eax, edx { z3 = eax } - - {Inc(tmp0, z1 + z3);} - mov ebx, z1 - add ebx, eax - add tmp0, ebx - - {tmp2 := (tmp2) * INT32(FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } - {Inc(tmp2, z2 + z3);} - mov ebx, tmp2 - imul ebx, FIX_3_072711026 - mov edx, z2 { z2 = edx } - add ebx, edx - add eax, ebx - mov tmp2, eax - - {Inc(tmp1, z2 + z4);} - mov eax, z4 { z4 = eax } - add edx, eax - add tmp1, edx - - {tmp3 := (tmp3) * INT32(FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } - {Inc(tmp3, z1 + z4);} - mov edx, tmp3 - imul edx, FIX_1_501321110 - - add edx, eax - add edx, z1 { tmp3 = edx } - - { Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 } - - {wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp3, CONST_BITS-PASS1_BITS));} - {wsptr^[DCTSIZE*7] := int (DESCALE(tmp10 - tmp3, CONST_BITS-PASS1_BITS));} - mov eax, tmp10 - add eax, ROUND_CONST - lea ebx, [eax+edx] - sar ebx, CONST_BITS-PASS1_BITS - mov DWORD PTR [ecx+wrkDCTSIZE*0], ebx - - sub eax, edx - sar eax, CONST_BITS-PASS1_BITS - mov DWORD PTR [ecx+wrkDCTSIZE*7], eax - - {wsptr^[DCTSIZE*1] := int (DESCALE(tmp11 + tmp2, CONST_BITS-PASS1_BITS));} - {wsptr^[DCTSIZE*6] := int (DESCALE(tmp11 - tmp2, CONST_BITS-PASS1_BITS));} - mov eax, tmp11 - add eax, ROUND_CONST - mov edx, tmp2 - lea ebx, [eax+edx] - sar ebx, CONST_BITS-PASS1_BITS - mov DWORD PTR [ecx+wrkDCTSIZE*1], ebx - - sub eax, edx - sar eax, CONST_BITS-PASS1_BITS - mov DWORD PTR [ecx+wrkDCTSIZE*6], eax - - {wsptr^[DCTSIZE*2] := int (DESCALE(tmp12 + tmp1, CONST_BITS-PASS1_BITS));} - {wsptr^[DCTSIZE*5] := int (DESCALE(tmp12 - tmp1, CONST_BITS-PASS1_BITS));} - mov eax, tmp12 - add eax, ROUND_CONST - mov edx, tmp1 - lea ebx, [eax+edx] - sar ebx, CONST_BITS-PASS1_BITS - mov DWORD PTR [ecx+wrkDCTSIZE*2], ebx - - sub eax, edx - sar eax, CONST_BITS-PASS1_BITS - mov DWORD PTR [ecx+wrkDCTSIZE*5], eax - - {wsptr^[DCTSIZE*3] := int (DESCALE(tmp13 + tmp0, CONST_BITS-PASS1_BITS));} - {wsptr^[DCTSIZE*4] := int (DESCALE(tmp13 - tmp0, CONST_BITS-PASS1_BITS));} - mov eax, tmp13 - add eax, ROUND_CONST - mov edx, tmp0 - lea ebx, [eax+edx] - sar ebx, CONST_BITS-PASS1_BITS - mov DWORD PTR [ecx+wrkDCTSIZE*3], ebx - - sub eax, edx - sar eax, CONST_BITS-PASS1_BITS - mov DWORD PTR [ecx+wrkDCTSIZE*4], eax - - {Inc(JCOEF_PTR(inptr)); { advance pointers to next column } - {Inc(ISLOW_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr));} - dec ctr - je @loop519 - - add esi, Type JCOEF - add edi, Type ISLOW_MULT_TYPE - add ecx, Type int { int_ptr } - {end;} - jmp @loop518 -@loop519: - { Save to memory what we've registerized for the preceding loop. } - - { Pass 2: process rows from work array, store into output array. } - { Note that we must descale the results by a factor of 8 == 2**3, } - { and also undo the PASS1_BITS scaling. } - - {wsptr := @workspace;} - lea esi, workspace - - {for ctr := 0 to pred(DCTSIZE) do - begin} - mov ctr, 0 -@loop523: - - {outptr := output_buf^[ctr];} - mov eax, ctr - mov ebx, output_buf - mov edi, DWORD PTR [ebx+eax*4] { 4 = SizeOf(pointer) } - - {Inc(JSAMPLE_PTR(outptr), output_col);} - add edi, LongWord(output_col) - - { Rows of zeroes can be exploited in the same way as we did with columns. - However, the column calculation has created many nonzero AC terms, so - the simplification applies less often (typically 5% to 10% of the time). - On machines with very fast multiplication, it's possible that the - test takes more time than it's worth. In that case this section - may be commented out. } - -{$ifndef NO_ZERO_ROW_TEST} - {if ((wsptr^[1]) or (wsptr^[2]) or (wsptr^[3]) or (wsptr^[4]) or - (wsptr^[5]) or (wsptr^[6]) or (wsptr^[7]) = 0) then - begin} - mov eax, DWORD PTR [esi+4*1] - or eax, DWORD PTR [esi+4*2] - or eax, DWORD PTR [esi+4*3] - jne @loop525 { Nomssi: early exit path may help } - or eax, DWORD PTR [esi+4*4] - or eax, DWORD PTR [esi+4*5] - or eax, DWORD PTR [esi+4*6] - or eax, DWORD PTR [esi+4*7] - jne @loop525 - - { AC terms all zero } - {JSAMPLE(dcval_) := range_limit^[int(DESCALE(INT32(wsptr^[0]), - PASS1_BITS+3)) and RANGE_MASK];} - mov eax, DWORD PTR [esi+4*0] - add eax, (INT32(1) shl (PASS1_BITS+3-1)) - sar eax, PASS1_BITS+3 - and eax, RANGE_MASK - mov ebx, range_limit - mov al, BYTE PTR [ebx+eax] - mov ah, al - - {outptr^[0] := dcval_; - outptr^[1] := dcval_; - outptr^[2] := dcval_; - outptr^[3] := dcval_; - outptr^[4] := dcval_; - outptr^[5] := dcval_; - outptr^[6] := dcval_; - outptr^[7] := dcval_;} - - stosw - stosw - stosw - stosw - - {Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } - {continue;} - add esi, wrkDCTSIZE - inc ctr - cmp ctr, DCTSIZE - jl @loop523 - jmp @loop524 - {end;} -@loop525: -{$endif} - - - { Even part: reverse the even part of the forward DCT. } - { The rotator is sqrt(2)*c(-6). } - - {z2 := INT32 (wsptr^[2]);} - mov edx, DWORD PTR [esi+4*2] { z2 = edx } - - {z3 := INT32 (wsptr^[6]);} - mov ecx, DWORD PTR [esi+4*6] { z3 = ecx } - - {z1 := (z2 + z3) * INT32(FIX_0_541196100);} - lea eax, [edx+ecx] - imul eax, FIX_0_541196100 - mov ebx, eax { z1 = ebx } - - {tmp2 := z1 + (z3) * INT32(- FIX_1_847759065);} - imul ecx, (-FIX_1_847759065) - add ecx, ebx { tmp2 = ecx } - - {tmp3 := z1 + (z2) * INT32(FIX_0_765366865);} - imul edx, FIX_0_765366865 - add ebx, edx { tmp3 = ebx } - - {tmp0 := (INT32(wsptr^[0]) + INT32(wsptr^[4])) shl CONST_BITS;} - {tmp1 := (INT32(wsptr^[0]) - INT32(wsptr^[4])) shl CONST_BITS;} - mov edx, DWORD PTR [esi+4*4] - mov eax, DWORD PTR [esi+4*0] - sub eax, edx - add edx, edx - add edx, eax - shl edx, CONST_BITS { tmp0 = edx } - shl eax, CONST_BITS { tmp1 = eax } - - {tmp10 := tmp0 + tmp3;} - {tmp13 := tmp0 - tmp3;} - sub edx, ebx - mov tmp13, edx - add ebx, ebx - add edx, ebx - mov tmp10, edx - - {tmp11 := tmp1 + tmp2;} - {tmp12 := tmp1 - tmp2;} - lea ebx, [ecx+eax] - mov tmp11, ebx - sub eax, ecx - mov tmp12, eax - - { Odd part per figure 8; the matrix is unitary and hence its - transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. } - -{ The following lines no longer produce code, since wsptr has been - optimized to esi, it is more efficient to access these values - directly. - tmp0 := INT32(wsptr^[7]); - tmp1 := INT32(wsptr^[5]); - tmp2 := INT32(wsptr^[3]); - tmp3 := INT32(wsptr^[1]); } - - {z2 := tmp1 + tmp2;} - {z2 := (z2) * INT32(- FIX_2_562915447); { sqrt(2) * (-c1-c3) } - mov ebx, DWORD PTR [esi+4*3] { tmp2 } - mov ecx, DWORD PTR [esi+4*5] { tmp1 } - lea eax, [ebx+ecx] - imul eax, (-FIX_2_562915447) - mov z2, eax - - {z3 := tmp0 + tmp2;} - mov edx, DWORD PTR [esi+4*7] { tmp0 } - add ebx, edx { old z3 = ebx } - mov eax, ebx - {z3 := (z3) * INT32(- FIX_1_961570560); { sqrt(2) * (-c3-c5) } - imul eax, (-FIX_1_961570560) - mov z3, eax - - {z1 := tmp0 + tmp3;} - {z1 := (z1) * INT32(- FIX_0_899976223); { sqrt(2) * (c7-c3) } - mov eax, DWORD PTR [esi+4*1] { tmp3 } - add edx, eax - imul edx, (-FIX_0_899976223) { z1 = edx } - - {z4 := tmp1 + tmp3;} - add eax, ecx { +tmp1 } - add ebx, eax { z3 + z4 = ebx } - {z4 := (z4) * INT32(- FIX_0_390180644); { sqrt(2) * (c5-c3) } - imul eax, (-FIX_0_390180644) { z4 = eax } - - {z5 := (z3 + z4) * INT32(FIX_1_175875602); { sqrt(2) * c3 } - {Inc(z3, z5);} - imul ebx, FIX_1_175875602 - mov ecx, z3 - add ecx, ebx { ecx = z3 } - - {Inc(z4, z5);} - add ebx, eax { z4 = ebx } - - {tmp0 := (tmp0) * INT32(FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } - {Inc(tmp0, z1 + z3);} - mov eax, DWORD PTR [esi+4*7] - imul eax, FIX_0_298631336 - add eax, edx - add eax, ecx - mov tmp0, eax - - {tmp1 := (tmp1) * INT32(FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } - {Inc(tmp1, z2 + z4);} - mov eax, DWORD PTR [esi+4*5] - imul eax, FIX_2_053119869 - add eax, z2 - add eax, ebx - mov tmp1, eax - - {tmp2 := (tmp2) * INT32(FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } - {Inc(tmp2, z2 + z3);} - mov eax, DWORD PTR [esi+4*3] - imul eax, FIX_3_072711026 - add eax, z2 - add ecx, eax { ecx = tmp2 } - - {tmp3 := (tmp3) * INT32(FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } - {Inc(tmp3, z1 + z4);} - mov eax, DWORD PTR [esi+4*1] - imul eax, FIX_1_501321110 - add eax, edx - add ebx, eax { ebx = tmp3 } - - { Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 } - - {outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp3, - CONST_BITS+PASS1_BITS+3)) and RANGE_MASK]; } - {outptr^[7] := range_limit^[ int(DESCALE(tmp10 - tmp3, - CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} - - mov edx, tmp10 - add edx, ROUND_CONST_2 - lea eax, [ebx+edx] - sub edx, ebx - - shr eax, CONST_BITS+PASS1_BITS+3 - and eax, RANGE_MASK - mov ebx, range_limit { once for all } - mov al, BYTE PTR [ebx+eax] - mov [edi+0], al - - shr edx, CONST_BITS+PASS1_BITS+3 - and edx, RANGE_MASK - mov al, BYTE PTR [ebx+edx] - mov [edi+7], al - - {outptr^[1] := range_limit^[ int(DESCALE(tmp11 + tmp2, - CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} - mov eax, tmp11 - add eax, ROUND_CONST_2 - lea edx, [eax+ecx] - shr edx, CONST_BITS+PASS1_BITS+3 - and edx, RANGE_MASK - mov dl, BYTE PTR [ebx+edx] - mov [edi+1], dl - - {outptr^[6] := range_limit^[ int(DESCALE(tmp11 - tmp2, - CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} - sub eax, ecx - shr eax, CONST_BITS+PASS1_BITS+3 - and eax, RANGE_MASK - mov al, BYTE PTR [ebx+eax] - mov [edi+6], al - - {outptr^[2] := range_limit^[ int(DESCALE(tmp12 + tmp1, - CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} - mov eax, tmp12 - add eax, ROUND_CONST_2 - mov ecx, tmp1 - lea edx, [eax+ecx] - shr edx, CONST_BITS+PASS1_BITS+3 - and edx, RANGE_MASK - mov dl, BYTE PTR [ebx+edx] - mov [edi+2], dl - - {outptr^[5] := range_limit^[ int(DESCALE(tmp12 - tmp1, - CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} - sub eax, ecx - shr eax, CONST_BITS+PASS1_BITS+3 - and eax, RANGE_MASK - mov al, BYTE PTR [ebx+eax] - mov [edi+5], al - - {outptr^[3] := range_limit^[ int(DESCALE(tmp13 + tmp0, - CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} - mov eax, tmp13 - add eax, ROUND_CONST_2 - mov ecx, tmp0 - lea edx, [eax+ecx] - shr edx, CONST_BITS+PASS1_BITS+3 - and edx, RANGE_MASK - mov dl, BYTE PTR [ebx+edx] - mov [edi+3], dl - - {outptr^[4] := range_limit^[ int(DESCALE(tmp13 - tmp0, - CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} - sub eax, ecx - shr eax, CONST_BITS+PASS1_BITS+3 - and eax, RANGE_MASK - mov al, BYTE PTR [ebx+eax] - mov [edi+4], al - - {Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } - add esi, wrkDCTSIZE - add edi, DCTSIZE - - {end;} - inc ctr - cmp ctr, DCTSIZE - jl @loop523 - -@loop524: -@loop496: - pop ebx - pop esi - pop edi -end; - -end. +unit imjidctasm; + +{ This file contains a slow-but-accurate integer implementation of the + inverse DCT (Discrete Cosine Transform). In the IJG code, this routine + must also perform dequantization of the input coefficients. + + A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT + on each row (or vice versa, but it's more convenient to emit a row at + a time). Direct algorithms are also available, but they are much more + complex and seem not to be any faster when reduced to code. + + This implementation is based on an algorithm described in + C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT + Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics, + Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991. + The primary algorithm described there uses 11 multiplies and 29 adds. + We use their alternate method with 12 multiplies and 32 adds. + The advantage of this method is that no data path contains more than one + multiplication; this allows a very simple and accurate implementation in + scaled fixed-point arithmetic, with a minimal number of shifts. } + +{ Original : jidctint.c ; Copyright (C) 1991-1996, Thomas G. Lane. } +{ ;------------------------------------------------------------------------- + ; JIDCTINT.ASM + ; 80386 protected mode assembly translation of JIDCTINT.C + ; **** Optimized to all hell by Jason M. Felice (jasonf@apk.net) **** + ; **** E-mail welcome **** + ; + ; ** This code does not make O/S calls -- use it for OS/2, Win95, WinNT, + ; ** DOS prot. mode., Linux, whatever... have fun. + ; + ; ** Note, this code is dependant on the structure member order in the .h + ; ** files for the following structures: + ; -- amazingly NOT j_decompress_struct... cool. + ; -- jpeg_component_info (dependant on position of dct_table element) + ; + ; Originally created with the /Fa option of MSVC 4.0 (why work when you + ; don't have to?) + ; + ; (this code, when compiled is 1K bytes smaller than the optimized MSVC + ; release build, not to mention 120-130 ms faster in my profile test with 1 + ; small color and and 1 medium black-and-white jpeg: stats using TASM 4.0 + ; and MSVC 4.0 to create a non-console app; jpeg_idct_islow accumulated + ; 5,760 hits on all trials) + ; + ; TASM -t -ml -os jidctint.asm, jidctint.obj + ;------------------------------------------------------------------------- + Converted to Delphi 2.0 BASM for PasJPEG + by Jacques NOMSSI NZALI + October 13th 1996 + * assumes Delphi "register" calling convention + first 3 parameter are in EAX,EDX,ECX + * register allocation revised +} + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib, + imjdct; { Private declarations for DCT subsystem } + +{ Perform dequantization and inverse DCT on one block of coefficients. } + +{GLOBAL} +procedure jpeg_idct_islow (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); + +implementation + +{ This module is specialized to the case DCTSIZE = 8. } + +{$ifndef DCTSIZE_IS_8} + Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } +{$endif} + +{ The poop on this scaling stuff is as follows: + + Each 1-D IDCT step produces outputs which are a factor of sqrt(N) + larger than the true IDCT outputs. The final outputs are therefore + a factor of N larger than desired; since N=8 this can be cured by + a simple right shift at the end of the algorithm. The advantage of + this arrangement is that we save two multiplications per 1-D IDCT, + because the y0 and y4 inputs need not be divided by sqrt(N). + + We have to do addition and subtraction of the integer inputs, which + is no problem, and multiplication by fractional constants, which is + a problem to do in integer arithmetic. We multiply all the constants + by CONST_SCALE and convert them to integer constants (thus retaining + CONST_BITS bits of precision in the constants). After doing a + multiplication we have to divide the product by CONST_SCALE, with proper + rounding, to produce the correct output. This division can be done + cheaply as a right shift of CONST_BITS bits. We postpone shifting + as long as possible so that partial sums can be added together with + full fractional precision. + + The outputs of the first pass are scaled up by PASS1_BITS bits so that + they are represented to better-than-integral precision. These outputs + require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word + with the recommended scaling. (To scale up 12-bit sample data further, an + intermediate INT32 array would be needed.) + + To avoid overflow of the 32-bit intermediate results in pass 2, we must + have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis + shows that the values given below are the most effective. } + +const + CONST_BITS = 13; + +{$ifdef BITS_IN_JSAMPLE_IS_8} +const + PASS1_BITS = 2; +{$else} +const + PASS1_BITS = 1; { lose a little precision to avoid overflow } +{$endif} + +const + CONST_SCALE = (INT32(1) shl CONST_BITS); + +const + FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446} + FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196} + FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433} + FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270} + FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373} + FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633} + FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299} + FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137} + FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069} + FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819} + FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995} + FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172} + + +{ for DESCALE } +const + ROUND_CONST = (INT32(1) shl (CONST_BITS-PASS1_BITS-1)); +const + ROUND_CONST_2 = (INT32(1) shl (CONST_BITS+PASS1_BITS+3-1)); + +{ Perform dequantization and inverse DCT on one block of coefficients. } + +{GLOBAL} +procedure jpeg_idct_islow (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); +type + PWorkspace = ^TWorkspace; + TWorkspace = coef_bits_field; { buffers data between passes } +const + coefDCTSIZE = DCTSIZE*SizeOf(JCOEF); + wrkDCTSIZE = DCTSIZE*SizeOf(int); +var + tmp0, tmp1, tmp2, tmp3 : INT32; + tmp10, tmp11, tmp12, tmp13 : INT32; + z1, z2, z3, z4, z5 : INT32; +var + inptr : JCOEFPTR; + quantptr : ISLOW_MULT_TYPE_FIELD_PTR; + wsptr : PWorkspace; + outptr : JSAMPROW; +var + range_limit : JSAMPROW; + ctr : int; + workspace : TWorkspace; +var + dcval : int; +var + dcval_ : JSAMPLE; +asm + push edi + push esi + push ebx + + cld { The only direction we use, might as well set it now, as opposed } + { to inside 2 loops. } + +{ Each IDCT routine is responsible for range-limiting its results and + converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could + be quite far out of range if the input data is corrupt, so a bulletproof + range-limiting step is required. We use a mask-and-table-lookup method + to do the combined operations quickly. See the comments with + prepare_range_limit_table (in jdmaster.c) for more info. } + + {range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE]));} + mov eax, [eax].jpeg_decompress_struct.sample_range_limit {eax=cinfo} + add eax, (MAXJSAMPLE+1 + CENTERJSAMPLE)*(Type JSAMPLE) + mov range_limit, eax + + { Pass 1: process columns from input, store into work array. } + { Note results are scaled up by sqrt(8) compared to a true IDCT; } + { furthermore, we scale the results by 2**PASS1_BITS. } + + {inptr := coef_block;} + mov esi, ecx { ecx=coef_block } + {quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table);} + mov edi, [edx].jpeg_component_info.dct_table { edx=compptr } + + {wsptr := PWorkspace(@workspace);} + lea ecx, workspace + + {for ctr := pred(DCTSIZE) downto 0 do + begin} + mov ctr, DCTSIZE +@loop518: + { Due to quantization, we will usually find that many of the input + coefficients are zero, especially the AC terms. We can exploit this + by short-circuiting the IDCT calculation for any column in which all + the AC terms are zero. In that case each output is equal to the + DC coefficient (with scale factor as needed). + With typical images and quantization tables, half or more of the + column DCT calculations can be simplified this way. } + + {if ((inptr^[DCTSIZE*1]) or (inptr^[DCTSIZE*2]) or (inptr^[DCTSIZE*3]) or + (inptr^[DCTSIZE*4]) or (inptr^[DCTSIZE*5]) or (inptr^[DCTSIZE*6]) or + (inptr^[DCTSIZE*7]) = 0) then + begin} + mov eax, DWORD PTR [esi+coefDCTSIZE*1] + or eax, DWORD PTR [esi+coefDCTSIZE*2] + or eax, DWORD PTR [esi+coefDCTSIZE*3] + mov edx, DWORD PTR [esi+coefDCTSIZE*4] + or eax, edx + or eax, DWORD PTR [esi+coefDCTSIZE*5] + or eax, DWORD PTR [esi+coefDCTSIZE*6] + or eax, DWORD PTR [esi+coefDCTSIZE*7] + jne @loop520 + + { AC terms all zero } + {dcval := ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * + (quantptr^[DCTSIZE*0]) shl PASS1_BITS;} + mov eax, DWORD PTR [esi+coefDCTSIZE*0] + imul eax, DWORD PTR [edi+wrkDCTSIZE*0] + shl eax, PASS1_BITS + + {wsptr^[DCTSIZE*0] := dcval; + wsptr^[DCTSIZE*1] := dcval; + wsptr^[DCTSIZE*2] := dcval; + wsptr^[DCTSIZE*3] := dcval; + wsptr^[DCTSIZE*4] := dcval; + wsptr^[DCTSIZE*5] := dcval; + wsptr^[DCTSIZE*6] := dcval; + wsptr^[DCTSIZE*7] := dcval;} + + mov DWORD PTR [ecx+ wrkDCTSIZE*0], eax + mov DWORD PTR [ecx+ wrkDCTSIZE*1], eax + mov DWORD PTR [ecx+ wrkDCTSIZE*2], eax + mov DWORD PTR [ecx+ wrkDCTSIZE*3], eax + mov DWORD PTR [ecx+ wrkDCTSIZE*4], eax + mov DWORD PTR [ecx+ wrkDCTSIZE*5], eax + mov DWORD PTR [ecx+ wrkDCTSIZE*6], eax + mov DWORD PTR [ecx+ wrkDCTSIZE*7], eax + + {Inc(JCOEF_PTR(inptr)); { advance pointers to next column } + {Inc(ISLOW_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + continue;} + dec ctr + je @loop519 + + add esi, Type JCOEF + add edi, Type ISLOW_MULT_TYPE + add ecx, Type int { int_ptr } + jmp @loop518 + +@loop520: + + {end;} + + { Even part: reverse the even part of the forward DCT. } + { The rotator is sqrt(2)*c(-6). } + + {z2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*2]) * quantptr^[DCTSIZE*2]; + z3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*6]) * quantptr^[DCTSIZE*6]; + + z1 := (z2 + z3) * INT32(FIX_0_541196100); + tmp2 := z1 + INT32(z3) * INT32(- FIX_1_847759065); + tmp3 := z1 + INT32(z2) * INT32(FIX_0_765366865);} + + mov edx, DWORD PTR [esi+coefDCTSIZE*2] + imul edx, DWORD PTR [edi+wrkDCTSIZE*2] {z2} + + mov eax, DWORD PTR [esi+coefDCTSIZE*6] + imul eax, DWORD PTR [edi+wrkDCTSIZE*6] {z3} + + lea ebx, [eax+edx] + imul ebx, FIX_0_541196100 {z1} + + imul eax, (-FIX_1_847759065) + add eax, ebx + mov tmp2, eax + + imul edx, FIX_0_765366865 + add edx, ebx + mov tmp3, edx + + {z2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * quantptr^[DCTSIZE*0]; + z3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*4]) * quantptr^[DCTSIZE*4];} + + mov edx, DWORD PTR [esi+coefDCTSIZE*4] + imul edx, DWORD PTR [edi+wrkDCTSIZE*4] { z3 = edx } + + mov eax, DWORD PTR [esi+coefDCTSIZE*0] + imul eax, DWORD PTR [edi+wrkDCTSIZE*0] { z2 = eax } + + {tmp0 := (z2 + z3) shl CONST_BITS; + tmp1 := (z2 - z3) shl CONST_BITS;} + lea ebx,[eax+edx] + sub eax, edx + shl ebx, CONST_BITS { tmp0 = ebx } + shl eax, CONST_BITS { tmp1 = eax } + + {tmp10 := tmp0 + tmp3; + tmp13 := tmp0 - tmp3;} + mov edx, tmp3 + sub ebx, edx + mov tmp13, ebx + add edx, edx + add ebx, edx + mov tmp10, ebx + + {tmp11 := tmp1 + tmp2; + tmp12 := tmp1 - tmp2;} + mov ebx, tmp2 + sub eax, ebx + mov tmp12, eax + add ebx, ebx + add eax, ebx + mov tmp11, eax + + { Odd part per figure 8; the matrix is unitary and hence its + transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. } + + {tmp0 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*7]) * quantptr^[DCTSIZE*7];} + mov eax, DWORD PTR [esi+coefDCTSIZE*7] + imul eax, DWORD PTR [edi+wrkDCTSIZE*7] + mov edx, eax { edx = tmp0 } + {tmp0 := (tmp0) * INT32(FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } + imul eax, FIX_0_298631336 + mov tmp0, eax + + {tmp3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*1]) * quantptr^[DCTSIZE*1];} + mov eax, DWORD PTR [esi+coefDCTSIZE*1] + imul eax, DWORD PTR [edi+wrkDCTSIZE*1] + mov tmp3, eax + + {z1 := tmp0 + tmp3;} + {z1 := (z1) * INT32(- FIX_0_899976223); { sqrt(2) * (c7-c3) } + add eax, edx + imul eax, (-FIX_0_899976223) + mov z1, eax + + {tmp1 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*5]) * quantptr^[DCTSIZE*5];} + mov eax, DWORD PTR [esi+coefDCTSIZE*5] + imul eax, DWORD PTR [edi+wrkDCTSIZE*5] + mov ebx, eax { ebx = tmp1 } + {tmp1 := (tmp1) * INT32(FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } + imul eax, FIX_2_053119869 + mov tmp1, eax + + {tmp2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*3]) * quantptr^[DCTSIZE*3];} + mov eax, DWORD PTR [esi+coefDCTSIZE*3] + imul eax, DWORD PTR [edi+wrkDCTSIZE*3] + mov tmp2, eax + + {z3 := tmp0 + tmp2;} + add edx, eax { edx = z3 } + + {z2 := tmp1 + tmp2;} + {z2 := (z2) * INT32(- FIX_2_562915447); { sqrt(2) * (-c1-c3) } + add eax, ebx + imul eax, (-FIX_2_562915447) + mov z2, eax + + {z4 := tmp1 + tmp3;} + add ebx, tmp3 { ebx = z4 } + + {z5 := INT32(z3 + z4) * INT32(FIX_1_175875602); { sqrt(2) * c3 } + lea eax, [edx+ebx] + imul eax, FIX_1_175875602 { eax = z5 } + + {z4 := (z4) * INT32(- FIX_0_390180644); { sqrt(2) * (c5-c3) } + {Inc(z4, z5);} + imul ebx, (-FIX_0_390180644) + add ebx, eax + mov z4, ebx + + {z3 := (z3) * INT32(- FIX_1_961570560); { sqrt(2) * (-c3-c5) } + {Inc(z3, z5);} + imul edx, (-FIX_1_961570560) + add eax, edx { z3 = eax } + + {Inc(tmp0, z1 + z3);} + mov ebx, z1 + add ebx, eax + add tmp0, ebx + + {tmp2 := (tmp2) * INT32(FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } + {Inc(tmp2, z2 + z3);} + mov ebx, tmp2 + imul ebx, FIX_3_072711026 + mov edx, z2 { z2 = edx } + add ebx, edx + add eax, ebx + mov tmp2, eax + + {Inc(tmp1, z2 + z4);} + mov eax, z4 { z4 = eax } + add edx, eax + add tmp1, edx + + {tmp3 := (tmp3) * INT32(FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } + {Inc(tmp3, z1 + z4);} + mov edx, tmp3 + imul edx, FIX_1_501321110 + + add edx, eax + add edx, z1 { tmp3 = edx } + + { Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 } + + {wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp3, CONST_BITS-PASS1_BITS));} + {wsptr^[DCTSIZE*7] := int (DESCALE(tmp10 - tmp3, CONST_BITS-PASS1_BITS));} + mov eax, tmp10 + add eax, ROUND_CONST + lea ebx, [eax+edx] + sar ebx, CONST_BITS-PASS1_BITS + mov DWORD PTR [ecx+wrkDCTSIZE*0], ebx + + sub eax, edx + sar eax, CONST_BITS-PASS1_BITS + mov DWORD PTR [ecx+wrkDCTSIZE*7], eax + + {wsptr^[DCTSIZE*1] := int (DESCALE(tmp11 + tmp2, CONST_BITS-PASS1_BITS));} + {wsptr^[DCTSIZE*6] := int (DESCALE(tmp11 - tmp2, CONST_BITS-PASS1_BITS));} + mov eax, tmp11 + add eax, ROUND_CONST + mov edx, tmp2 + lea ebx, [eax+edx] + sar ebx, CONST_BITS-PASS1_BITS + mov DWORD PTR [ecx+wrkDCTSIZE*1], ebx + + sub eax, edx + sar eax, CONST_BITS-PASS1_BITS + mov DWORD PTR [ecx+wrkDCTSIZE*6], eax + + {wsptr^[DCTSIZE*2] := int (DESCALE(tmp12 + tmp1, CONST_BITS-PASS1_BITS));} + {wsptr^[DCTSIZE*5] := int (DESCALE(tmp12 - tmp1, CONST_BITS-PASS1_BITS));} + mov eax, tmp12 + add eax, ROUND_CONST + mov edx, tmp1 + lea ebx, [eax+edx] + sar ebx, CONST_BITS-PASS1_BITS + mov DWORD PTR [ecx+wrkDCTSIZE*2], ebx + + sub eax, edx + sar eax, CONST_BITS-PASS1_BITS + mov DWORD PTR [ecx+wrkDCTSIZE*5], eax + + {wsptr^[DCTSIZE*3] := int (DESCALE(tmp13 + tmp0, CONST_BITS-PASS1_BITS));} + {wsptr^[DCTSIZE*4] := int (DESCALE(tmp13 - tmp0, CONST_BITS-PASS1_BITS));} + mov eax, tmp13 + add eax, ROUND_CONST + mov edx, tmp0 + lea ebx, [eax+edx] + sar ebx, CONST_BITS-PASS1_BITS + mov DWORD PTR [ecx+wrkDCTSIZE*3], ebx + + sub eax, edx + sar eax, CONST_BITS-PASS1_BITS + mov DWORD PTR [ecx+wrkDCTSIZE*4], eax + + {Inc(JCOEF_PTR(inptr)); { advance pointers to next column } + {Inc(ISLOW_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr));} + dec ctr + je @loop519 + + add esi, Type JCOEF + add edi, Type ISLOW_MULT_TYPE + add ecx, Type int { int_ptr } + {end;} + jmp @loop518 +@loop519: + { Save to memory what we've registerized for the preceding loop. } + + { Pass 2: process rows from work array, store into output array. } + { Note that we must descale the results by a factor of 8 == 2**3, } + { and also undo the PASS1_BITS scaling. } + + {wsptr := @workspace;} + lea esi, workspace + + {for ctr := 0 to pred(DCTSIZE) do + begin} + mov ctr, 0 +@loop523: + + {outptr := output_buf^[ctr];} + mov eax, ctr + mov ebx, output_buf + mov edi, DWORD PTR [ebx+eax*4] { 4 = SizeOf(pointer) } + + {Inc(JSAMPLE_PTR(outptr), output_col);} + add edi, uInt(output_col) + + { Rows of zeroes can be exploited in the same way as we did with columns. + However, the column calculation has created many nonzero AC terms, so + the simplification applies less often (typically 5% to 10% of the time). + On machines with very fast multiplication, it's possible that the + test takes more time than it's worth. In that case this section + may be commented out. } + +{$ifndef NO_ZERO_ROW_TEST} + {if ((wsptr^[1]) or (wsptr^[2]) or (wsptr^[3]) or (wsptr^[4]) or + (wsptr^[5]) or (wsptr^[6]) or (wsptr^[7]) = 0) then + begin} + mov eax, DWORD PTR [esi+4*1] + or eax, DWORD PTR [esi+4*2] + or eax, DWORD PTR [esi+4*3] + jne @loop525 { Nomssi: early exit path may help } + or eax, DWORD PTR [esi+4*4] + or eax, DWORD PTR [esi+4*5] + or eax, DWORD PTR [esi+4*6] + or eax, DWORD PTR [esi+4*7] + jne @loop525 + + { AC terms all zero } + {JSAMPLE(dcval_) := range_limit^[int(DESCALE(INT32(wsptr^[0]), + PASS1_BITS+3)) and RANGE_MASK];} + mov eax, DWORD PTR [esi+4*0] + add eax, (INT32(1) shl (PASS1_BITS+3-1)) + sar eax, PASS1_BITS+3 + and eax, RANGE_MASK + mov ebx, range_limit + mov al, BYTE PTR [ebx+eax] + mov ah, al + + {outptr^[0] := dcval_; + outptr^[1] := dcval_; + outptr^[2] := dcval_; + outptr^[3] := dcval_; + outptr^[4] := dcval_; + outptr^[5] := dcval_; + outptr^[6] := dcval_; + outptr^[7] := dcval_;} + + stosw + stosw + stosw + stosw + + {Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } + {continue;} + add esi, wrkDCTSIZE + inc ctr + cmp ctr, DCTSIZE + jl @loop523 + jmp @loop524 + {end;} +@loop525: +{$endif} + + + { Even part: reverse the even part of the forward DCT. } + { The rotator is sqrt(2)*c(-6). } + + {z2 := INT32 (wsptr^[2]);} + mov edx, DWORD PTR [esi+4*2] { z2 = edx } + + {z3 := INT32 (wsptr^[6]);} + mov ecx, DWORD PTR [esi+4*6] { z3 = ecx } + + {z1 := (z2 + z3) * INT32(FIX_0_541196100);} + lea eax, [edx+ecx] + imul eax, FIX_0_541196100 + mov ebx, eax { z1 = ebx } + + {tmp2 := z1 + (z3) * INT32(- FIX_1_847759065);} + imul ecx, (-FIX_1_847759065) + add ecx, ebx { tmp2 = ecx } + + {tmp3 := z1 + (z2) * INT32(FIX_0_765366865);} + imul edx, FIX_0_765366865 + add ebx, edx { tmp3 = ebx } + + {tmp0 := (INT32(wsptr^[0]) + INT32(wsptr^[4])) shl CONST_BITS;} + {tmp1 := (INT32(wsptr^[0]) - INT32(wsptr^[4])) shl CONST_BITS;} + mov edx, DWORD PTR [esi+4*4] + mov eax, DWORD PTR [esi+4*0] + sub eax, edx + add edx, edx + add edx, eax + shl edx, CONST_BITS { tmp0 = edx } + shl eax, CONST_BITS { tmp1 = eax } + + {tmp10 := tmp0 + tmp3;} + {tmp13 := tmp0 - tmp3;} + sub edx, ebx + mov tmp13, edx + add ebx, ebx + add edx, ebx + mov tmp10, edx + + {tmp11 := tmp1 + tmp2;} + {tmp12 := tmp1 - tmp2;} + lea ebx, [ecx+eax] + mov tmp11, ebx + sub eax, ecx + mov tmp12, eax + + { Odd part per figure 8; the matrix is unitary and hence its + transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. } + +{ The following lines no longer produce code, since wsptr has been + optimized to esi, it is more efficient to access these values + directly. + tmp0 := INT32(wsptr^[7]); + tmp1 := INT32(wsptr^[5]); + tmp2 := INT32(wsptr^[3]); + tmp3 := INT32(wsptr^[1]); } + + {z2 := tmp1 + tmp2;} + {z2 := (z2) * INT32(- FIX_2_562915447); { sqrt(2) * (-c1-c3) } + mov ebx, DWORD PTR [esi+4*3] { tmp2 } + mov ecx, DWORD PTR [esi+4*5] { tmp1 } + lea eax, [ebx+ecx] + imul eax, (-FIX_2_562915447) + mov z2, eax + + {z3 := tmp0 + tmp2;} + mov edx, DWORD PTR [esi+4*7] { tmp0 } + add ebx, edx { old z3 = ebx } + mov eax, ebx + {z3 := (z3) * INT32(- FIX_1_961570560); { sqrt(2) * (-c3-c5) } + imul eax, (-FIX_1_961570560) + mov z3, eax + + {z1 := tmp0 + tmp3;} + {z1 := (z1) * INT32(- FIX_0_899976223); { sqrt(2) * (c7-c3) } + mov eax, DWORD PTR [esi+4*1] { tmp3 } + add edx, eax + imul edx, (-FIX_0_899976223) { z1 = edx } + + {z4 := tmp1 + tmp3;} + add eax, ecx { +tmp1 } + add ebx, eax { z3 + z4 = ebx } + {z4 := (z4) * INT32(- FIX_0_390180644); { sqrt(2) * (c5-c3) } + imul eax, (-FIX_0_390180644) { z4 = eax } + + {z5 := (z3 + z4) * INT32(FIX_1_175875602); { sqrt(2) * c3 } + {Inc(z3, z5);} + imul ebx, FIX_1_175875602 + mov ecx, z3 + add ecx, ebx { ecx = z3 } + + {Inc(z4, z5);} + add ebx, eax { z4 = ebx } + + {tmp0 := (tmp0) * INT32(FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } + {Inc(tmp0, z1 + z3);} + mov eax, DWORD PTR [esi+4*7] + imul eax, FIX_0_298631336 + add eax, edx + add eax, ecx + mov tmp0, eax + + {tmp1 := (tmp1) * INT32(FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } + {Inc(tmp1, z2 + z4);} + mov eax, DWORD PTR [esi+4*5] + imul eax, FIX_2_053119869 + add eax, z2 + add eax, ebx + mov tmp1, eax + + {tmp2 := (tmp2) * INT32(FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } + {Inc(tmp2, z2 + z3);} + mov eax, DWORD PTR [esi+4*3] + imul eax, FIX_3_072711026 + add eax, z2 + add ecx, eax { ecx = tmp2 } + + {tmp3 := (tmp3) * INT32(FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } + {Inc(tmp3, z1 + z4);} + mov eax, DWORD PTR [esi+4*1] + imul eax, FIX_1_501321110 + add eax, edx + add ebx, eax { ebx = tmp3 } + + { Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 } + + {outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp3, + CONST_BITS+PASS1_BITS+3)) and RANGE_MASK]; } + {outptr^[7] := range_limit^[ int(DESCALE(tmp10 - tmp3, + CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} + + mov edx, tmp10 + add edx, ROUND_CONST_2 + lea eax, [ebx+edx] + sub edx, ebx + + shr eax, CONST_BITS+PASS1_BITS+3 + and eax, RANGE_MASK + mov ebx, range_limit { once for all } + mov al, BYTE PTR [ebx+eax] + mov [edi+0], al + + shr edx, CONST_BITS+PASS1_BITS+3 + and edx, RANGE_MASK + mov al, BYTE PTR [ebx+edx] + mov [edi+7], al + + {outptr^[1] := range_limit^[ int(DESCALE(tmp11 + tmp2, + CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} + mov eax, tmp11 + add eax, ROUND_CONST_2 + lea edx, [eax+ecx] + shr edx, CONST_BITS+PASS1_BITS+3 + and edx, RANGE_MASK + mov dl, BYTE PTR [ebx+edx] + mov [edi+1], dl + + {outptr^[6] := range_limit^[ int(DESCALE(tmp11 - tmp2, + CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} + sub eax, ecx + shr eax, CONST_BITS+PASS1_BITS+3 + and eax, RANGE_MASK + mov al, BYTE PTR [ebx+eax] + mov [edi+6], al + + {outptr^[2] := range_limit^[ int(DESCALE(tmp12 + tmp1, + CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} + mov eax, tmp12 + add eax, ROUND_CONST_2 + mov ecx, tmp1 + lea edx, [eax+ecx] + shr edx, CONST_BITS+PASS1_BITS+3 + and edx, RANGE_MASK + mov dl, BYTE PTR [ebx+edx] + mov [edi+2], dl + + {outptr^[5] := range_limit^[ int(DESCALE(tmp12 - tmp1, + CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} + sub eax, ecx + shr eax, CONST_BITS+PASS1_BITS+3 + and eax, RANGE_MASK + mov al, BYTE PTR [ebx+eax] + mov [edi+5], al + + {outptr^[3] := range_limit^[ int(DESCALE(tmp13 + tmp0, + CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} + mov eax, tmp13 + add eax, ROUND_CONST_2 + mov ecx, tmp0 + lea edx, [eax+ecx] + shr edx, CONST_BITS+PASS1_BITS+3 + and edx, RANGE_MASK + mov dl, BYTE PTR [ebx+edx] + mov [edi+3], dl + + {outptr^[4] := range_limit^[ int(DESCALE(tmp13 - tmp0, + CONST_BITS+PASS1_BITS+3)) and RANGE_MASK];} + sub eax, ecx + shr eax, CONST_BITS+PASS1_BITS+3 + and eax, RANGE_MASK + mov al, BYTE PTR [ebx+eax] + mov [edi+4], al + + {Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } + add esi, wrkDCTSIZE + add edi, DCTSIZE + + {end;} + inc ctr + cmp ctr, DCTSIZE + jl @loop523 + +@loop524: +@loop496: + pop ebx + pop esi + pop edi +end; + +end. diff --git a/Imaging/JpegLib/imjidctflt.pas b/Imaging/JpegLib/imjidctflt.pas index 68e1588..f8d41e9 100644 --- a/Imaging/JpegLib/imjidctflt.pas +++ b/Imaging/JpegLib/imjidctflt.pas @@ -1,286 +1,285 @@ -unit imjidctflt; - -{$N+} -{ This file contains a floating-point implementation of the - inverse DCT (Discrete Cosine Transform). In the IJG code, this routine - must also perform dequantization of the input coefficients. - - This implementation should be more accurate than either of the integer - IDCT implementations. However, it may not give the same results on all - machines because of differences in roundoff behavior. Speed will depend - on the hardware's floating point capacity. - - A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT - on each row (or vice versa, but it's more convenient to emit a row at - a time). Direct algorithms are also available, but they are much more - complex and seem not to be any faster when reduced to code. - - This implementation is based on Arai, Agui, and Nakajima's algorithm for - scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in - Japanese, but the algorithm is described in the Pennebaker & Mitchell - JPEG textbook (see REFERENCES section in file README). The following code - is based directly on figure 4-8 in P&M. - While an 8-point DCT cannot be done in less than 11 multiplies, it is - possible to arrange the computation so that many of the multiplies are - simple scalings of the final outputs. These multiplies can then be - folded into the multiplications or divisions by the JPEG quantization - table entries. The AA&N method leaves only 5 multiplies and 29 adds - to be done in the DCT itself. - The primary disadvantage of this method is that with a fixed-point - implementation, accuracy is lost due to imprecise representation of the - scaled quantization values. However, that problem does not arise if - we use floating point arithmetic. } - -{ Original: jidctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib, - imjdct; { Private declarations for DCT subsystem } - -{ Perform dequantization and inverse DCT on one block of coefficients. } - -{GLOBAL} -procedure jpeg_idct_float (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); - -implementation - -{ This module is specialized to the case DCTSIZE = 8. } - -{$ifndef DCTSIZE_IS_8} - Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } -{$endif} - - -{ Dequantize a coefficient by multiplying it by the multiplier-table - entry; produce a float result. } - -function DEQUANTIZE(coef : int; quantval : FAST_FLOAT) : FAST_FLOAT; -begin - Dequantize := ( (coef) * quantval); -end; - -{ Descale and correctly round an INT32 value that's scaled by N bits. - We assume RIGHT_SHIFT rounds towards minus infinity, so adding - the fudge factor is correct for either sign of X. } - -function DESCALE(x : INT32; n : int) : INT32; -var - shift_temp : INT32; -begin -{$ifdef RIGHT_SHIFT_IS_UNSIGNED} - shift_temp := x + (INT32(1) shl (n-1)); - if shift_temp < 0 then - Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) - else - Descale := (shift_temp shr n); -{$else} - Descale := (x + (INT32(1) shl (n-1)) shr n; -{$endif} -end; - - -{ Perform dequantization and inverse DCT on one block of coefficients. } - -{GLOBAL} -procedure jpeg_idct_float (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); -type - PWorkspace = ^TWorkspace; - TWorkspace = array[0..DCTSIZE2-1] of FAST_FLOAT; -var - tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT; - tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT; - z5, z10, z11, z12, z13 : FAST_FLOAT; - inptr : JCOEFPTR; - quantptr : FLOAT_MULT_TYPE_FIELD_PTR; - wsptr : PWorkSpace; - outptr : JSAMPROW; - range_limit : JSAMPROW; - ctr : int; - workspace : TWorkspace; { buffers data between passes } - {SHIFT_TEMPS} -var - dcval : FAST_FLOAT; -begin -{ Each IDCT routine is responsible for range-limiting its results and - converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could - be quite far out of range if the input data is corrupt, so a bulletproof - range-limiting step is required. We use a mask-and-table-lookup method - to do the combined operations quickly. See the comments with - prepare_range_limit_table (in jdmaster.c) for more info. } - - range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); - - { Pass 1: process columns from input, store into work array. } - - inptr := coef_block; - quantptr := FLOAT_MULT_TYPE_FIELD_PTR (compptr^.dct_table); - wsptr := @workspace; - for ctr := pred(DCTSIZE) downto 0 do - begin - { Due to quantization, we will usually find that many of the input - coefficients are zero, especially the AC terms. We can exploit this - by short-circuiting the IDCT calculation for any column in which all - the AC terms are zero. In that case each output is equal to the - DC coefficient (with scale factor as needed). - With typical images and quantization tables, half or more of the - column DCT calculations can be simplified this way. } - - if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and - (inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and - (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and - (inptr^[DCTSIZE*7]=0) then - begin - { AC terms all zero } - FAST_FLOAT(dcval) := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); - - wsptr^[DCTSIZE*0] := dcval; - wsptr^[DCTSIZE*1] := dcval; - wsptr^[DCTSIZE*2] := dcval; - wsptr^[DCTSIZE*3] := dcval; - wsptr^[DCTSIZE*4] := dcval; - wsptr^[DCTSIZE*5] := dcval; - wsptr^[DCTSIZE*6] := dcval; - wsptr^[DCTSIZE*7] := dcval; - - Inc(JCOEF_PTR(inptr)); { advance pointers to next column } - Inc(FLOAT_MULT_TYPE_PTR(quantptr)); - Inc(FAST_FLOAT_PTR(wsptr)); - continue; - end; - - { Even part } - - tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); - tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]); - tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]); - tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]); - - tmp10 := tmp0 + tmp2; { phase 3 } - tmp11 := tmp0 - tmp2; - - tmp13 := tmp1 + tmp3; { phases 5-3 } - tmp12 := (tmp1 - tmp3) * ({FAST_FLOAT}(1.414213562)) - tmp13; { 2*c4 } - - tmp0 := tmp10 + tmp13; { phase 2 } - tmp3 := tmp10 - tmp13; - tmp1 := tmp11 + tmp12; - tmp2 := tmp11 - tmp12; - - { Odd part } - - tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]); - tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]); - tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]); - tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]); - - z13 := tmp6 + tmp5; { phase 6 } - z10 := tmp6 - tmp5; - z11 := tmp4 + tmp7; - z12 := tmp4 - tmp7; - - tmp7 := z11 + z13; { phase 5 } - tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562)); { 2*c4 } - - z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 } - tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) } - tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) } - - tmp6 := tmp12 - tmp7; { phase 2 } - tmp5 := tmp11 - tmp6; - tmp4 := tmp10 + tmp5; - - wsptr^[DCTSIZE*0] := tmp0 + tmp7; - wsptr^[DCTSIZE*7] := tmp0 - tmp7; - wsptr^[DCTSIZE*1] := tmp1 + tmp6; - wsptr^[DCTSIZE*6] := tmp1 - tmp6; - wsptr^[DCTSIZE*2] := tmp2 + tmp5; - wsptr^[DCTSIZE*5] := tmp2 - tmp5; - wsptr^[DCTSIZE*4] := tmp3 + tmp4; - wsptr^[DCTSIZE*3] := tmp3 - tmp4; - - Inc(JCOEF_PTR(inptr)); { advance pointers to next column } - Inc(FLOAT_MULT_TYPE_PTR(quantptr)); - Inc(FAST_FLOAT_PTR(wsptr)); - end; - - { Pass 2: process rows from work array, store into output array. } - { Note that we must descale the results by a factor of 8 = 2**3. } - - wsptr := @workspace; - for ctr := 0 to pred(DCTSIZE) do - begin - outptr := JSAMPROW(@(output_buf^[ctr]^[output_col])); - { Rows of zeroes can be exploited in the same way as we did with columns. - However, the column calculation has created many nonzero AC terms, so - the simplification applies less often (typically 5% to 10% of the time). - And testing floats for zero is relatively expensive, so we don't bother. } - - { Even part } - - tmp10 := wsptr^[0] + wsptr^[4]; - tmp11 := wsptr^[0] - wsptr^[4]; - - tmp13 := wsptr^[2] + wsptr^[6]; - tmp12 := (wsptr^[2] - wsptr^[6]) * ({FAST_FLOAT}(1.414213562)) - tmp13; - - tmp0 := tmp10 + tmp13; - tmp3 := tmp10 - tmp13; - tmp1 := tmp11 + tmp12; - tmp2 := tmp11 - tmp12; - - { Odd part } - - z13 := wsptr^[5] + wsptr^[3]; - z10 := wsptr^[5] - wsptr^[3]; - z11 := wsptr^[1] + wsptr^[7]; - z12 := wsptr^[1] - wsptr^[7]; - - tmp7 := z11 + z13; - tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562)); - - z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 } - tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) } - tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) } - - tmp6 := tmp12 - tmp7; - tmp5 := tmp11 - tmp6; - tmp4 := tmp10 + tmp5; - - { Final output stage: scale down by a factor of 8 and range-limit } - - outptr^[0] := range_limit^[ int(DESCALE( INT32(Round((tmp0 + tmp7))), 3)) - and RANGE_MASK]; - outptr^[7] := range_limit^[ int(DESCALE( INT32(Round((tmp0 - tmp7))), 3)) - and RANGE_MASK]; - outptr^[1] := range_limit^[ int(DESCALE( INT32(Round((tmp1 + tmp6))), 3)) - and RANGE_MASK]; - outptr^[6] := range_limit^[ int(DESCALE( INT32(Round((tmp1 - tmp6))), 3)) - and RANGE_MASK]; - outptr^[2] := range_limit^[ int(DESCALE( INT32(Round((tmp2 + tmp5))), 3)) - and RANGE_MASK]; - outptr^[5] := range_limit^[ int(DESCALE( INT32(Round((tmp2 - tmp5))), 3)) - and RANGE_MASK]; - outptr^[4] := range_limit^[ int(DESCALE( INT32(Round((tmp3 + tmp4))), 3)) - and RANGE_MASK]; - outptr^[3] := range_limit^[ int(DESCALE( INT32(Round((tmp3 - tmp4))), 3)) - and RANGE_MASK]; - - Inc(FAST_FLOAT_PTR(wsptr), DCTSIZE); { advance pointer to next row } - end; -end; - -end. +unit imjidctflt; + +{ This file contains a floating-point implementation of the + inverse DCT (Discrete Cosine Transform). In the IJG code, this routine + must also perform dequantization of the input coefficients. + + This implementation should be more accurate than either of the integer + IDCT implementations. However, it may not give the same results on all + machines because of differences in roundoff behavior. Speed will depend + on the hardware's floating point capacity. + + A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT + on each row (or vice versa, but it's more convenient to emit a row at + a time). Direct algorithms are also available, but they are much more + complex and seem not to be any faster when reduced to code. + + This implementation is based on Arai, Agui, and Nakajima's algorithm for + scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in + Japanese, but the algorithm is described in the Pennebaker & Mitchell + JPEG textbook (see REFERENCES section in file README). The following code + is based directly on figure 4-8 in P&M. + While an 8-point DCT cannot be done in less than 11 multiplies, it is + possible to arrange the computation so that many of the multiplies are + simple scalings of the final outputs. These multiplies can then be + folded into the multiplications or divisions by the JPEG quantization + table entries. The AA&N method leaves only 5 multiplies and 29 adds + to be done in the DCT itself. + The primary disadvantage of this method is that with a fixed-point + implementation, accuracy is lost due to imprecise representation of the + scaled quantization values. However, that problem does not arise if + we use floating point arithmetic. } + +{ Original: jidctflt.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib, + imjdct; { Private declarations for DCT subsystem } + +{ Perform dequantization and inverse DCT on one block of coefficients. } + +{GLOBAL} +procedure jpeg_idct_float (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); + +implementation + +{ This module is specialized to the case DCTSIZE = 8. } + +{$ifndef DCTSIZE_IS_8} + Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } +{$endif} + + +{ Dequantize a coefficient by multiplying it by the multiplier-table + entry; produce a float result. } + +function DEQUANTIZE(coef : int; quantval : FAST_FLOAT) : FAST_FLOAT; +begin + Dequantize := ( (coef) * quantval); +end; + +{ Descale and correctly round an INT32 value that's scaled by N bits. + We assume RIGHT_SHIFT rounds towards minus infinity, so adding + the fudge factor is correct for either sign of X. } + +function DESCALE(x : INT32; n : int) : INT32; +var + shift_temp : INT32; +begin +{$ifdef RIGHT_SHIFT_IS_UNSIGNED} + shift_temp := x + (INT32(1) shl (n-1)); + if shift_temp < 0 then + Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) + else + Descale := (shift_temp shr n); +{$else} + Descale := (x + (INT32(1) shl (n-1)) shr n; +{$endif} +end; + + +{ Perform dequantization and inverse DCT on one block of coefficients. } + +{GLOBAL} +procedure jpeg_idct_float (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); +type + PWorkspace = ^TWorkspace; + TWorkspace = array[0..DCTSIZE2-1] of FAST_FLOAT; +var + tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : FAST_FLOAT; + tmp10, tmp11, tmp12, tmp13 : FAST_FLOAT; + z5, z10, z11, z12, z13 : FAST_FLOAT; + inptr : JCOEFPTR; + quantptr : FLOAT_MULT_TYPE_FIELD_PTR; + wsptr : PWorkSpace; + outptr : JSAMPROW; + range_limit : JSAMPROW; + ctr : int; + workspace : TWorkspace; { buffers data between passes } + {SHIFT_TEMPS} +var + dcval : FAST_FLOAT; +begin +{ Each IDCT routine is responsible for range-limiting its results and + converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could + be quite far out of range if the input data is corrupt, so a bulletproof + range-limiting step is required. We use a mask-and-table-lookup method + to do the combined operations quickly. See the comments with + prepare_range_limit_table (in jdmaster.c) for more info. } + + range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); + + { Pass 1: process columns from input, store into work array. } + + inptr := coef_block; + quantptr := FLOAT_MULT_TYPE_FIELD_PTR (compptr^.dct_table); + wsptr := @workspace; + for ctr := pred(DCTSIZE) downto 0 do + begin + { Due to quantization, we will usually find that many of the input + coefficients are zero, especially the AC terms. We can exploit this + by short-circuiting the IDCT calculation for any column in which all + the AC terms are zero. In that case each output is equal to the + DC coefficient (with scale factor as needed). + With typical images and quantization tables, half or more of the + column DCT calculations can be simplified this way. } + + if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and + (inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and + (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and + (inptr^[DCTSIZE*7]=0) then + begin + { AC terms all zero } + FAST_FLOAT(dcval) := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); + + wsptr^[DCTSIZE*0] := dcval; + wsptr^[DCTSIZE*1] := dcval; + wsptr^[DCTSIZE*2] := dcval; + wsptr^[DCTSIZE*3] := dcval; + wsptr^[DCTSIZE*4] := dcval; + wsptr^[DCTSIZE*5] := dcval; + wsptr^[DCTSIZE*6] := dcval; + wsptr^[DCTSIZE*7] := dcval; + + Inc(JCOEF_PTR(inptr)); { advance pointers to next column } + Inc(FLOAT_MULT_TYPE_PTR(quantptr)); + Inc(FAST_FLOAT_PTR(wsptr)); + continue; + end; + + { Even part } + + tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); + tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]); + tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]); + tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]); + + tmp10 := tmp0 + tmp2; { phase 3 } + tmp11 := tmp0 - tmp2; + + tmp13 := tmp1 + tmp3; { phases 5-3 } + tmp12 := (tmp1 - tmp3) * ({FAST_FLOAT}(1.414213562)) - tmp13; { 2*c4 } + + tmp0 := tmp10 + tmp13; { phase 2 } + tmp3 := tmp10 - tmp13; + tmp1 := tmp11 + tmp12; + tmp2 := tmp11 - tmp12; + + { Odd part } + + tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]); + tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]); + tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]); + tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]); + + z13 := tmp6 + tmp5; { phase 6 } + z10 := tmp6 - tmp5; + z11 := tmp4 + tmp7; + z12 := tmp4 - tmp7; + + tmp7 := z11 + z13; { phase 5 } + tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562)); { 2*c4 } + + z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 } + tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) } + tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) } + + tmp6 := tmp12 - tmp7; { phase 2 } + tmp5 := tmp11 - tmp6; + tmp4 := tmp10 + tmp5; + + wsptr^[DCTSIZE*0] := tmp0 + tmp7; + wsptr^[DCTSIZE*7] := tmp0 - tmp7; + wsptr^[DCTSIZE*1] := tmp1 + tmp6; + wsptr^[DCTSIZE*6] := tmp1 - tmp6; + wsptr^[DCTSIZE*2] := tmp2 + tmp5; + wsptr^[DCTSIZE*5] := tmp2 - tmp5; + wsptr^[DCTSIZE*4] := tmp3 + tmp4; + wsptr^[DCTSIZE*3] := tmp3 - tmp4; + + Inc(JCOEF_PTR(inptr)); { advance pointers to next column } + Inc(FLOAT_MULT_TYPE_PTR(quantptr)); + Inc(FAST_FLOAT_PTR(wsptr)); + end; + + { Pass 2: process rows from work array, store into output array. } + { Note that we must descale the results by a factor of 8 = 2**3. } + + wsptr := @workspace; + for ctr := 0 to pred(DCTSIZE) do + begin + outptr := JSAMPROW(@(output_buf^[ctr]^[output_col])); + { Rows of zeroes can be exploited in the same way as we did with columns. + However, the column calculation has created many nonzero AC terms, so + the simplification applies less often (typically 5% to 10% of the time). + And testing floats for zero is relatively expensive, so we don't bother. } + + { Even part } + + tmp10 := wsptr^[0] + wsptr^[4]; + tmp11 := wsptr^[0] - wsptr^[4]; + + tmp13 := wsptr^[2] + wsptr^[6]; + tmp12 := (wsptr^[2] - wsptr^[6]) * ({FAST_FLOAT}(1.414213562)) - tmp13; + + tmp0 := tmp10 + tmp13; + tmp3 := tmp10 - tmp13; + tmp1 := tmp11 + tmp12; + tmp2 := tmp11 - tmp12; + + { Odd part } + + z13 := wsptr^[5] + wsptr^[3]; + z10 := wsptr^[5] - wsptr^[3]; + z11 := wsptr^[1] + wsptr^[7]; + z12 := wsptr^[1] - wsptr^[7]; + + tmp7 := z11 + z13; + tmp11 := (z11 - z13) * ({FAST_FLOAT}(1.414213562)); + + z5 := (z10 + z12) * ({FAST_FLOAT}(1.847759065)); { 2*c2 } + tmp10 := ({FAST_FLOAT}(1.082392200)) * z12 - z5; { 2*(c2-c6) } + tmp12 := ({FAST_FLOAT}(-2.613125930)) * z10 + z5; { -2*(c2+c6) } + + tmp6 := tmp12 - tmp7; + tmp5 := tmp11 - tmp6; + tmp4 := tmp10 + tmp5; + + { Final output stage: scale down by a factor of 8 and range-limit } + + outptr^[0] := range_limit^[ int(DESCALE( INT32(Round((tmp0 + tmp7))), 3)) + and RANGE_MASK]; + outptr^[7] := range_limit^[ int(DESCALE( INT32(Round((tmp0 - tmp7))), 3)) + and RANGE_MASK]; + outptr^[1] := range_limit^[ int(DESCALE( INT32(Round((tmp1 + tmp6))), 3)) + and RANGE_MASK]; + outptr^[6] := range_limit^[ int(DESCALE( INT32(Round((tmp1 - tmp6))), 3)) + and RANGE_MASK]; + outptr^[2] := range_limit^[ int(DESCALE( INT32(Round((tmp2 + tmp5))), 3)) + and RANGE_MASK]; + outptr^[5] := range_limit^[ int(DESCALE( INT32(Round((tmp2 - tmp5))), 3)) + and RANGE_MASK]; + outptr^[4] := range_limit^[ int(DESCALE( INT32(Round((tmp3 + tmp4))), 3)) + and RANGE_MASK]; + outptr^[3] := range_limit^[ int(DESCALE( INT32(Round((tmp3 - tmp4))), 3)) + and RANGE_MASK]; + + Inc(FAST_FLOAT_PTR(wsptr), DCTSIZE); { advance pointer to next row } + end; +end; + +end. diff --git a/Imaging/JpegLib/imjidctfst.pas b/Imaging/JpegLib/imjidctfst.pas index 6b1dd9b..0b336d5 100644 --- a/Imaging/JpegLib/imjidctfst.pas +++ b/Imaging/JpegLib/imjidctfst.pas @@ -1,410 +1,410 @@ -unit imjidctfst; - -{ This file contains a fast, not so accurate integer implementation of the - inverse DCT (Discrete Cosine Transform). In the IJG code, this routine - must also perform dequantization of the input coefficients. - - A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT - on each row (or vice versa, but it's more convenient to emit a row at - a time). Direct algorithms are also available, but they are much more - complex and seem not to be any faster when reduced to code. - - This implementation is based on Arai, Agui, and Nakajima's algorithm for - scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in - Japanese, but the algorithm is described in the Pennebaker & Mitchell - JPEG textbook (see REFERENCES section in file README). The following code - is based directly on figure 4-8 in P&M. - While an 8-point DCT cannot be done in less than 11 multiplies, it is - possible to arrange the computation so that many of the multiplies are - simple scalings of the final outputs. These multiplies can then be - folded into the multiplications or divisions by the JPEG quantization - table entries. The AA&N method leaves only 5 multiplies and 29 adds - to be done in the DCT itself. - The primary disadvantage of this method is that with fixed-point math, - accuracy is lost due to imprecise representation of the scaled - quantization values. The smaller the quantization table entry, the less - precise the scaled value, so this implementation does worse with high- - quality-setting files than with low-quality ones. } - -{ Original : jidctfst.c ; Copyright (C) 1994-1996, Thomas G. Lane. } - - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib, - imjdct; { Private declarations for DCT subsystem } - - -{ Perform dequantization and inverse DCT on one block of coefficients. } - -{GLOBAL} -procedure jpeg_idct_ifast (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); - -implementation - -{ This module is specialized to the case DCTSIZE = 8. } - -{$ifndef DCTSIZE_IS_8} - Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } -{$endif} - -{ Scaling decisions are generally the same as in the LL&M algorithm; - see jidctint.c for more details. However, we choose to descale - (right shift) multiplication products as soon as they are formed, - rather than carrying additional fractional bits into subsequent additions. - This compromises accuracy slightly, but it lets us save a few shifts. - More importantly, 16-bit arithmetic is then adequate (for 8-bit samples) - everywhere except in the multiplications proper; this saves a good deal - of work on 16-bit-int machines. - - The dequantized coefficients are not integers because the AA&N scaling - factors have been incorporated. We represent them scaled up by PASS1_BITS, - so that the first and second IDCT rounds have the same input scaling. - For 8-bit JSAMPLEs, we choose IFAST_SCALE_BITS = PASS1_BITS so as to - avoid a descaling shift; this compromises accuracy rather drastically - for small quantization table entries, but it saves a lot of shifts. - For 12-bit JSAMPLEs, there's no hope of using 16x16 multiplies anyway, - so we use a much larger scaling factor to preserve accuracy. - - A final compromise is to represent the multiplicative constants to only - 8 fractional bits, rather than 13. This saves some shifting work on some - machines, and may also reduce the cost of multiplication (since there - are fewer one-bits in the constants). } - -{$ifdef BITS_IN_JSAMPLE_IS_8} -const - CONST_BITS = 8; - PASS1_BITS = 2; -{$else} -const - CONST_BITS = 8; - PASS1_BITS = 1; { lose a little precision to avoid overflow } -{$endif} - - -const - FIX_1_082392200 = INT32(Round((INT32(1) shl CONST_BITS)*1.082392200)); {277} - FIX_1_414213562 = INT32(Round((INT32(1) shl CONST_BITS)*1.414213562)); {362} - FIX_1_847759065 = INT32(Round((INT32(1) shl CONST_BITS)*1.847759065)); {473} - FIX_2_613125930 = INT32(Round((INT32(1) shl CONST_BITS)*2.613125930)); {669} - - -{ Descale and correctly round an INT32 value that's scaled by N bits. - We assume RIGHT_SHIFT rounds towards minus infinity, so adding - the fudge factor is correct for either sign of X. } - -function DESCALE(x : INT32; n : int) : INT32; -var - shift_temp : INT32; -begin -{$ifdef USE_ACCURATE_ROUNDING} - shift_temp := x + (INT32(1) shl (n-1)); -{$else} -{ We can gain a little more speed, with a further compromise in accuracy, - by omitting the addition in a descaling shift. This yields an incorrectly - rounded result half the time... } - shift_temp := x; -{$endif} - -{$ifdef RIGHT_SHIFT_IS_UNSIGNED} - if shift_temp < 0 then - Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) - else -{$endif} - Descale := (shift_temp shr n); -end; - - -{ Multiply a DCTELEM variable by an INT32 constant, and immediately - descale to yield a DCTELEM result. } - - {(DCTELEM( DESCALE((var) * (const), CONST_BITS))} - function Multiply(Avar, Aconst: Integer): DCTELEM; - begin - Multiply := DCTELEM( Avar*INT32(Aconst) div (INT32(1) shl CONST_BITS)); - end; - - -{ Dequantize a coefficient by multiplying it by the multiplier-table - entry; produce a DCTELEM result. For 8-bit data a 16x16->16 - multiplication will do. For 12-bit data, the multiplier table is - declared INT32, so a 32-bit multiply will be used. } - -{$ifdef BITS_IN_JSAMPLE_IS_8} - function DEQUANTIZE(coef,quantval : int) : int; - begin - Dequantize := ( IFAST_MULT_TYPE(coef) * quantval); - end; -{$else} - function DEQUANTIZE(coef,quantval : INT32) : int; - begin - Dequantize := DESCALE((coef)*(quantval), IFAST_SCALE_BITS-PASS1_BITS); - end; -{$endif} - - -{ Like DESCALE, but applies to a DCTELEM and produces an int. - We assume that int right shift is unsigned if INT32 right shift is. } - -function IDESCALE(x : DCTELEM; n : int) : int; -{$ifdef BITS_IN_JSAMPLE_IS_8} -const - DCTELEMBITS = 16; { DCTELEM may be 16 or 32 bits } -{$else} -const - DCTELEMBITS = 32; { DCTELEM must be 32 bits } -{$endif} -var - ishift_temp : DCTELEM; -begin -{$ifndef USE_ACCURATE_ROUNDING} - ishift_temp := x + (INT32(1) shl (n-1)); -{$else} -{ We can gain a little more speed, with a further compromise in accuracy, - by omitting the addition in a descaling shift. This yields an incorrectly - rounded result half the time... } - ishift_temp := x; -{$endif} - -{$ifdef RIGHT_SHIFT_IS_UNSIGNED} - if ishift_temp < 0 then - IDescale := (ishift_temp shr n) - or ((not DCTELEM(0)) shl (DCTELEMBITS-n)) - else -{$endif} - IDescale := (ishift_temp shr n); -end; - - - -{ Perform dequantization and inverse DCT on one block of coefficients. } - -{GLOBAL} -procedure jpeg_idct_ifast (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); -type - PWorkspace = ^TWorkspace; - TWorkspace = coef_bits_field; { buffers data between passes } -var - tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : DCTELEM; - tmp10, tmp11, tmp12, tmp13 : DCTELEM; - z5, z10, z11, z12, z13 : DCTELEM; - inptr : JCOEFPTR; - quantptr : IFAST_MULT_TYPE_FIELD_PTR; - wsptr : PWorkspace; - outptr : JSAMPROW; - range_limit : JSAMPROW; - ctr : int; - workspace : TWorkspace; { buffers data between passes } - {SHIFT_TEMPS} { for DESCALE } - {ISHIFT_TEMPS} { for IDESCALE } -var - dcval : int; -var - dcval_ : JSAMPLE; -begin -{ Each IDCT routine is responsible for range-limiting its results and - converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could - be quite far out of range if the input data is corrupt, so a bulletproof - range-limiting step is required. We use a mask-and-table-lookup method - to do the combined operations quickly. See the comments with - prepare_range_limit_table (in jdmaster.c) for more info. } - - range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); - { Pass 1: process columns from input, store into work array. } - - inptr := coef_block; - quantptr := IFAST_MULT_TYPE_FIELD_PTR(compptr^.dct_table); - wsptr := @workspace; - for ctr := pred(DCTSIZE) downto 0 do - begin - { Due to quantization, we will usually find that many of the input - coefficients are zero, especially the AC terms. We can exploit this - by short-circuiting the IDCT calculation for any column in which all - the AC terms are zero. In that case each output is equal to the - DC coefficient (with scale factor as needed). - With typical images and quantization tables, half or more of the - column DCT calculations can be simplified this way. } - - if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and (inptr^[DCTSIZE*3]=0) and - (inptr^[DCTSIZE*4]=0) and (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and - (inptr^[DCTSIZE*7]=0) then - begin - { AC terms all zero } - dcval := int(DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0])); - - wsptr^[DCTSIZE*0] := dcval; - wsptr^[DCTSIZE*1] := dcval; - wsptr^[DCTSIZE*2] := dcval; - wsptr^[DCTSIZE*3] := dcval; - wsptr^[DCTSIZE*4] := dcval; - wsptr^[DCTSIZE*5] := dcval; - wsptr^[DCTSIZE*6] := dcval; - wsptr^[DCTSIZE*7] := dcval; - - Inc(JCOEF_PTR(inptr)); { advance pointers to next column } - Inc(IFAST_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - continue; - end; - - { Even part } - - tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); - tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]); - tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]); - tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]); - - tmp10 := tmp0 + tmp2; { phase 3 } - tmp11 := tmp0 - tmp2; - - tmp13 := tmp1 + tmp3; { phases 5-3 } - tmp12 := MULTIPLY(tmp1 - tmp3, FIX_1_414213562) - tmp13; { 2*c4 } - - tmp0 := tmp10 + tmp13; { phase 2 } - tmp3 := tmp10 - tmp13; - tmp1 := tmp11 + tmp12; - tmp2 := tmp11 - tmp12; - - { Odd part } - - tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]); - tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]); - tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]); - tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]); - - z13 := tmp6 + tmp5; { phase 6 } - z10 := tmp6 - tmp5; - z11 := tmp4 + tmp7; - z12 := tmp4 - tmp7; - - tmp7 := z11 + z13; { phase 5 } - tmp11 := MULTIPLY(z11 - z13, FIX_1_414213562); { 2*c4 } - - z5 := MULTIPLY(z10 + z12, FIX_1_847759065); { 2*c2 } - tmp10 := MULTIPLY(z12, FIX_1_082392200) - z5; { 2*(c2-c6) } - tmp12 := MULTIPLY(z10, - FIX_2_613125930) + z5; { -2*(c2+c6) } - - tmp6 := tmp12 - tmp7; { phase 2 } - tmp5 := tmp11 - tmp6; - tmp4 := tmp10 + tmp5; - - wsptr^[DCTSIZE*0] := int (tmp0 + tmp7); - wsptr^[DCTSIZE*7] := int (tmp0 - tmp7); - wsptr^[DCTSIZE*1] := int (tmp1 + tmp6); - wsptr^[DCTSIZE*6] := int (tmp1 - tmp6); - wsptr^[DCTSIZE*2] := int (tmp2 + tmp5); - wsptr^[DCTSIZE*5] := int (tmp2 - tmp5); - wsptr^[DCTSIZE*4] := int (tmp3 + tmp4); - wsptr^[DCTSIZE*3] := int (tmp3 - tmp4); - - Inc(JCOEF_PTR(inptr)); { advance pointers to next column } - Inc(IFAST_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - end; - - { Pass 2: process rows from work array, store into output array. } - { Note that we must descale the results by a factor of 8 == 2**3, } - { and also undo the PASS1_BITS scaling. } - - wsptr := @workspace; - for ctr := 0 to pred(DCTSIZE) do - begin - outptr := JSAMPROW(@output_buf^[ctr]^[output_col]); - { Rows of zeroes can be exploited in the same way as we did with columns. - However, the column calculation has created many nonzero AC terms, so - the simplification applies less often (typically 5% to 10% of the time). - On machines with very fast multiplication, it's possible that the - test takes more time than it's worth. In that case this section - may be commented out. } - -{$ifndef NO_ZERO_ROW_TEST} - if (wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0) and - (wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0) then - begin - { AC terms all zero } - dcval_ := range_limit^[IDESCALE(wsptr^[0], PASS1_BITS+3) - and RANGE_MASK]; - - outptr^[0] := dcval_; - outptr^[1] := dcval_; - outptr^[2] := dcval_; - outptr^[3] := dcval_; - outptr^[4] := dcval_; - outptr^[5] := dcval_; - outptr^[6] := dcval_; - outptr^[7] := dcval_; - - Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } - continue; - end; -{$endif} - - { Even part } - - tmp10 := (DCTELEM(wsptr^[0]) + DCTELEM(wsptr^[4])); - tmp11 := (DCTELEM(wsptr^[0]) - DCTELEM(wsptr^[4])); - - tmp13 := (DCTELEM(wsptr^[2]) + DCTELEM(wsptr^[6])); - tmp12 := MULTIPLY(DCTELEM(wsptr^[2]) - DCTELEM(wsptr^[6]), FIX_1_414213562) - - tmp13; - - tmp0 := tmp10 + tmp13; - tmp3 := tmp10 - tmp13; - tmp1 := tmp11 + tmp12; - tmp2 := tmp11 - tmp12; - - { Odd part } - - z13 := DCTELEM(wsptr^[5]) + DCTELEM(wsptr^[3]); - z10 := DCTELEM(wsptr^[5]) - DCTELEM(wsptr^[3]); - z11 := DCTELEM(wsptr^[1]) + DCTELEM(wsptr^[7]); - z12 := DCTELEM(wsptr^[1]) - DCTELEM(wsptr^[7]); - - tmp7 := z11 + z13; { phase 5 } - tmp11 := MULTIPLY(z11 - z13, FIX_1_414213562); { 2*c4 } - - z5 := MULTIPLY(z10 + z12, FIX_1_847759065); { 2*c2 } - tmp10 := MULTIPLY(z12, FIX_1_082392200) - z5; { 2*(c2-c6) } - tmp12 := MULTIPLY(z10, - FIX_2_613125930) + z5; { -2*(c2+c6) } - - tmp6 := tmp12 - tmp7; { phase 2 } - tmp5 := tmp11 - tmp6; - tmp4 := tmp10 + tmp5; - - { Final output stage: scale down by a factor of 8 and range-limit } - - outptr^[0] := range_limit^[IDESCALE(tmp0 + tmp7, PASS1_BITS+3) - and RANGE_MASK]; - outptr^[7] := range_limit^[IDESCALE(tmp0 - tmp7, PASS1_BITS+3) - and RANGE_MASK]; - outptr^[1] := range_limit^[IDESCALE(tmp1 + tmp6, PASS1_BITS+3) - and RANGE_MASK]; - outptr^[6] := range_limit^[IDESCALE(tmp1 - tmp6, PASS1_BITS+3) - and RANGE_MASK]; - outptr^[2] := range_limit^[IDESCALE(tmp2 + tmp5, PASS1_BITS+3) - and RANGE_MASK]; - outptr^[5] := range_limit^[IDESCALE(tmp2 - tmp5, PASS1_BITS+3) - and RANGE_MASK]; - outptr^[4] := range_limit^[IDESCALE(tmp3 + tmp4, PASS1_BITS+3) - and RANGE_MASK]; - outptr^[3] := range_limit^[IDESCALE(tmp3 - tmp4, PASS1_BITS+3) - and RANGE_MASK]; - - Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } - end; -end; - -end. +unit imjidctfst; + +{ This file contains a fast, not so accurate integer implementation of the + inverse DCT (Discrete Cosine Transform). In the IJG code, this routine + must also perform dequantization of the input coefficients. + + A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT + on each row (or vice versa, but it's more convenient to emit a row at + a time). Direct algorithms are also available, but they are much more + complex and seem not to be any faster when reduced to code. + + This implementation is based on Arai, Agui, and Nakajima's algorithm for + scaled DCT. Their original paper (Trans. IEICE E-71(11):1095) is in + Japanese, but the algorithm is described in the Pennebaker & Mitchell + JPEG textbook (see REFERENCES section in file README). The following code + is based directly on figure 4-8 in P&M. + While an 8-point DCT cannot be done in less than 11 multiplies, it is + possible to arrange the computation so that many of the multiplies are + simple scalings of the final outputs. These multiplies can then be + folded into the multiplications or divisions by the JPEG quantization + table entries. The AA&N method leaves only 5 multiplies and 29 adds + to be done in the DCT itself. + The primary disadvantage of this method is that with fixed-point math, + accuracy is lost due to imprecise representation of the scaled + quantization values. The smaller the quantization table entry, the less + precise the scaled value, so this implementation does worse with high- + quality-setting files than with low-quality ones. } + +{ Original : jidctfst.c ; Copyright (C) 1994-1996, Thomas G. Lane. } + + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib, + imjdct; { Private declarations for DCT subsystem } + + +{ Perform dequantization and inverse DCT on one block of coefficients. } + +{GLOBAL} +procedure jpeg_idct_ifast (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); + +implementation + +{ This module is specialized to the case DCTSIZE = 8. } + +{$ifndef DCTSIZE_IS_8} + Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } +{$endif} + +{ Scaling decisions are generally the same as in the LL&M algorithm; + see jidctint.c for more details. However, we choose to descale + (right shift) multiplication products as soon as they are formed, + rather than carrying additional fractional bits into subsequent additions. + This compromises accuracy slightly, but it lets us save a few shifts. + More importantly, 16-bit arithmetic is then adequate (for 8-bit samples) + everywhere except in the multiplications proper; this saves a good deal + of work on 16-bit-int machines. + + The dequantized coefficients are not integers because the AA&N scaling + factors have been incorporated. We represent them scaled up by PASS1_BITS, + so that the first and second IDCT rounds have the same input scaling. + For 8-bit JSAMPLEs, we choose IFAST_SCALE_BITS = PASS1_BITS so as to + avoid a descaling shift; this compromises accuracy rather drastically + for small quantization table entries, but it saves a lot of shifts. + For 12-bit JSAMPLEs, there's no hope of using 16x16 multiplies anyway, + so we use a much larger scaling factor to preserve accuracy. + + A final compromise is to represent the multiplicative constants to only + 8 fractional bits, rather than 13. This saves some shifting work on some + machines, and may also reduce the cost of multiplication (since there + are fewer one-bits in the constants). } + +{$ifdef BITS_IN_JSAMPLE_IS_8} +const + CONST_BITS = 8; + PASS1_BITS = 2; +{$else} +const + CONST_BITS = 8; + PASS1_BITS = 1; { lose a little precision to avoid overflow } +{$endif} + + +const + FIX_1_082392200 = INT32(Round((INT32(1) shl CONST_BITS)*1.082392200)); {277} + FIX_1_414213562 = INT32(Round((INT32(1) shl CONST_BITS)*1.414213562)); {362} + FIX_1_847759065 = INT32(Round((INT32(1) shl CONST_BITS)*1.847759065)); {473} + FIX_2_613125930 = INT32(Round((INT32(1) shl CONST_BITS)*2.613125930)); {669} + + +{ Descale and correctly round an INT32 value that's scaled by N bits. + We assume RIGHT_SHIFT rounds towards minus infinity, so adding + the fudge factor is correct for either sign of X. } + +function DESCALE(x : INT32; n : int) : INT32; +var + shift_temp : INT32; +begin +{$ifdef USE_ACCURATE_ROUNDING} + shift_temp := x + (INT32(1) shl (n-1)); +{$else} +{ We can gain a little more speed, with a further compromise in accuracy, + by omitting the addition in a descaling shift. This yields an incorrectly + rounded result half the time... } + shift_temp := x; +{$endif} + +{$ifdef RIGHT_SHIFT_IS_UNSIGNED} + if shift_temp < 0 then + Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) + else +{$endif} + Descale := (shift_temp shr n); +end; + + +{ Multiply a DCTELEM variable by an INT32 constant, and immediately + descale to yield a DCTELEM result. } + + {(DCTELEM( DESCALE((var) * (const), CONST_BITS))} + function Multiply(Avar, Aconst: Integer): DCTELEM; + begin + Multiply := DCTELEM( Avar*INT32(Aconst) div (INT32(1) shl CONST_BITS)); + end; + + +{ Dequantize a coefficient by multiplying it by the multiplier-table + entry; produce a DCTELEM result. For 8-bit data a 16x16->16 + multiplication will do. For 12-bit data, the multiplier table is + declared INT32, so a 32-bit multiply will be used. } + +{$ifdef BITS_IN_JSAMPLE_IS_8} + function DEQUANTIZE(coef,quantval : int) : int; + begin + Dequantize := ( IFAST_MULT_TYPE(coef) * quantval); + end; +{$else} + function DEQUANTIZE(coef,quantval : INT32) : int; + begin + Dequantize := DESCALE((coef)*(quantval), IFAST_SCALE_BITS-PASS1_BITS); + end; +{$endif} + + +{ Like DESCALE, but applies to a DCTELEM and produces an int. + We assume that int right shift is unsigned if INT32 right shift is. } + +function IDESCALE(x : DCTELEM; n : int) : int; +{$ifdef BITS_IN_JSAMPLE_IS_8} +const + DCTELEMBITS = 16; { DCTELEM may be 16 or 32 bits } +{$else} +const + DCTELEMBITS = 32; { DCTELEM must be 32 bits } +{$endif} +var + ishift_temp : DCTELEM; +begin +{$ifndef USE_ACCURATE_ROUNDING} + ishift_temp := x + (INT32(1) shl (n-1)); +{$else} +{ We can gain a little more speed, with a further compromise in accuracy, + by omitting the addition in a descaling shift. This yields an incorrectly + rounded result half the time... } + ishift_temp := x; +{$endif} + +{$ifdef RIGHT_SHIFT_IS_UNSIGNED} + if ishift_temp < 0 then + IDescale := (ishift_temp shr n) + or ((not DCTELEM(0)) shl (DCTELEMBITS-n)) + else +{$endif} + IDescale := (ishift_temp shr n); +end; + + + +{ Perform dequantization and inverse DCT on one block of coefficients. } + +{GLOBAL} +procedure jpeg_idct_ifast (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); +type + PWorkspace = ^TWorkspace; + TWorkspace = coef_bits_field; { buffers data between passes } +var + tmp0, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7 : DCTELEM; + tmp10, tmp11, tmp12, tmp13 : DCTELEM; + z5, z10, z11, z12, z13 : DCTELEM; + inptr : JCOEFPTR; + quantptr : IFAST_MULT_TYPE_FIELD_PTR; + wsptr : PWorkspace; + outptr : JSAMPROW; + range_limit : JSAMPROW; + ctr : int; + workspace : TWorkspace; { buffers data between passes } + {SHIFT_TEMPS} { for DESCALE } + {ISHIFT_TEMPS} { for IDESCALE } +var + dcval : int; +var + dcval_ : JSAMPLE; +begin +{ Each IDCT routine is responsible for range-limiting its results and + converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could + be quite far out of range if the input data is corrupt, so a bulletproof + range-limiting step is required. We use a mask-and-table-lookup method + to do the combined operations quickly. See the comments with + prepare_range_limit_table (in jdmaster.c) for more info. } + + range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); + { Pass 1: process columns from input, store into work array. } + + inptr := coef_block; + quantptr := IFAST_MULT_TYPE_FIELD_PTR(compptr^.dct_table); + wsptr := @workspace; + for ctr := pred(DCTSIZE) downto 0 do + begin + { Due to quantization, we will usually find that many of the input + coefficients are zero, especially the AC terms. We can exploit this + by short-circuiting the IDCT calculation for any column in which all + the AC terms are zero. In that case each output is equal to the + DC coefficient (with scale factor as needed). + With typical images and quantization tables, half or more of the + column DCT calculations can be simplified this way. } + + if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and (inptr^[DCTSIZE*3]=0) and + (inptr^[DCTSIZE*4]=0) and (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and + (inptr^[DCTSIZE*7]=0) then + begin + { AC terms all zero } + dcval := int(DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0])); + + wsptr^[DCTSIZE*0] := dcval; + wsptr^[DCTSIZE*1] := dcval; + wsptr^[DCTSIZE*2] := dcval; + wsptr^[DCTSIZE*3] := dcval; + wsptr^[DCTSIZE*4] := dcval; + wsptr^[DCTSIZE*5] := dcval; + wsptr^[DCTSIZE*6] := dcval; + wsptr^[DCTSIZE*7] := dcval; + + Inc(JCOEF_PTR(inptr)); { advance pointers to next column } + Inc(IFAST_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + continue; + end; + + { Even part } + + tmp0 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); + tmp1 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]); + tmp2 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]); + tmp3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]); + + tmp10 := tmp0 + tmp2; { phase 3 } + tmp11 := tmp0 - tmp2; + + tmp13 := tmp1 + tmp3; { phases 5-3 } + tmp12 := MULTIPLY(tmp1 - tmp3, FIX_1_414213562) - tmp13; { 2*c4 } + + tmp0 := tmp10 + tmp13; { phase 2 } + tmp3 := tmp10 - tmp13; + tmp1 := tmp11 + tmp12; + tmp2 := tmp11 - tmp12; + + { Odd part } + + tmp4 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]); + tmp5 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]); + tmp6 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]); + tmp7 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]); + + z13 := tmp6 + tmp5; { phase 6 } + z10 := tmp6 - tmp5; + z11 := tmp4 + tmp7; + z12 := tmp4 - tmp7; + + tmp7 := z11 + z13; { phase 5 } + tmp11 := MULTIPLY(z11 - z13, FIX_1_414213562); { 2*c4 } + + z5 := MULTIPLY(z10 + z12, FIX_1_847759065); { 2*c2 } + tmp10 := MULTIPLY(z12, FIX_1_082392200) - z5; { 2*(c2-c6) } + tmp12 := MULTIPLY(z10, - FIX_2_613125930) + z5; { -2*(c2+c6) } + + tmp6 := tmp12 - tmp7; { phase 2 } + tmp5 := tmp11 - tmp6; + tmp4 := tmp10 + tmp5; + + wsptr^[DCTSIZE*0] := int (tmp0 + tmp7); + wsptr^[DCTSIZE*7] := int (tmp0 - tmp7); + wsptr^[DCTSIZE*1] := int (tmp1 + tmp6); + wsptr^[DCTSIZE*6] := int (tmp1 - tmp6); + wsptr^[DCTSIZE*2] := int (tmp2 + tmp5); + wsptr^[DCTSIZE*5] := int (tmp2 - tmp5); + wsptr^[DCTSIZE*4] := int (tmp3 + tmp4); + wsptr^[DCTSIZE*3] := int (tmp3 - tmp4); + + Inc(JCOEF_PTR(inptr)); { advance pointers to next column } + Inc(IFAST_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + end; + + { Pass 2: process rows from work array, store into output array. } + { Note that we must descale the results by a factor of 8 == 2**3, } + { and also undo the PASS1_BITS scaling. } + + wsptr := @workspace; + for ctr := 0 to pred(DCTSIZE) do + begin + outptr := JSAMPROW(@output_buf^[ctr]^[output_col]); + { Rows of zeroes can be exploited in the same way as we did with columns. + However, the column calculation has created many nonzero AC terms, so + the simplification applies less often (typically 5% to 10% of the time). + On machines with very fast multiplication, it's possible that the + test takes more time than it's worth. In that case this section + may be commented out. } + +{$ifndef NO_ZERO_ROW_TEST} + if (wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0) and + (wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0) then + begin + { AC terms all zero } + dcval_ := range_limit^[IDESCALE(wsptr^[0], PASS1_BITS+3) + and RANGE_MASK]; + + outptr^[0] := dcval_; + outptr^[1] := dcval_; + outptr^[2] := dcval_; + outptr^[3] := dcval_; + outptr^[4] := dcval_; + outptr^[5] := dcval_; + outptr^[6] := dcval_; + outptr^[7] := dcval_; + + Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } + continue; + end; +{$endif} + + { Even part } + + tmp10 := (DCTELEM(wsptr^[0]) + DCTELEM(wsptr^[4])); + tmp11 := (DCTELEM(wsptr^[0]) - DCTELEM(wsptr^[4])); + + tmp13 := (DCTELEM(wsptr^[2]) + DCTELEM(wsptr^[6])); + tmp12 := MULTIPLY(DCTELEM(wsptr^[2]) - DCTELEM(wsptr^[6]), FIX_1_414213562) + - tmp13; + + tmp0 := tmp10 + tmp13; + tmp3 := tmp10 - tmp13; + tmp1 := tmp11 + tmp12; + tmp2 := tmp11 - tmp12; + + { Odd part } + + z13 := DCTELEM(wsptr^[5]) + DCTELEM(wsptr^[3]); + z10 := DCTELEM(wsptr^[5]) - DCTELEM(wsptr^[3]); + z11 := DCTELEM(wsptr^[1]) + DCTELEM(wsptr^[7]); + z12 := DCTELEM(wsptr^[1]) - DCTELEM(wsptr^[7]); + + tmp7 := z11 + z13; { phase 5 } + tmp11 := MULTIPLY(z11 - z13, FIX_1_414213562); { 2*c4 } + + z5 := MULTIPLY(z10 + z12, FIX_1_847759065); { 2*c2 } + tmp10 := MULTIPLY(z12, FIX_1_082392200) - z5; { 2*(c2-c6) } + tmp12 := MULTIPLY(z10, - FIX_2_613125930) + z5; { -2*(c2+c6) } + + tmp6 := tmp12 - tmp7; { phase 2 } + tmp5 := tmp11 - tmp6; + tmp4 := tmp10 + tmp5; + + { Final output stage: scale down by a factor of 8 and range-limit } + + outptr^[0] := range_limit^[IDESCALE(tmp0 + tmp7, PASS1_BITS+3) + and RANGE_MASK]; + outptr^[7] := range_limit^[IDESCALE(tmp0 - tmp7, PASS1_BITS+3) + and RANGE_MASK]; + outptr^[1] := range_limit^[IDESCALE(tmp1 + tmp6, PASS1_BITS+3) + and RANGE_MASK]; + outptr^[6] := range_limit^[IDESCALE(tmp1 - tmp6, PASS1_BITS+3) + and RANGE_MASK]; + outptr^[2] := range_limit^[IDESCALE(tmp2 + tmp5, PASS1_BITS+3) + and RANGE_MASK]; + outptr^[5] := range_limit^[IDESCALE(tmp2 - tmp5, PASS1_BITS+3) + and RANGE_MASK]; + outptr^[4] := range_limit^[IDESCALE(tmp3 + tmp4, PASS1_BITS+3) + and RANGE_MASK]; + outptr^[3] := range_limit^[IDESCALE(tmp3 - tmp4, PASS1_BITS+3) + and RANGE_MASK]; + + Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } + end; +end; + +end. diff --git a/Imaging/JpegLib/imjidctint.pas b/Imaging/JpegLib/imjidctint.pas index f46cc8f..7989ae6 100644 --- a/Imaging/JpegLib/imjidctint.pas +++ b/Imaging/JpegLib/imjidctint.pas @@ -1,440 +1,440 @@ -unit imjidctint; -{$Q+} - -{ This file contains a slow-but-accurate integer implementation of the - inverse DCT (Discrete Cosine Transform). In the IJG code, this routine - must also perform dequantization of the input coefficients. - - A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT - on each row (or vice versa, but it's more convenient to emit a row at - a time). Direct algorithms are also available, but they are much more - complex and seem not to be any faster when reduced to code. - - This implementation is based on an algorithm described in - C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT - Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics, - Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991. - The primary algorithm described there uses 11 multiplies and 29 adds. - We use their alternate method with 12 multiplies and 32 adds. - The advantage of this method is that no data path contains more than one - multiplication; this allows a very simple and accurate implementation in - scaled fixed-point arithmetic, with a minimal number of shifts. } - -{ Original : jidctint.c ; Copyright (C) 1991-1998, Thomas G. Lane. } - - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib, - imjdct; { Private declarations for DCT subsystem } - -{ Perform dequantization and inverse DCT on one block of coefficients. } - -{GLOBAL} -procedure jpeg_idct_islow (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); - -implementation - -{ This module is specialized to the case DCTSIZE = 8. } - -{$ifndef DCTSIZE_IS_8} - Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } -{$endif} - -{ The poop on this scaling stuff is as follows: - - Each 1-D IDCT step produces outputs which are a factor of sqrt(N) - larger than the true IDCT outputs. The final outputs are therefore - a factor of N larger than desired; since N=8 this can be cured by - a simple right shift at the end of the algorithm. The advantage of - this arrangement is that we save two multiplications per 1-D IDCT, - because the y0 and y4 inputs need not be divided by sqrt(N). - - We have to do addition and subtraction of the integer inputs, which - is no problem, and multiplication by fractional constants, which is - a problem to do in integer arithmetic. We multiply all the constants - by CONST_SCALE and convert them to integer constants (thus retaining - CONST_BITS bits of precision in the constants). After doing a - multiplication we have to divide the product by CONST_SCALE, with proper - rounding, to produce the correct output. This division can be done - cheaply as a right shift of CONST_BITS bits. We postpone shifting - as long as possible so that partial sums can be added together with - full fractional precision. - - The outputs of the first pass are scaled up by PASS1_BITS bits so that - they are represented to better-than-integral precision. These outputs - require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word - with the recommended scaling. (To scale up 12-bit sample data further, an - intermediate INT32 array would be needed.) - - To avoid overflow of the 32-bit intermediate results in pass 2, we must - have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis - shows that the values given below are the most effective. } - -{$ifdef BITS_IN_JSAMPLE_IS_8} -const - CONST_BITS = 13; - PASS1_BITS = 2; -{$else} -const - CONST_BITS = 13; - PASS1_BITS = 1; { lose a little precision to avoid overflow } -{$endif} - -const - CONST_SCALE = (INT32(1) shl CONST_BITS); - -const - FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446} - FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196} - FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433} - FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270} - FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373} - FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633} - FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299} - FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137} - FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069} - FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819} - FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995} - FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172} - - - -{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result. - For 8-bit samples with the recommended scaling, all the variable - and constant values involved are no more than 16 bits wide, so a - 16x16->32 bit multiply can be used instead of a full 32x32 multiply. - For 12-bit samples, a full 32-bit multiplication will be needed. } - -{$ifdef BITS_IN_JSAMPLE_IS_8} - - {$IFDEF BASM16} - {$IFNDEF WIN32} - {MULTIPLY16C16(var,const)} - function Multiply(X, Y: Integer): integer; assembler; - asm - mov ax, X - imul Y - mov al, ah - mov ah, dl - end; - {$ENDIF} - {$ENDIF} - - function Multiply(X, Y: INT32): INT32; - begin - Multiply := INT32(X) * INT32(Y); - end; - - -{$else} - {#define MULTIPLY(var,const) ((var) * (const))} - function Multiply(X, Y: INT32): INT32; - begin - Multiply := INT32(X) * INT32(Y); - end; -{$endif} - - -{ Dequantize a coefficient by multiplying it by the multiplier-table - entry; produce an int result. In this module, both inputs and result - are 16 bits or less, so either int or short multiply will work. } - -function DEQUANTIZE(coef,quantval : int) : int; -begin - Dequantize := ( ISLOW_MULT_TYPE(coef) * quantval); -end; - -{ Descale and correctly round an INT32 value that's scaled by N bits. - We assume RIGHT_SHIFT rounds towards minus infinity, so adding - the fudge factor is correct for either sign of X. } - -function DESCALE(x : INT32; n : int) : INT32; -var - shift_temp : INT32; -begin -{$ifdef RIGHT_SHIFT_IS_UNSIGNED} - shift_temp := x + (INT32(1) shl (n-1)); - if shift_temp < 0 then - Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) - else - Descale := (shift_temp shr n); -{$else} - Descale := (x + (INT32(1) shl (n-1)) shr n; -{$endif} -end; - -{ Perform dequantization and inverse DCT on one block of coefficients. } - -{GLOBAL} -procedure jpeg_idct_islow (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); -type - PWorkspace = ^TWorkspace; - TWorkspace = coef_bits_field; { buffers data between passes } -var - tmp0, tmp1, tmp2, tmp3 : INT32; - tmp10, tmp11, tmp12, tmp13 : INT32; - z1, z2, z3, z4, z5 : INT32; - inptr : JCOEFPTR; - quantptr : ISLOW_MULT_TYPE_FIELD_PTR; - wsptr : PWorkspace; - outptr : JSAMPROW; - range_limit : JSAMPROW; - ctr : int; - workspace : TWorkspace; - {SHIFT_TEMPS} -var - dcval : int; -var - dcval_ : JSAMPLE; -begin -{ Each IDCT routine is responsible for range-limiting its results and - converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could - be quite far out of range if the input data is corrupt, so a bulletproof - range-limiting step is required. We use a mask-and-table-lookup method - to do the combined operations quickly. See the comments with - prepare_range_limit_table (in jdmaster.c) for more info. } - - range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); - - - { Pass 1: process columns from input, store into work array. } - { Note results are scaled up by sqrt(8) compared to a true IDCT; } - { furthermore, we scale the results by 2**PASS1_BITS. } - - inptr := coef_block; - quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); - wsptr := PWorkspace(@workspace); - for ctr := pred(DCTSIZE) downto 0 do - begin - { Due to quantization, we will usually find that many of the input - coefficients are zero, especially the AC terms. We can exploit this - by short-circuiting the IDCT calculation for any column in which all - the AC terms are zero. In that case each output is equal to the - DC coefficient (with scale factor as needed). - With typical images and quantization tables, half or more of the - column DCT calculations can be simplified this way. } - - if ((inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and - (inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and - (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and - (inptr^[DCTSIZE*7]=0)) then - begin - { AC terms all zero } - dcval := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]) shl PASS1_BITS; - - wsptr^[DCTSIZE*0] := dcval; - wsptr^[DCTSIZE*1] := dcval; - wsptr^[DCTSIZE*2] := dcval; - wsptr^[DCTSIZE*3] := dcval; - wsptr^[DCTSIZE*4] := dcval; - wsptr^[DCTSIZE*5] := dcval; - wsptr^[DCTSIZE*6] := dcval; - wsptr^[DCTSIZE*7] := dcval; - - Inc(JCOEF_PTR(inptr)); { advance pointers to next column } - Inc(ISLOW_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - continue; - end; - - { Even part: reverse the even part of the forward DCT. } - { The rotator is sqrt(2)*c(-6). } - - z2 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]); - z3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]); - - z1 := MULTIPLY(z2 + z3, FIX_0_541196100); - tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065); - tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865); - - z2 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); - z3 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]); - - tmp0 := (z2 + z3) shl CONST_BITS; - tmp1 := (z2 - z3) shl CONST_BITS; - - tmp10 := tmp0 + tmp3; - tmp13 := tmp0 - tmp3; - tmp11 := tmp1 + tmp2; - tmp12 := tmp1 - tmp2; - - { Odd part per figure 8; the matrix is unitary and hence its - transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. } - - tmp0 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]); - tmp1 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]); - tmp2 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]); - tmp3 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]); - - z1 := tmp0 + tmp3; - z2 := tmp1 + tmp2; - z3 := tmp0 + tmp2; - z4 := tmp1 + tmp3; - z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } - - tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } - tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } - tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } - tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } - z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) } - z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } - z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } - z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } - - Inc(z3, z5); - Inc(z4, z5); - - Inc(tmp0, z1 + z3); - Inc(tmp1, z2 + z4); - Inc(tmp2, z2 + z3); - Inc(tmp3, z1 + z4); - - { Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 } - - wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp3, CONST_BITS-PASS1_BITS)); - wsptr^[DCTSIZE*7] := int (DESCALE(tmp10 - tmp3, CONST_BITS-PASS1_BITS)); - wsptr^[DCTSIZE*1] := int (DESCALE(tmp11 + tmp2, CONST_BITS-PASS1_BITS)); - wsptr^[DCTSIZE*6] := int (DESCALE(tmp11 - tmp2, CONST_BITS-PASS1_BITS)); - wsptr^[DCTSIZE*2] := int (DESCALE(tmp12 + tmp1, CONST_BITS-PASS1_BITS)); - wsptr^[DCTSIZE*5] := int (DESCALE(tmp12 - tmp1, CONST_BITS-PASS1_BITS)); - wsptr^[DCTSIZE*3] := int (DESCALE(tmp13 + tmp0, CONST_BITS-PASS1_BITS)); - wsptr^[DCTSIZE*4] := int (DESCALE(tmp13 - tmp0, CONST_BITS-PASS1_BITS)); - - Inc(JCOEF_PTR(inptr)); { advance pointers to next column } - Inc(ISLOW_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - end; - - { Pass 2: process rows from work array, store into output array. } - { Note that we must descale the results by a factor of 8 == 2**3, } - { and also undo the PASS1_BITS scaling. } - - wsptr := @workspace; - for ctr := 0 to pred(DCTSIZE) do - begin - outptr := output_buf^[ctr]; - Inc(JSAMPLE_PTR(outptr), output_col); - { Rows of zeroes can be exploited in the same way as we did with columns. - However, the column calculation has created many nonzero AC terms, so - the simplification applies less often (typically 5% to 10% of the time). - On machines with very fast multiplication, it's possible that the - test takes more time than it's worth. In that case this section - may be commented out. } - -{$ifndef NO_ZERO_ROW_TEST} - if ((wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0) - and (wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0)) then - begin - { AC terms all zero } - JSAMPLE(dcval_) := range_limit^[int(DESCALE(INT32(wsptr^[0]), - PASS1_BITS+3)) and RANGE_MASK]; - - outptr^[0] := dcval_; - outptr^[1] := dcval_; - outptr^[2] := dcval_; - outptr^[3] := dcval_; - outptr^[4] := dcval_; - outptr^[5] := dcval_; - outptr^[6] := dcval_; - outptr^[7] := dcval_; - - Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } - continue; - end; -{$endif} - - { Even part: reverse the even part of the forward DCT. } - { The rotator is sqrt(2)*c(-6). } - - z2 := INT32 (wsptr^[2]); - z3 := INT32 (wsptr^[6]); - - z1 := MULTIPLY(z2 + z3, FIX_0_541196100); - tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065); - tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865); - - tmp0 := (INT32(wsptr^[0]) + INT32(wsptr^[4])) shl CONST_BITS; - tmp1 := (INT32(wsptr^[0]) - INT32(wsptr^[4])) shl CONST_BITS; - - tmp10 := tmp0 + tmp3; - tmp13 := tmp0 - tmp3; - tmp11 := tmp1 + tmp2; - tmp12 := tmp1 - tmp2; - - { Odd part per figure 8; the matrix is unitary and hence its - transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. } - - tmp0 := INT32(wsptr^[7]); - tmp1 := INT32(wsptr^[5]); - tmp2 := INT32(wsptr^[3]); - tmp3 := INT32(wsptr^[1]); - - z1 := tmp0 + tmp3; - z2 := tmp1 + tmp2; - z3 := tmp0 + tmp2; - z4 := tmp1 + tmp3; - z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } - - tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } - tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } - tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } - tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } - z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) } - z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } - z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } - z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } - - Inc(z3, z5); - Inc(z4, z5); - - Inc(tmp0, z1 + z3); - Inc(tmp1, z2 + z4); - Inc(tmp2, z2 + z3); - Inc(tmp3, z1 + z4); - - { Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 } - - outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp3, - CONST_BITS+PASS1_BITS+3)) - and RANGE_MASK]; - outptr^[7] := range_limit^[ int(DESCALE(tmp10 - tmp3, - CONST_BITS+PASS1_BITS+3)) - and RANGE_MASK]; - outptr^[1] := range_limit^[ int(DESCALE(tmp11 + tmp2, - CONST_BITS+PASS1_BITS+3)) - and RANGE_MASK]; - outptr^[6] := range_limit^[ int(DESCALE(tmp11 - tmp2, - CONST_BITS+PASS1_BITS+3)) - and RANGE_MASK]; - outptr^[2] := range_limit^[ int(DESCALE(tmp12 + tmp1, - CONST_BITS+PASS1_BITS+3)) - and RANGE_MASK]; - outptr^[5] := range_limit^[ int(DESCALE(tmp12 - tmp1, - CONST_BITS+PASS1_BITS+3)) - and RANGE_MASK]; - outptr^[3] := range_limit^[ int(DESCALE(tmp13 + tmp0, - CONST_BITS+PASS1_BITS+3)) - and RANGE_MASK]; - outptr^[4] := range_limit^[ int(DESCALE(tmp13 - tmp0, - CONST_BITS+PASS1_BITS+3)) - and RANGE_MASK]; - - Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } - end; -end; - -end. +unit imjidctint; +{$Q+} + +{ This file contains a slow-but-accurate integer implementation of the + inverse DCT (Discrete Cosine Transform). In the IJG code, this routine + must also perform dequantization of the input coefficients. + + A 2-D IDCT can be done by 1-D IDCT on each column followed by 1-D IDCT + on each row (or vice versa, but it's more convenient to emit a row at + a time). Direct algorithms are also available, but they are much more + complex and seem not to be any faster when reduced to code. + + This implementation is based on an algorithm described in + C. Loeffler, A. Ligtenberg and G. Moschytz, "Practical Fast 1-D DCT + Algorithms with 11 Multiplications", Proc. Int'l. Conf. on Acoustics, + Speech, and Signal Processing 1989 (ICASSP '89), pp. 988-991. + The primary algorithm described there uses 11 multiplies and 29 adds. + We use their alternate method with 12 multiplies and 32 adds. + The advantage of this method is that no data path contains more than one + multiplication; this allows a very simple and accurate implementation in + scaled fixed-point arithmetic, with a minimal number of shifts. } + +{ Original : jidctint.c ; Copyright (C) 1991-1998, Thomas G. Lane. } + + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib, + imjdct; { Private declarations for DCT subsystem } + +{ Perform dequantization and inverse DCT on one block of coefficients. } + +{GLOBAL} +procedure jpeg_idct_islow (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); + +implementation + +{ This module is specialized to the case DCTSIZE = 8. } + +{$ifndef DCTSIZE_IS_8} + Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } +{$endif} + +{ The poop on this scaling stuff is as follows: + + Each 1-D IDCT step produces outputs which are a factor of sqrt(N) + larger than the true IDCT outputs. The final outputs are therefore + a factor of N larger than desired; since N=8 this can be cured by + a simple right shift at the end of the algorithm. The advantage of + this arrangement is that we save two multiplications per 1-D IDCT, + because the y0 and y4 inputs need not be divided by sqrt(N). + + We have to do addition and subtraction of the integer inputs, which + is no problem, and multiplication by fractional constants, which is + a problem to do in integer arithmetic. We multiply all the constants + by CONST_SCALE and convert them to integer constants (thus retaining + CONST_BITS bits of precision in the constants). After doing a + multiplication we have to divide the product by CONST_SCALE, with proper + rounding, to produce the correct output. This division can be done + cheaply as a right shift of CONST_BITS bits. We postpone shifting + as long as possible so that partial sums can be added together with + full fractional precision. + + The outputs of the first pass are scaled up by PASS1_BITS bits so that + they are represented to better-than-integral precision. These outputs + require BITS_IN_JSAMPLE + PASS1_BITS + 3 bits; this fits in a 16-bit word + with the recommended scaling. (To scale up 12-bit sample data further, an + intermediate INT32 array would be needed.) + + To avoid overflow of the 32-bit intermediate results in pass 2, we must + have BITS_IN_JSAMPLE + CONST_BITS + PASS1_BITS <= 26. Error analysis + shows that the values given below are the most effective. } + +{$ifdef BITS_IN_JSAMPLE_IS_8} +const + CONST_BITS = 13; + PASS1_BITS = 2; +{$else} +const + CONST_BITS = 13; + PASS1_BITS = 1; { lose a little precision to avoid overflow } +{$endif} + +const + CONST_SCALE = (INT32(1) shl CONST_BITS); + +const + FIX_0_298631336 = INT32(Round(CONST_SCALE * 0.298631336)); {2446} + FIX_0_390180644 = INT32(Round(CONST_SCALE * 0.390180644)); {3196} + FIX_0_541196100 = INT32(Round(CONST_SCALE * 0.541196100)); {4433} + FIX_0_765366865 = INT32(Round(CONST_SCALE * 0.765366865)); {6270} + FIX_0_899976223 = INT32(Round(CONST_SCALE * 0.899976223)); {7373} + FIX_1_175875602 = INT32(Round(CONST_SCALE * 1.175875602)); {9633} + FIX_1_501321110 = INT32(Round(CONST_SCALE * 1.501321110)); {12299} + FIX_1_847759065 = INT32(Round(CONST_SCALE * 1.847759065)); {15137} + FIX_1_961570560 = INT32(Round(CONST_SCALE * 1.961570560)); {16069} + FIX_2_053119869 = INT32(Round(CONST_SCALE * 2.053119869)); {16819} + FIX_2_562915447 = INT32(Round(CONST_SCALE * 2.562915447)); {20995} + FIX_3_072711026 = INT32(Round(CONST_SCALE * 3.072711026)); {25172} + + + +{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result. + For 8-bit samples with the recommended scaling, all the variable + and constant values involved are no more than 16 bits wide, so a + 16x16->32 bit multiply can be used instead of a full 32x32 multiply. + For 12-bit samples, a full 32-bit multiplication will be needed. } + +{$ifdef BITS_IN_JSAMPLE_IS_8} + + {$IFDEF BASM16} + {$IFNDEF WIN32} + {MULTIPLY16C16(var,const)} + function Multiply(X, Y: Integer): integer; assembler; + asm + mov ax, X + imul Y + mov al, ah + mov ah, dl + end; + {$ENDIF} + {$ENDIF} + + function Multiply(X, Y: INT32): INT32; + begin + Multiply := INT32(X) * INT32(Y); + end; + + +{$else} + {#define MULTIPLY(var,const) ((var) * (const))} + function Multiply(X, Y: INT32): INT32; + begin + Multiply := INT32(X) * INT32(Y); + end; +{$endif} + + +{ Dequantize a coefficient by multiplying it by the multiplier-table + entry; produce an int result. In this module, both inputs and result + are 16 bits or less, so either int or short multiply will work. } + +function DEQUANTIZE(coef,quantval : int) : int; +begin + Dequantize := ( ISLOW_MULT_TYPE(coef) * quantval); +end; + +{ Descale and correctly round an INT32 value that's scaled by N bits. + We assume RIGHT_SHIFT rounds towards minus infinity, so adding + the fudge factor is correct for either sign of X. } + +function DESCALE(x : INT32; n : int) : INT32; +var + shift_temp : INT32; +begin +{$ifdef RIGHT_SHIFT_IS_UNSIGNED} + shift_temp := x + (INT32(1) shl (n-1)); + if shift_temp < 0 then + Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) + else + Descale := (shift_temp shr n); +{$else} + Descale := (x + (INT32(1) shl (n-1)) shr n; +{$endif} +end; + +{ Perform dequantization and inverse DCT on one block of coefficients. } + +{GLOBAL} +procedure jpeg_idct_islow (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); +type + PWorkspace = ^TWorkspace; + TWorkspace = coef_bits_field; { buffers data between passes } +var + tmp0, tmp1, tmp2, tmp3 : INT32; + tmp10, tmp11, tmp12, tmp13 : INT32; + z1, z2, z3, z4, z5 : INT32; + inptr : JCOEFPTR; + quantptr : ISLOW_MULT_TYPE_FIELD_PTR; + wsptr : PWorkspace; + outptr : JSAMPROW; + range_limit : JSAMPROW; + ctr : int; + workspace : TWorkspace; + {SHIFT_TEMPS} +var + dcval : int; +var + dcval_ : JSAMPLE; +begin +{ Each IDCT routine is responsible for range-limiting its results and + converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could + be quite far out of range if the input data is corrupt, so a bulletproof + range-limiting step is required. We use a mask-and-table-lookup method + to do the combined operations quickly. See the comments with + prepare_range_limit_table (in jdmaster.c) for more info. } + + range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); + + + { Pass 1: process columns from input, store into work array. } + { Note results are scaled up by sqrt(8) compared to a true IDCT; } + { furthermore, we scale the results by 2**PASS1_BITS. } + + inptr := coef_block; + quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); + wsptr := PWorkspace(@workspace); + for ctr := pred(DCTSIZE) downto 0 do + begin + { Due to quantization, we will usually find that many of the input + coefficients are zero, especially the AC terms. We can exploit this + by short-circuiting the IDCT calculation for any column in which all + the AC terms are zero. In that case each output is equal to the + DC coefficient (with scale factor as needed). + With typical images and quantization tables, half or more of the + column DCT calculations can be simplified this way. } + + if ((inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and + (inptr^[DCTSIZE*3]=0) and (inptr^[DCTSIZE*4]=0) and + (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and + (inptr^[DCTSIZE*7]=0)) then + begin + { AC terms all zero } + dcval := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]) shl PASS1_BITS; + + wsptr^[DCTSIZE*0] := dcval; + wsptr^[DCTSIZE*1] := dcval; + wsptr^[DCTSIZE*2] := dcval; + wsptr^[DCTSIZE*3] := dcval; + wsptr^[DCTSIZE*4] := dcval; + wsptr^[DCTSIZE*5] := dcval; + wsptr^[DCTSIZE*6] := dcval; + wsptr^[DCTSIZE*7] := dcval; + + Inc(JCOEF_PTR(inptr)); { advance pointers to next column } + Inc(ISLOW_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + continue; + end; + + { Even part: reverse the even part of the forward DCT. } + { The rotator is sqrt(2)*c(-6). } + + z2 := DEQUANTIZE(inptr^[DCTSIZE*2], quantptr^[DCTSIZE*2]); + z3 := DEQUANTIZE(inptr^[DCTSIZE*6], quantptr^[DCTSIZE*6]); + + z1 := MULTIPLY(z2 + z3, FIX_0_541196100); + tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065); + tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865); + + z2 := DEQUANTIZE(inptr^[DCTSIZE*0], quantptr^[DCTSIZE*0]); + z3 := DEQUANTIZE(inptr^[DCTSIZE*4], quantptr^[DCTSIZE*4]); + + tmp0 := (z2 + z3) shl CONST_BITS; + tmp1 := (z2 - z3) shl CONST_BITS; + + tmp10 := tmp0 + tmp3; + tmp13 := tmp0 - tmp3; + tmp11 := tmp1 + tmp2; + tmp12 := tmp1 - tmp2; + + { Odd part per figure 8; the matrix is unitary and hence its + transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. } + + tmp0 := DEQUANTIZE(inptr^[DCTSIZE*7], quantptr^[DCTSIZE*7]); + tmp1 := DEQUANTIZE(inptr^[DCTSIZE*5], quantptr^[DCTSIZE*5]); + tmp2 := DEQUANTIZE(inptr^[DCTSIZE*3], quantptr^[DCTSIZE*3]); + tmp3 := DEQUANTIZE(inptr^[DCTSIZE*1], quantptr^[DCTSIZE*1]); + + z1 := tmp0 + tmp3; + z2 := tmp1 + tmp2; + z3 := tmp0 + tmp2; + z4 := tmp1 + tmp3; + z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } + + tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } + tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } + tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } + tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } + z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) } + z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } + z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } + z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } + + Inc(z3, z5); + Inc(z4, z5); + + Inc(tmp0, z1 + z3); + Inc(tmp1, z2 + z4); + Inc(tmp2, z2 + z3); + Inc(tmp3, z1 + z4); + + { Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 } + + wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp3, CONST_BITS-PASS1_BITS)); + wsptr^[DCTSIZE*7] := int (DESCALE(tmp10 - tmp3, CONST_BITS-PASS1_BITS)); + wsptr^[DCTSIZE*1] := int (DESCALE(tmp11 + tmp2, CONST_BITS-PASS1_BITS)); + wsptr^[DCTSIZE*6] := int (DESCALE(tmp11 - tmp2, CONST_BITS-PASS1_BITS)); + wsptr^[DCTSIZE*2] := int (DESCALE(tmp12 + tmp1, CONST_BITS-PASS1_BITS)); + wsptr^[DCTSIZE*5] := int (DESCALE(tmp12 - tmp1, CONST_BITS-PASS1_BITS)); + wsptr^[DCTSIZE*3] := int (DESCALE(tmp13 + tmp0, CONST_BITS-PASS1_BITS)); + wsptr^[DCTSIZE*4] := int (DESCALE(tmp13 - tmp0, CONST_BITS-PASS1_BITS)); + + Inc(JCOEF_PTR(inptr)); { advance pointers to next column } + Inc(ISLOW_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + end; + + { Pass 2: process rows from work array, store into output array. } + { Note that we must descale the results by a factor of 8 == 2**3, } + { and also undo the PASS1_BITS scaling. } + + wsptr := @workspace; + for ctr := 0 to pred(DCTSIZE) do + begin + outptr := output_buf^[ctr]; + Inc(JSAMPLE_PTR(outptr), output_col); + { Rows of zeroes can be exploited in the same way as we did with columns. + However, the column calculation has created many nonzero AC terms, so + the simplification applies less often (typically 5% to 10% of the time). + On machines with very fast multiplication, it's possible that the + test takes more time than it's worth. In that case this section + may be commented out. } + +{$ifndef NO_ZERO_ROW_TEST} + if ((wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and (wsptr^[4]=0) + and (wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0)) then + begin + { AC terms all zero } + JSAMPLE(dcval_) := range_limit^[int(DESCALE(INT32(wsptr^[0]), + PASS1_BITS+3)) and RANGE_MASK]; + + outptr^[0] := dcval_; + outptr^[1] := dcval_; + outptr^[2] := dcval_; + outptr^[3] := dcval_; + outptr^[4] := dcval_; + outptr^[5] := dcval_; + outptr^[6] := dcval_; + outptr^[7] := dcval_; + + Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } + continue; + end; +{$endif} + + { Even part: reverse the even part of the forward DCT. } + { The rotator is sqrt(2)*c(-6). } + + z2 := INT32 (wsptr^[2]); + z3 := INT32 (wsptr^[6]); + + z1 := MULTIPLY(z2 + z3, FIX_0_541196100); + tmp2 := z1 + MULTIPLY(z3, - FIX_1_847759065); + tmp3 := z1 + MULTIPLY(z2, FIX_0_765366865); + + tmp0 := (INT32(wsptr^[0]) + INT32(wsptr^[4])) shl CONST_BITS; + tmp1 := (INT32(wsptr^[0]) - INT32(wsptr^[4])) shl CONST_BITS; + + tmp10 := tmp0 + tmp3; + tmp13 := tmp0 - tmp3; + tmp11 := tmp1 + tmp2; + tmp12 := tmp1 - tmp2; + + { Odd part per figure 8; the matrix is unitary and hence its + transpose is its inverse. i0..i3 are y7,y5,y3,y1 respectively. } + + tmp0 := INT32(wsptr^[7]); + tmp1 := INT32(wsptr^[5]); + tmp2 := INT32(wsptr^[3]); + tmp3 := INT32(wsptr^[1]); + + z1 := tmp0 + tmp3; + z2 := tmp1 + tmp2; + z3 := tmp0 + tmp2; + z4 := tmp1 + tmp3; + z5 := MULTIPLY(z3 + z4, FIX_1_175875602); { sqrt(2) * c3 } + + tmp0 := MULTIPLY(tmp0, FIX_0_298631336); { sqrt(2) * (-c1+c3+c5-c7) } + tmp1 := MULTIPLY(tmp1, FIX_2_053119869); { sqrt(2) * ( c1+c3-c5+c7) } + tmp2 := MULTIPLY(tmp2, FIX_3_072711026); { sqrt(2) * ( c1+c3+c5-c7) } + tmp3 := MULTIPLY(tmp3, FIX_1_501321110); { sqrt(2) * ( c1+c3-c5-c7) } + z1 := MULTIPLY(z1, - FIX_0_899976223); { sqrt(2) * (c7-c3) } + z2 := MULTIPLY(z2, - FIX_2_562915447); { sqrt(2) * (-c1-c3) } + z3 := MULTIPLY(z3, - FIX_1_961570560); { sqrt(2) * (-c3-c5) } + z4 := MULTIPLY(z4, - FIX_0_390180644); { sqrt(2) * (c5-c3) } + + Inc(z3, z5); + Inc(z4, z5); + + Inc(tmp0, z1 + z3); + Inc(tmp1, z2 + z4); + Inc(tmp2, z2 + z3); + Inc(tmp3, z1 + z4); + + { Final output stage: inputs are tmp10..tmp13, tmp0..tmp3 } + + outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp3, + CONST_BITS+PASS1_BITS+3)) + and RANGE_MASK]; + outptr^[7] := range_limit^[ int(DESCALE(tmp10 - tmp3, + CONST_BITS+PASS1_BITS+3)) + and RANGE_MASK]; + outptr^[1] := range_limit^[ int(DESCALE(tmp11 + tmp2, + CONST_BITS+PASS1_BITS+3)) + and RANGE_MASK]; + outptr^[6] := range_limit^[ int(DESCALE(tmp11 - tmp2, + CONST_BITS+PASS1_BITS+3)) + and RANGE_MASK]; + outptr^[2] := range_limit^[ int(DESCALE(tmp12 + tmp1, + CONST_BITS+PASS1_BITS+3)) + and RANGE_MASK]; + outptr^[5] := range_limit^[ int(DESCALE(tmp12 - tmp1, + CONST_BITS+PASS1_BITS+3)) + and RANGE_MASK]; + outptr^[3] := range_limit^[ int(DESCALE(tmp13 + tmp0, + CONST_BITS+PASS1_BITS+3)) + and RANGE_MASK]; + outptr^[4] := range_limit^[ int(DESCALE(tmp13 - tmp0, + CONST_BITS+PASS1_BITS+3)) + and RANGE_MASK]; + + Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } + end; +end; + +end. diff --git a/Imaging/JpegLib/imjidctred.pas b/Imaging/JpegLib/imjidctred.pas index dae7bfc..ef6239a 100644 --- a/Imaging/JpegLib/imjidctred.pas +++ b/Imaging/JpegLib/imjidctred.pas @@ -1,525 +1,525 @@ -unit imjidctred; - - -{ This file contains inverse-DCT routines that produce reduced-size output: - either 4x4, 2x2, or 1x1 pixels from an 8x8 DCT block. - - The implementation is based on the Loeffler, Ligtenberg and Moschytz (LL&M) - algorithm used in jidctint.c. We simply replace each 8-to-8 1-D IDCT step - with an 8-to-4 step that produces the four averages of two adjacent outputs - (or an 8-to-2 step producing two averages of four outputs, for 2x2 output). - These steps were derived by computing the corresponding values at the end - of the normal LL&M code, then simplifying as much as possible. - - 1x1 is trivial: just take the DC coefficient divided by 8. - - See jidctint.c for additional comments. } - - -{ Original : jidctred.c ; Copyright (C) 1994-1998, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib, - imjdct; { Private declarations for DCT subsystem } - -{ Perform dequantization and inverse DCT on one block of coefficients, - producing a reduced-size 1x1 output block. } - -{GLOBAL} -procedure jpeg_idct_1x1 (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); - -{ Perform dequantization and inverse DCT on one block of coefficients, - producing a reduced-size 2x2 output block. } - -{GLOBAL} -procedure jpeg_idct_2x2 (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); - -{ Perform dequantization and inverse DCT on one block of coefficients, - producing a reduced-size 4x4 output block. } - -{GLOBAL} -procedure jpeg_idct_4x4 (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); - -implementation - -{ This module is specialized to the case DCTSIZE = 8. } - -{$ifndef DCTSIZE_IS_8} - Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } -{$endif} - - -{ Scaling is the same as in jidctint.c. } - -{$ifdef BITS_IN_JSAMPLE_IS_8} -const - CONST_BITS = 13; - PASS1_BITS = 2; -{$else} -const - CONST_BITS = 13; - PASS1_BITS = 1; { lose a little precision to avoid overflow } -{$endif} - -const - FIX_0_211164243 = INT32(Round((INT32(1) shl CONST_BITS) * 0.211164243)); {1730} - FIX_0_509795579 = INT32(Round((INT32(1) shl CONST_BITS) * 0.509795579)); {4176} - FIX_0_601344887 = INT32(Round((INT32(1) shl CONST_BITS) * 0.601344887)); {4926} - FIX_0_720959822 = INT32(Round((INT32(1) shl CONST_BITS) * 0.720959822)); {5906} - FIX_0_765366865 = INT32(Round((INT32(1) shl CONST_BITS) * 0.765366865)); {6270} - FIX_0_850430095 = INT32(Round((INT32(1) shl CONST_BITS) * 0.850430095)); {6967} - FIX_0_899976223 = INT32(Round((INT32(1) shl CONST_BITS) * 0.899976223)); {7373} - FIX_1_061594337 = INT32(Round((INT32(1) shl CONST_BITS) * 1.061594337)); {8697} - FIX_1_272758580 = INT32(Round((INT32(1) shl CONST_BITS) * 1.272758580)); {10426} - FIX_1_451774981 = INT32(Round((INT32(1) shl CONST_BITS) * 1.451774981)); {11893} - FIX_1_847759065 = INT32(Round((INT32(1) shl CONST_BITS) * 1.847759065)); {15137} - FIX_2_172734803 = INT32(Round((INT32(1) shl CONST_BITS) * 2.172734803)); {17799} - FIX_2_562915447 = INT32(Round((INT32(1) shl CONST_BITS) * 2.562915447)); {20995} - FIX_3_624509785 = INT32(Round((INT32(1) shl CONST_BITS) * 3.624509785)); {29692} - - -{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result. - For 8-bit samples with the recommended scaling, all the variable - and constant values involved are no more than 16 bits wide, so a - 16x16->32 bit multiply can be used instead of a full 32x32 multiply. - For 12-bit samples, a full 32-bit multiplication will be needed. } - -{$ifdef BITS_IN_JSAMPLE_IS_8} - - {function Multiply(X, Y: Integer): integer; assembler; - asm - mov ax, X - imul Y - mov al, ah - mov ah, dl - end;} - - {MULTIPLY16C16(var,const)} - function Multiply(X, Y: Integer): INT32; - begin - Multiply := X*INT32(Y); - end; - - -{$else} - function Multiply(X, Y: INT32): INT32; - begin - Multiply := X*Y; - end; -{$endif} - - -{ Dequantize a coefficient by multiplying it by the multiplier-table - entry; produce an int result. In this module, both inputs and result - are 16 bits or less, so either int or short multiply will work. } - -function DEQUANTIZE(coef,quantval : int) : int; -begin - Dequantize := ( ISLOW_MULT_TYPE(coef) * quantval); -end; - - -{ Descale and correctly round an INT32 value that's scaled by N bits. - We assume RIGHT_SHIFT rounds towards minus infinity, so adding - the fudge factor is correct for either sign of X. } - -function DESCALE(x : INT32; n : int) : INT32; -var - shift_temp : INT32; -begin -{$ifdef RIGHT_SHIFT_IS_UNSIGNED} - shift_temp := x + (INT32(1) shl (n-1)); - if shift_temp < 0 then - Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) - else - Descale := (shift_temp shr n); -{$else} - Descale := (x + (INT32(1) shl (n-1)) shr n; -{$endif} -end; - -{ Perform dequantization and inverse DCT on one block of coefficients, - producing a reduced-size 4x4 output block. } - -{GLOBAL} -procedure jpeg_idct_4x4 (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); -type - PWorkspace = ^TWorkspace; - TWorkspace = array[0..(DCTSIZE*4)-1] of int; { buffers data between passes } -var - tmp0, tmp2, tmp10, tmp12 : INT32; - z1, z2, z3, z4 : INT32; - inptr : JCOEFPTR; - quantptr : ISLOW_MULT_TYPE_FIELD_PTR; - wsptr : PWorkspace; - outptr : JSAMPROW; - range_limit : JSAMPROW; - ctr : int; - workspace : TWorkspace; { buffers data between passes } - {SHIFT_TEMPS} -var - dcval : int; -var - dcval_ : JSAMPLE; -begin -{ Each IDCT routine is responsible for range-limiting its results and - converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could - be quite far out of range if the input data is corrupt, so a bulletproof - range-limiting step is required. We use a mask-and-table-lookup method - to do the combined operations quickly. See the comments with - prepare_range_limit_table (in jdmaster.c) for more info. } - - range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); - - { Pass 1: process columns from input, store into work array. } - - inptr := coef_block; - quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); - wsptr := @workspace; - for ctr := DCTSIZE downto 1 do - begin - { Don't bother to process column 4, because second pass won't use it } - if (ctr = DCTSIZE-4) then - begin - Inc(JCOEF_PTR(inptr)); - Inc(ISLOW_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - - continue; - end; - if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and (inptr^[DCTSIZE*3]=0) and - (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and (inptr^[DCTSIZE*7]=0) then - begin - { AC terms all zero; we need not examine term 4 for 4x4 output } - dcval := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * - quantptr^[DCTSIZE*0]) shl PASS1_BITS; - - wsptr^[DCTSIZE*0] := dcval; - wsptr^[DCTSIZE*1] := dcval; - wsptr^[DCTSIZE*2] := dcval; - wsptr^[DCTSIZE*3] := dcval; - - Inc(JCOEF_PTR(inptr)); - Inc(ISLOW_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - - continue; - end; - - { Even part } - - tmp0 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * quantptr^[DCTSIZE*0]); - - tmp0 := tmp0 shl (CONST_BITS+1); - - z2 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*2]) * quantptr^[DCTSIZE*2]); - z3 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*6]) * quantptr^[DCTSIZE*6]); - - tmp2 := MULTIPLY(z2, FIX_1_847759065) + MULTIPLY(z3, - FIX_0_765366865); - - tmp10 := tmp0 + tmp2; - tmp12 := tmp0 - tmp2; - - { Odd part } - - z1 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*7]) * quantptr^[DCTSIZE*7]; - z2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*5]) * quantptr^[DCTSIZE*5]; - z3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*3]) * quantptr^[DCTSIZE*3]; - z4 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*1]) * quantptr^[DCTSIZE*1]; - - tmp0 := MULTIPLY(z1, - FIX_0_211164243) { sqrt(2) * (c3-c1) } - + MULTIPLY(z2, FIX_1_451774981) { sqrt(2) * (c3+c7) } - + MULTIPLY(z3, - FIX_2_172734803) { sqrt(2) * (-c1-c5) } - + MULTIPLY(z4, FIX_1_061594337); { sqrt(2) * (c5+c7) } - - tmp2 := MULTIPLY(z1, - FIX_0_509795579) { sqrt(2) * (c7-c5) } - + MULTIPLY(z2, - FIX_0_601344887) { sqrt(2) * (c5-c1) } - + MULTIPLY(z3, FIX_0_899976223) { sqrt(2) * (c3-c7) } - + MULTIPLY(z4, FIX_2_562915447); { sqrt(2) * (c1+c3) } - - { Final output stage } - - wsptr^[DCTSIZE*0] := int(DESCALE(tmp10 + tmp2, CONST_BITS-PASS1_BITS+1)); - wsptr^[DCTSIZE*3] := int(DESCALE(tmp10 - tmp2, CONST_BITS-PASS1_BITS+1)); - wsptr^[DCTSIZE*1] := int(DESCALE(tmp12 + tmp0, CONST_BITS-PASS1_BITS+1)); - wsptr^[DCTSIZE*2] := int(DESCALE(tmp12 - tmp0, CONST_BITS-PASS1_BITS+1)); - - Inc(JCOEF_PTR(inptr)); - Inc(ISLOW_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - end; - - { Pass 2: process 4 rows from work array, store into output array. } - - wsptr := @workspace; - for ctr := 0 to pred(4) do - begin - outptr := JSAMPROW(@ output_buf^[ctr]^[output_col]); - { It's not clear whether a zero row test is worthwhile here ... } - -{$ifndef NO_ZERO_ROW_TEST} - if (wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and - (wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0) then - begin - { AC terms all zero } - dcval_ := range_limit^[int(DESCALE(INT32(wsptr^[0]), PASS1_BITS+3)) - and RANGE_MASK]; - - outptr^[0] := dcval_; - outptr^[1] := dcval_; - outptr^[2] := dcval_; - outptr^[3] := dcval_; - - Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } - continue; - end; -{$endif} - - { Even part } - - tmp0 := (INT32(wsptr^[0])) shl (CONST_BITS+1); - - tmp2 := MULTIPLY(INT32(wsptr^[2]), FIX_1_847759065) - + MULTIPLY(INT32(wsptr^[6]), - FIX_0_765366865); - - tmp10 := tmp0 + tmp2; - tmp12 := tmp0 - tmp2; - - { Odd part } - - z1 := INT32(wsptr^[7]); - z2 := INT32(wsptr^[5]); - z3 := INT32(wsptr^[3]); - z4 := INT32(wsptr^[1]); - - tmp0 := MULTIPLY(z1, - FIX_0_211164243) { sqrt(2) * (c3-c1) } - + MULTIPLY(z2, FIX_1_451774981) { sqrt(2) * (c3+c7) } - + MULTIPLY(z3, - FIX_2_172734803) { sqrt(2) * (-c1-c5) } - + MULTIPLY(z4, FIX_1_061594337); { sqrt(2) * (c5+c7) } - - tmp2 := MULTIPLY(z1, - FIX_0_509795579) { sqrt(2) * (c7-c5) } - + MULTIPLY(z2, - FIX_0_601344887) { sqrt(2) * (c5-c1) } - + MULTIPLY(z3, FIX_0_899976223) { sqrt(2) * (c3-c7) } - + MULTIPLY(z4, FIX_2_562915447); { sqrt(2) * (c1+c3) } - - { Final output stage } - - outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp2, - CONST_BITS+PASS1_BITS+3+1)) - and RANGE_MASK]; - outptr^[3] := range_limit^[ int(DESCALE(tmp10 - tmp2, - CONST_BITS+PASS1_BITS+3+1)) - and RANGE_MASK]; - outptr^[1] := range_limit^[ int(DESCALE(tmp12 + tmp0, - CONST_BITS+PASS1_BITS+3+1)) - and RANGE_MASK]; - outptr^[2] := range_limit^[ int(DESCALE(tmp12 - tmp0, - CONST_BITS+PASS1_BITS+3+1)) - and RANGE_MASK]; - - Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } - end; -end; - - -{ Perform dequantization and inverse DCT on one block of coefficients, - producing a reduced-size 2x2 output block. } - -{GLOBAL} -procedure jpeg_idct_2x2 (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); -type - PWorkspace = ^TWorkspace; - TWorkspace = array[0..(DCTSIZE*2)-1] of int; { buffers data between passes } -var - tmp0, tmp10, z1 : INT32; - inptr : JCOEFPTR; - quantptr : ISLOW_MULT_TYPE_FIELD_PTR; - wsptr : PWorkspace; - outptr : JSAMPROW; - range_limit : JSAMPROW; - ctr : int; - workspace : TWorkspace; { buffers data between passes } - {SHIFT_TEMPS} -var - dcval : int; -var - dcval_ : JSAMPLE; -begin -{ Each IDCT routine is responsible for range-limiting its results and - converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could - be quite far out of range if the input data is corrupt, so a bulletproof - range-limiting step is required. We use a mask-and-table-lookup method - to do the combined operations quickly. See the comments with - prepare_range_limit_table (in jdmaster.c) for more info. } - - range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); - { Pass 1: process columns from input, store into work array. } - - inptr := coef_block; - quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); - wsptr := @workspace; - for ctr := DCTSIZE downto 1 do - begin - { Don't bother to process columns 2,4,6 } - if (ctr = DCTSIZE-2) or (ctr = DCTSIZE-4) or (ctr = DCTSIZE-6) then - begin - Inc(JCOEF_PTR(inptr)); - Inc(ISLOW_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - - continue; - end; - if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*3]=0) and - (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*7]=0) then - begin - { AC terms all zero; we need not examine terms 2,4,6 for 2x2 output } - dcval := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * - quantptr^[DCTSIZE*0]) shl PASS1_BITS; - - wsptr^[DCTSIZE*0] := dcval; - wsptr^[DCTSIZE*1] := dcval; - - Inc(JCOEF_PTR(inptr)); - Inc(ISLOW_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - - continue; - end; - - { Even part } - - z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * quantptr^[DCTSIZE*0]); - - tmp10 := z1 shl (CONST_BITS+2); - - { Odd part } - - z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*7]) * quantptr^[DCTSIZE*7]); - tmp0 := MULTIPLY(z1, - FIX_0_720959822); { sqrt(2) * (c7-c5+c3-c1) } - z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*5]) * quantptr^[DCTSIZE*5]); - Inc(tmp0, MULTIPLY(z1, FIX_0_850430095)); { sqrt(2) * (-c1+c3+c5+c7) } - z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*3]) * quantptr^[DCTSIZE*3]); - Inc(tmp0, MULTIPLY(z1, - FIX_1_272758580)); { sqrt(2) * (-c1+c3-c5-c7) } - z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*1]) * quantptr^[DCTSIZE*1]); - Inc(tmp0, MULTIPLY(z1, FIX_3_624509785)); { sqrt(2) * (c1+c3+c5+c7) } - - { Final output stage } - - wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp0, CONST_BITS-PASS1_BITS+2)); - wsptr^[DCTSIZE*1] := int (DESCALE(tmp10 - tmp0, CONST_BITS-PASS1_BITS+2)); - - Inc(JCOEF_PTR(inptr)); - Inc(ISLOW_MULT_TYPE_PTR(quantptr)); - Inc(int_ptr(wsptr)); - end; - - { Pass 2: process 2 rows from work array, store into output array. } - - wsptr := @workspace; - for ctr := 0 to pred(2) do - begin - outptr := JSAMPROW(@ output_buf^[ctr]^[output_col]); - { It's not clear whether a zero row test is worthwhile here ... } - -{$ifndef NO_ZERO_ROW_TEST} - if (wsptr^[1]=0) and (wsptr^[3]=0) and (wsptr^[5]=0) and (wsptr^[7]= 0) then - begin - { AC terms all zero } - dcval_ := range_limit^[ int(DESCALE(INT32(wsptr^[0]), PASS1_BITS+3)) - and RANGE_MASK]; - - outptr^[0] := dcval_; - outptr^[1] := dcval_; - - Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } - continue; - end; -{$endif} - - { Even part } - - tmp10 := (INT32 (wsptr^[0])) shl (CONST_BITS+2); - - { Odd part } - - tmp0 := MULTIPLY( INT32(wsptr^[7]), - FIX_0_720959822) { sqrt(2) * (c7-c5+c3-c1) } - + MULTIPLY( INT32(wsptr^[5]), FIX_0_850430095) { sqrt(2) * (-c1+c3+c5+c7) } - + MULTIPLY( INT32(wsptr^[3]), - FIX_1_272758580) { sqrt(2) * (-c1+c3-c5-c7) } - + MULTIPLY( INT32(wsptr^[1]), FIX_3_624509785); { sqrt(2) * (c1+c3+c5+c7) } - - { Final output stage } - - outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp0, - CONST_BITS+PASS1_BITS+3+2)) - and RANGE_MASK]; - outptr^[1] := range_limit^[ int(DESCALE(tmp10 - tmp0, - CONST_BITS+PASS1_BITS+3+2)) - and RANGE_MASK]; - - Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } - end; -end; - - -{ Perform dequantization and inverse DCT on one block of coefficients, - producing a reduced-size 1x1 output block. } - -{GLOBAL} -procedure jpeg_idct_1x1 (cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; - output_col : JDIMENSION); -var - dcval : int; - quantptr : ISLOW_MULT_TYPE_FIELD_PTR; - range_limit : JSAMPROW; - {SHIFT_TEMPS} -begin -{ Each IDCT routine is responsible for range-limiting its results and - converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could - be quite far out of range if the input data is corrupt, so a bulletproof - range-limiting step is required. We use a mask-and-table-lookup method - to do the combined operations quickly. See the comments with - prepare_range_limit_table (in jdmaster.c) for more info. } - - range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); - { Pass 1: process columns from input, store into work array. } - - { We hardly need an inverse DCT routine for this: just take the - average pixel value, which is one-eighth of the DC coefficient. } - - quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); - dcval := (ISLOW_MULT_TYPE(coef_block^[0]) * quantptr^[0]); - dcval := int (DESCALE( INT32(dcval), 3)); - - output_buf^[0]^[output_col] := range_limit^[dcval and RANGE_MASK]; -end; - -end. +unit imjidctred; + + +{ This file contains inverse-DCT routines that produce reduced-size output: + either 4x4, 2x2, or 1x1 pixels from an 8x8 DCT block. + + The implementation is based on the Loeffler, Ligtenberg and Moschytz (LL&M) + algorithm used in jidctint.c. We simply replace each 8-to-8 1-D IDCT step + with an 8-to-4 step that produces the four averages of two adjacent outputs + (or an 8-to-2 step producing two averages of four outputs, for 2x2 output). + These steps were derived by computing the corresponding values at the end + of the normal LL&M code, then simplifying as much as possible. + + 1x1 is trivial: just take the DC coefficient divided by 8. + + See jidctint.c for additional comments. } + + +{ Original : jidctred.c ; Copyright (C) 1994-1998, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib, + imjdct; { Private declarations for DCT subsystem } + +{ Perform dequantization and inverse DCT on one block of coefficients, + producing a reduced-size 1x1 output block. } + +{GLOBAL} +procedure jpeg_idct_1x1 (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); + +{ Perform dequantization and inverse DCT on one block of coefficients, + producing a reduced-size 2x2 output block. } + +{GLOBAL} +procedure jpeg_idct_2x2 (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); + +{ Perform dequantization and inverse DCT on one block of coefficients, + producing a reduced-size 4x4 output block. } + +{GLOBAL} +procedure jpeg_idct_4x4 (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); + +implementation + +{ This module is specialized to the case DCTSIZE = 8. } + +{$ifndef DCTSIZE_IS_8} + Sorry, this code only copes with 8x8 DCTs. { deliberate syntax err } +{$endif} + + +{ Scaling is the same as in jidctint.c. } + +{$ifdef BITS_IN_JSAMPLE_IS_8} +const + CONST_BITS = 13; + PASS1_BITS = 2; +{$else} +const + CONST_BITS = 13; + PASS1_BITS = 1; { lose a little precision to avoid overflow } +{$endif} + +const + FIX_0_211164243 = INT32(Round((INT32(1) shl CONST_BITS) * 0.211164243)); {1730} + FIX_0_509795579 = INT32(Round((INT32(1) shl CONST_BITS) * 0.509795579)); {4176} + FIX_0_601344887 = INT32(Round((INT32(1) shl CONST_BITS) * 0.601344887)); {4926} + FIX_0_720959822 = INT32(Round((INT32(1) shl CONST_BITS) * 0.720959822)); {5906} + FIX_0_765366865 = INT32(Round((INT32(1) shl CONST_BITS) * 0.765366865)); {6270} + FIX_0_850430095 = INT32(Round((INT32(1) shl CONST_BITS) * 0.850430095)); {6967} + FIX_0_899976223 = INT32(Round((INT32(1) shl CONST_BITS) * 0.899976223)); {7373} + FIX_1_061594337 = INT32(Round((INT32(1) shl CONST_BITS) * 1.061594337)); {8697} + FIX_1_272758580 = INT32(Round((INT32(1) shl CONST_BITS) * 1.272758580)); {10426} + FIX_1_451774981 = INT32(Round((INT32(1) shl CONST_BITS) * 1.451774981)); {11893} + FIX_1_847759065 = INT32(Round((INT32(1) shl CONST_BITS) * 1.847759065)); {15137} + FIX_2_172734803 = INT32(Round((INT32(1) shl CONST_BITS) * 2.172734803)); {17799} + FIX_2_562915447 = INT32(Round((INT32(1) shl CONST_BITS) * 2.562915447)); {20995} + FIX_3_624509785 = INT32(Round((INT32(1) shl CONST_BITS) * 3.624509785)); {29692} + + +{ Multiply an INT32 variable by an INT32 constant to yield an INT32 result. + For 8-bit samples with the recommended scaling, all the variable + and constant values involved are no more than 16 bits wide, so a + 16x16->32 bit multiply can be used instead of a full 32x32 multiply. + For 12-bit samples, a full 32-bit multiplication will be needed. } + +{$ifdef BITS_IN_JSAMPLE_IS_8} + + {function Multiply(X, Y: Integer): integer; assembler; + asm + mov ax, X + imul Y + mov al, ah + mov ah, dl + end;} + + {MULTIPLY16C16(var,const)} + function Multiply(X, Y: Integer): INT32; + begin + Multiply := X*INT32(Y); + end; + + +{$else} + function Multiply(X, Y: INT32): INT32; + begin + Multiply := X*Y; + end; +{$endif} + + +{ Dequantize a coefficient by multiplying it by the multiplier-table + entry; produce an int result. In this module, both inputs and result + are 16 bits or less, so either int or short multiply will work. } + +function DEQUANTIZE(coef,quantval : int) : int; +begin + Dequantize := ( ISLOW_MULT_TYPE(coef) * quantval); +end; + + +{ Descale and correctly round an INT32 value that's scaled by N bits. + We assume RIGHT_SHIFT rounds towards minus infinity, so adding + the fudge factor is correct for either sign of X. } + +function DESCALE(x : INT32; n : int) : INT32; +var + shift_temp : INT32; +begin +{$ifdef RIGHT_SHIFT_IS_UNSIGNED} + shift_temp := x + (INT32(1) shl (n-1)); + if shift_temp < 0 then + Descale := (shift_temp shr n) or ((not INT32(0)) shl (32-n)) + else + Descale := (shift_temp shr n); +{$else} + Descale := (x + (INT32(1) shl (n-1)) shr n; +{$endif} +end; + +{ Perform dequantization and inverse DCT on one block of coefficients, + producing a reduced-size 4x4 output block. } + +{GLOBAL} +procedure jpeg_idct_4x4 (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); +type + PWorkspace = ^TWorkspace; + TWorkspace = array[0..(DCTSIZE*4)-1] of int; { buffers data between passes } +var + tmp0, tmp2, tmp10, tmp12 : INT32; + z1, z2, z3, z4 : INT32; + inptr : JCOEFPTR; + quantptr : ISLOW_MULT_TYPE_FIELD_PTR; + wsptr : PWorkspace; + outptr : JSAMPROW; + range_limit : JSAMPROW; + ctr : int; + workspace : TWorkspace; { buffers data between passes } + {SHIFT_TEMPS} +var + dcval : int; +var + dcval_ : JSAMPLE; +begin +{ Each IDCT routine is responsible for range-limiting its results and + converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could + be quite far out of range if the input data is corrupt, so a bulletproof + range-limiting step is required. We use a mask-and-table-lookup method + to do the combined operations quickly. See the comments with + prepare_range_limit_table (in jdmaster.c) for more info. } + + range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); + + { Pass 1: process columns from input, store into work array. } + + inptr := coef_block; + quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); + wsptr := @workspace; + for ctr := DCTSIZE downto 1 do + begin + { Don't bother to process column 4, because second pass won't use it } + if (ctr = DCTSIZE-4) then + begin + Inc(JCOEF_PTR(inptr)); + Inc(ISLOW_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + + continue; + end; + if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*2]=0) and (inptr^[DCTSIZE*3]=0) and + (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*6]=0) and (inptr^[DCTSIZE*7]=0) then + begin + { AC terms all zero; we need not examine term 4 for 4x4 output } + dcval := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * + quantptr^[DCTSIZE*0]) shl PASS1_BITS; + + wsptr^[DCTSIZE*0] := dcval; + wsptr^[DCTSIZE*1] := dcval; + wsptr^[DCTSIZE*2] := dcval; + wsptr^[DCTSIZE*3] := dcval; + + Inc(JCOEF_PTR(inptr)); + Inc(ISLOW_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + + continue; + end; + + { Even part } + + tmp0 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * quantptr^[DCTSIZE*0]); + + tmp0 := tmp0 shl (CONST_BITS+1); + + z2 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*2]) * quantptr^[DCTSIZE*2]); + z3 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*6]) * quantptr^[DCTSIZE*6]); + + tmp2 := MULTIPLY(z2, FIX_1_847759065) + MULTIPLY(z3, - FIX_0_765366865); + + tmp10 := tmp0 + tmp2; + tmp12 := tmp0 - tmp2; + + { Odd part } + + z1 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*7]) * quantptr^[DCTSIZE*7]; + z2 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*5]) * quantptr^[DCTSIZE*5]; + z3 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*3]) * quantptr^[DCTSIZE*3]; + z4 := ISLOW_MULT_TYPE(inptr^[DCTSIZE*1]) * quantptr^[DCTSIZE*1]; + + tmp0 := MULTIPLY(z1, - FIX_0_211164243) { sqrt(2) * (c3-c1) } + + MULTIPLY(z2, FIX_1_451774981) { sqrt(2) * (c3+c7) } + + MULTIPLY(z3, - FIX_2_172734803) { sqrt(2) * (-c1-c5) } + + MULTIPLY(z4, FIX_1_061594337); { sqrt(2) * (c5+c7) } + + tmp2 := MULTIPLY(z1, - FIX_0_509795579) { sqrt(2) * (c7-c5) } + + MULTIPLY(z2, - FIX_0_601344887) { sqrt(2) * (c5-c1) } + + MULTIPLY(z3, FIX_0_899976223) { sqrt(2) * (c3-c7) } + + MULTIPLY(z4, FIX_2_562915447); { sqrt(2) * (c1+c3) } + + { Final output stage } + + wsptr^[DCTSIZE*0] := int(DESCALE(tmp10 + tmp2, CONST_BITS-PASS1_BITS+1)); + wsptr^[DCTSIZE*3] := int(DESCALE(tmp10 - tmp2, CONST_BITS-PASS1_BITS+1)); + wsptr^[DCTSIZE*1] := int(DESCALE(tmp12 + tmp0, CONST_BITS-PASS1_BITS+1)); + wsptr^[DCTSIZE*2] := int(DESCALE(tmp12 - tmp0, CONST_BITS-PASS1_BITS+1)); + + Inc(JCOEF_PTR(inptr)); + Inc(ISLOW_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + end; + + { Pass 2: process 4 rows from work array, store into output array. } + + wsptr := @workspace; + for ctr := 0 to pred(4) do + begin + outptr := JSAMPROW(@ output_buf^[ctr]^[output_col]); + { It's not clear whether a zero row test is worthwhile here ... } + +{$ifndef NO_ZERO_ROW_TEST} + if (wsptr^[1]=0) and (wsptr^[2]=0) and (wsptr^[3]=0) and + (wsptr^[5]=0) and (wsptr^[6]=0) and (wsptr^[7]=0) then + begin + { AC terms all zero } + dcval_ := range_limit^[int(DESCALE(INT32(wsptr^[0]), PASS1_BITS+3)) + and RANGE_MASK]; + + outptr^[0] := dcval_; + outptr^[1] := dcval_; + outptr^[2] := dcval_; + outptr^[3] := dcval_; + + Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } + continue; + end; +{$endif} + + { Even part } + + tmp0 := (INT32(wsptr^[0])) shl (CONST_BITS+1); + + tmp2 := MULTIPLY(INT32(wsptr^[2]), FIX_1_847759065) + + MULTIPLY(INT32(wsptr^[6]), - FIX_0_765366865); + + tmp10 := tmp0 + tmp2; + tmp12 := tmp0 - tmp2; + + { Odd part } + + z1 := INT32(wsptr^[7]); + z2 := INT32(wsptr^[5]); + z3 := INT32(wsptr^[3]); + z4 := INT32(wsptr^[1]); + + tmp0 := MULTIPLY(z1, - FIX_0_211164243) { sqrt(2) * (c3-c1) } + + MULTIPLY(z2, FIX_1_451774981) { sqrt(2) * (c3+c7) } + + MULTIPLY(z3, - FIX_2_172734803) { sqrt(2) * (-c1-c5) } + + MULTIPLY(z4, FIX_1_061594337); { sqrt(2) * (c5+c7) } + + tmp2 := MULTIPLY(z1, - FIX_0_509795579) { sqrt(2) * (c7-c5) } + + MULTIPLY(z2, - FIX_0_601344887) { sqrt(2) * (c5-c1) } + + MULTIPLY(z3, FIX_0_899976223) { sqrt(2) * (c3-c7) } + + MULTIPLY(z4, FIX_2_562915447); { sqrt(2) * (c1+c3) } + + { Final output stage } + + outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp2, + CONST_BITS+PASS1_BITS+3+1)) + and RANGE_MASK]; + outptr^[3] := range_limit^[ int(DESCALE(tmp10 - tmp2, + CONST_BITS+PASS1_BITS+3+1)) + and RANGE_MASK]; + outptr^[1] := range_limit^[ int(DESCALE(tmp12 + tmp0, + CONST_BITS+PASS1_BITS+3+1)) + and RANGE_MASK]; + outptr^[2] := range_limit^[ int(DESCALE(tmp12 - tmp0, + CONST_BITS+PASS1_BITS+3+1)) + and RANGE_MASK]; + + Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } + end; +end; + + +{ Perform dequantization and inverse DCT on one block of coefficients, + producing a reduced-size 2x2 output block. } + +{GLOBAL} +procedure jpeg_idct_2x2 (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); +type + PWorkspace = ^TWorkspace; + TWorkspace = array[0..(DCTSIZE*2)-1] of int; { buffers data between passes } +var + tmp0, tmp10, z1 : INT32; + inptr : JCOEFPTR; + quantptr : ISLOW_MULT_TYPE_FIELD_PTR; + wsptr : PWorkspace; + outptr : JSAMPROW; + range_limit : JSAMPROW; + ctr : int; + workspace : TWorkspace; { buffers data between passes } + {SHIFT_TEMPS} +var + dcval : int; +var + dcval_ : JSAMPLE; +begin +{ Each IDCT routine is responsible for range-limiting its results and + converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could + be quite far out of range if the input data is corrupt, so a bulletproof + range-limiting step is required. We use a mask-and-table-lookup method + to do the combined operations quickly. See the comments with + prepare_range_limit_table (in jdmaster.c) for more info. } + + range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); + { Pass 1: process columns from input, store into work array. } + + inptr := coef_block; + quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); + wsptr := @workspace; + for ctr := DCTSIZE downto 1 do + begin + { Don't bother to process columns 2,4,6 } + if (ctr = DCTSIZE-2) or (ctr = DCTSIZE-4) or (ctr = DCTSIZE-6) then + begin + Inc(JCOEF_PTR(inptr)); + Inc(ISLOW_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + + continue; + end; + if (inptr^[DCTSIZE*1]=0) and (inptr^[DCTSIZE*3]=0) and + (inptr^[DCTSIZE*5]=0) and (inptr^[DCTSIZE*7]=0) then + begin + { AC terms all zero; we need not examine terms 2,4,6 for 2x2 output } + dcval := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * + quantptr^[DCTSIZE*0]) shl PASS1_BITS; + + wsptr^[DCTSIZE*0] := dcval; + wsptr^[DCTSIZE*1] := dcval; + + Inc(JCOEF_PTR(inptr)); + Inc(ISLOW_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + + continue; + end; + + { Even part } + + z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*0]) * quantptr^[DCTSIZE*0]); + + tmp10 := z1 shl (CONST_BITS+2); + + { Odd part } + + z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*7]) * quantptr^[DCTSIZE*7]); + tmp0 := MULTIPLY(z1, - FIX_0_720959822); { sqrt(2) * (c7-c5+c3-c1) } + z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*5]) * quantptr^[DCTSIZE*5]); + Inc(tmp0, MULTIPLY(z1, FIX_0_850430095)); { sqrt(2) * (-c1+c3+c5+c7) } + z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*3]) * quantptr^[DCTSIZE*3]); + Inc(tmp0, MULTIPLY(z1, - FIX_1_272758580)); { sqrt(2) * (-c1+c3-c5-c7) } + z1 := (ISLOW_MULT_TYPE(inptr^[DCTSIZE*1]) * quantptr^[DCTSIZE*1]); + Inc(tmp0, MULTIPLY(z1, FIX_3_624509785)); { sqrt(2) * (c1+c3+c5+c7) } + + { Final output stage } + + wsptr^[DCTSIZE*0] := int (DESCALE(tmp10 + tmp0, CONST_BITS-PASS1_BITS+2)); + wsptr^[DCTSIZE*1] := int (DESCALE(tmp10 - tmp0, CONST_BITS-PASS1_BITS+2)); + + Inc(JCOEF_PTR(inptr)); + Inc(ISLOW_MULT_TYPE_PTR(quantptr)); + Inc(int_ptr(wsptr)); + end; + + { Pass 2: process 2 rows from work array, store into output array. } + + wsptr := @workspace; + for ctr := 0 to pred(2) do + begin + outptr := JSAMPROW(@ output_buf^[ctr]^[output_col]); + { It's not clear whether a zero row test is worthwhile here ... } + +{$ifndef NO_ZERO_ROW_TEST} + if (wsptr^[1]=0) and (wsptr^[3]=0) and (wsptr^[5]=0) and (wsptr^[7]= 0) then + begin + { AC terms all zero } + dcval_ := range_limit^[ int(DESCALE(INT32(wsptr^[0]), PASS1_BITS+3)) + and RANGE_MASK]; + + outptr^[0] := dcval_; + outptr^[1] := dcval_; + + Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } + continue; + end; +{$endif} + + { Even part } + + tmp10 := (INT32 (wsptr^[0])) shl (CONST_BITS+2); + + { Odd part } + + tmp0 := MULTIPLY( INT32(wsptr^[7]), - FIX_0_720959822) { sqrt(2) * (c7-c5+c3-c1) } + + MULTIPLY( INT32(wsptr^[5]), FIX_0_850430095) { sqrt(2) * (-c1+c3+c5+c7) } + + MULTIPLY( INT32(wsptr^[3]), - FIX_1_272758580) { sqrt(2) * (-c1+c3-c5-c7) } + + MULTIPLY( INT32(wsptr^[1]), FIX_3_624509785); { sqrt(2) * (c1+c3+c5+c7) } + + { Final output stage } + + outptr^[0] := range_limit^[ int(DESCALE(tmp10 + tmp0, + CONST_BITS+PASS1_BITS+3+2)) + and RANGE_MASK]; + outptr^[1] := range_limit^[ int(DESCALE(tmp10 - tmp0, + CONST_BITS+PASS1_BITS+3+2)) + and RANGE_MASK]; + + Inc(int_ptr(wsptr), DCTSIZE); { advance pointer to next row } + end; +end; + + +{ Perform dequantization and inverse DCT on one block of coefficients, + producing a reduced-size 1x1 output block. } + +{GLOBAL} +procedure jpeg_idct_1x1 (cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; + output_col : JDIMENSION); +var + dcval : int; + quantptr : ISLOW_MULT_TYPE_FIELD_PTR; + range_limit : JSAMPROW; + {SHIFT_TEMPS} +begin +{ Each IDCT routine is responsible for range-limiting its results and + converting them to unsigned form (0..MAXJSAMPLE). The raw outputs could + be quite far out of range if the input data is corrupt, so a bulletproof + range-limiting step is required. We use a mask-and-table-lookup method + to do the combined operations quickly. See the comments with + prepare_range_limit_table (in jdmaster.c) for more info. } + + range_limit := JSAMPROW(@(cinfo^.sample_range_limit^[CENTERJSAMPLE])); + { Pass 1: process columns from input, store into work array. } + + { We hardly need an inverse DCT routine for this: just take the + average pixel value, which is one-eighth of the DC coefficient. } + + quantptr := ISLOW_MULT_TYPE_FIELD_PTR (compptr^.dct_table); + dcval := (ISLOW_MULT_TYPE(coef_block^[0]) * quantptr^[0]); + dcval := int (DESCALE( INT32(dcval), 3)); + + output_buf^[0]^[output_col] := range_limit^[dcval and RANGE_MASK]; +end; + +end. diff --git a/Imaging/JpegLib/imjinclude.pas b/Imaging/JpegLib/imjinclude.pas index dcaa684..e9934cd 100644 --- a/Imaging/JpegLib/imjinclude.pas +++ b/Imaging/JpegLib/imjinclude.pas @@ -1,126 +1,126 @@ -unit imjinclude; - -{ This file exists to provide a single place to fix any problems with - including the wrong system include files. (Common problems are taken - care of by the standard jconfig symbols, but on really weird systems - you may have to edit this file.) - - NOTE: this file is NOT intended to be included by applications using the - JPEG library. Most applications need only include jpeglib.h. } - -{ Original: jinclude.h Copyright (C) 1991-1994, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -{ Include auto-config file to find out which system include files we need. } - -uses -{$ifdef Delphi_Stream} - classes, -{$endif} - imjmorecfg; - -{ Nomssi: - To write a dest/source manager that handle streams rather than files, - you can edit the FILEptr definition and the JFREAD() and JFWRITE() - functions in this unit, you don't need to change the default managers - JDATASRC and JDATADST. } - -{$ifdef Delphi_Stream} -type - FILEptr = ^TStream; -{$else} - {$ifdef Delphi_Jpeg} - type - FILEptr = TCustomMemoryStream; - {$else} - type - FILEptr = ^File; - {$endif} -{$endif} - -{ We need the NULL macro and size_t typedef. - On an ANSI-conforming system it is sufficient to include . - Otherwise, we get them from or ; we may have to - pull in as well. - Note that the core JPEG library does not require ; - only the default error handler and data source/destination modules do. - But we must pull it in because of the references to FILE in jpeglib.h. - You can remove those references if you want to compile without .} - - - -{ We need memory copying and zeroing functions, plus strncpy(). - ANSI and System V implementations declare these in . - BSD doesn't have the mem() functions, but it does have bcopy()/bzero(). - Some systems may declare memset and memcpy in . - - NOTE: we assume the size parameters to these functions are of type size_t. - Change the casts in these macros if not! } - -procedure MEMZERO(target : pointer; size : size_t); - -procedure MEMCOPY(dest, src : pointer; size : size_t); - -{function SIZEOF(object) : size_t;} - -function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; - -function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; - -implementation - -procedure MEMZERO(target : pointer; size : size_t); -begin - FillChar(target^, size, 0); -end; - -procedure MEMCOPY(dest, src : pointer; size : size_t); -begin - Move(src^, dest^, size); -end; - -{ In ANSI C, and indeed any rational implementation, size_t is also the - type returned by sizeof(). However, it seems there are some irrational - implementations out there, in which sizeof() returns an int even though - size_t is defined as long or unsigned long. To ensure consistent results - we always use this SIZEOF() macro in place of using sizeof() directly. } - - -{#define - SIZEOF(object) (size_t(sizeof(object))} - - -{ The modules that use fread() and fwrite() always invoke them through - these macros. On some systems you may need to twiddle the argument casts. - CAUTION: argument order is different from underlying functions! } - - -function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; -var - count : uint; -begin - {$ifdef Delphi_Stream} - count := fp^.Read(buf^, sizeofbuf); - {$else} - blockread(fp^, buf^, sizeofbuf, count); - {$endif} - JFREAD := size_t(count); -end; - -function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; -var - count : uint; -begin - {$ifdef Delphi_Stream} - count := fp^.Write(buf^, sizeofbuf); - {$else} - blockwrite(fp^, buf^, sizeofbuf, count); - {$endif} - JFWRITE := size_t(count); -end; - - -end. +unit imjinclude; + +{ This file exists to provide a single place to fix any problems with + including the wrong system include files. (Common problems are taken + care of by the standard jconfig symbols, but on really weird systems + you may have to edit this file.) + + NOTE: this file is NOT intended to be included by applications using the + JPEG library. Most applications need only include jpeglib.h. } + +{ Original: jinclude.h Copyright (C) 1991-1994, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +{ Include auto-config file to find out which system include files we need. } + +uses +{$ifdef Delphi_Stream} + classes, +{$endif} + imjmorecfg; + +{ Nomssi: + To write a dest/source manager that handle streams rather than files, + you can edit the FILEptr definition and the JFREAD() and JFWRITE() + functions in this unit, you don't need to change the default managers + JDATASRC and JDATADST. } + +{$ifdef Delphi_Stream} +type + FILEptr = ^TStream; +{$else} + {$ifdef Delphi_Jpeg} + type + FILEptr = TCustomMemoryStream; + {$else} + type + FILEptr = ^File; + {$endif} +{$endif} + +{ We need the NULL macro and size_t typedef. + On an ANSI-conforming system it is sufficient to include . + Otherwise, we get them from or ; we may have to + pull in as well. + Note that the core JPEG library does not require ; + only the default error handler and data source/destination modules do. + But we must pull it in because of the references to FILE in jpeglib.h. + You can remove those references if you want to compile without .} + + + +{ We need memory copying and zeroing functions, plus strncpy(). + ANSI and System V implementations declare these in . + BSD doesn't have the mem() functions, but it does have bcopy()/bzero(). + Some systems may declare memset and memcpy in . + + NOTE: we assume the size parameters to these functions are of type size_t. + Change the casts in these macros if not! } + +procedure MEMZERO(target : pointer; size : size_t); + +procedure MEMCOPY(dest, src : pointer; size : size_t); + +{function SIZEOF(object) : size_t;} + +function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; + +function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; + +implementation + +procedure MEMZERO(target : pointer; size : size_t); +begin + FillChar(target^, size, 0); +end; + +procedure MEMCOPY(dest, src : pointer; size : size_t); +begin + Move(src^, dest^, size); +end; + +{ In ANSI C, and indeed any rational implementation, size_t is also the + type returned by sizeof(). However, it seems there are some irrational + implementations out there, in which sizeof() returns an int even though + size_t is defined as long or unsigned long. To ensure consistent results + we always use this SIZEOF() macro in place of using sizeof() directly. } + + +{#define + SIZEOF(object) (size_t(sizeof(object))} + + +{ The modules that use fread() and fwrite() always invoke them through + these macros. On some systems you may need to twiddle the argument casts. + CAUTION: argument order is different from underlying functions! } + + +function JFREAD(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; +var + count : uint; +begin + {$ifdef Delphi_Stream} + count := fp^.Read(buf^, sizeofbuf); + {$else} + blockread(fp^, buf^, sizeofbuf, count); + {$endif} + JFREAD := size_t(count); +end; + +function JFWRITE(fp : FILEptr; buf : pointer; sizeofbuf : size_t) : size_t; +var + count : uint; +begin + {$ifdef Delphi_Stream} + count := fp^.Write(buf^, sizeofbuf); + {$else} + blockwrite(fp^, buf^, sizeofbuf, count); + {$endif} + JFWRITE := size_t(count); +end; + + +end. diff --git a/Imaging/JpegLib/imjmemmgr.pas b/Imaging/JpegLib/imjmemmgr.pas index b3122f6..76d1271 100644 --- a/Imaging/JpegLib/imjmemmgr.pas +++ b/Imaging/JpegLib/imjmemmgr.pas @@ -1,1283 +1,1283 @@ -unit imjmemmgr; - -{ This file contains the JPEG system-independent memory management - routines. This code is usable across a wide variety of machines; most - of the system dependencies have been isolated in a separate file. - The major functions provided here are: - * pool-based allocation and freeing of memory; - * policy decisions about how to divide available memory among the - virtual arrays; - * control logic for swapping virtual arrays between main memory and - backing storage. - The separate system-dependent file provides the actual backing-storage - access code, and it contains the policy decision about how much total - main memory to use. - This file is system-dependent in the sense that some of its functions - are unnecessary in some systems. For example, if there is enough virtual - memory so that backing storage will never be used, much of the virtual - array control logic could be removed. (Of course, if you have that much - memory then you shouldn't care about a little bit of unused code...) } - -{ Original : jmemmgr.c ; Copyright (C) 1991-1997, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjdeferr, - imjerror, - imjpeglib, - imjutils, -{$IFDEF VER70} -{$ifndef NO_GETENV} - Dos, { DOS unit should declare getenv() } - { function GetEnv(name : string) : string; } -{$endif} - imjmemdos; { import the system-dependent declarations } -{$ELSE} - imjmemnobs; - {$DEFINE NO_GETENV} -{$ENDIF} - -{ Memory manager initialization. - When this is called, only the error manager pointer is valid in cinfo! } - -{GLOBAL} -procedure jinit_memory_mgr (cinfo : j_common_ptr); - -implementation - - -{ Some important notes: - The allocation routines provided here must never return NIL. - They should exit to error_exit if unsuccessful. - - It's not a good idea to try to merge the sarray and barray routines, - even though they are textually almost the same, because samples are - usually stored as bytes while coefficients are shorts or ints. Thus, - in machines where byte pointers have a different representation from - word pointers, the resulting machine code could not be the same. } - - -{ Many machines require storage alignment: longs must start on 4-byte - boundaries, doubles on 8-byte boundaries, etc. On such machines, malloc() - always returns pointers that are multiples of the worst-case alignment - requirement, and we had better do so too. - There isn't any really portable way to determine the worst-case alignment - requirement. This module assumes that the alignment requirement is - multiples of sizeof(ALIGN_TYPE). - By default, we define ALIGN_TYPE as double. This is necessary on some - workstations (where doubles really do need 8-byte alignment) and will work - fine on nearly everything. If your machine has lesser alignment needs, - you can save a few bytes by making ALIGN_TYPE smaller. - The only place I know of where this will NOT work is certain Macintosh - 680x0 compilers that define double as a 10-byte IEEE extended float. - Doing 10-byte alignment is counterproductive because longwords won't be - aligned well. Put "#define ALIGN_TYPE long" in jconfig.h if you have - such a compiler. } - -{$ifndef ALIGN_TYPE} { so can override from jconfig.h } -type - ALIGN_TYPE = double; -{$endif} - - -{ We allocate objects from "pools", where each pool is gotten with a single - request to jpeg_get_small() or jpeg_get_large(). There is no per-object - overhead within a pool, except for alignment padding. Each pool has a - header with a link to the next pool of the same class. - Small and large pool headers are identical except that the latter's - link pointer must be FAR on 80x86 machines. - Notice that the "real" header fields are union'ed with a dummy ALIGN_TYPE - field. This forces the compiler to make SIZEOF(small_pool_hdr) a multiple - of the alignment requirement of ALIGN_TYPE. } - -type - small_pool_ptr = ^small_pool_hdr; - small_pool_hdr = record - case byte of - 0:(hdr : record - next : small_pool_ptr; { next in list of pools } - bytes_used : size_t; { how many bytes already used within pool } - bytes_left : size_t; { bytes still available in this pool } - end); - 1:(dummy : ALIGN_TYPE); { included in union to ensure alignment } - end; {small_pool_hdr;} - -type - large_pool_ptr = ^large_pool_hdr; {FAR} - large_pool_hdr = record - case byte of - 0:(hdr : record - next : large_pool_ptr; { next in list of pools } - bytes_used : size_t; { how many bytes already used within pool } - bytes_left : size_t; { bytes still available in this pool } - end); - 1:(dummy : ALIGN_TYPE); { included in union to ensure alignment } - end; {large_pool_hdr;} - - -{ Here is the full definition of a memory manager object. } - -type - my_mem_ptr = ^my_memory_mgr; - my_memory_mgr = record - pub : jpeg_memory_mgr; { public fields } - - { Each pool identifier (lifetime class) names a linked list of pools. } - small_list : array[0..JPOOL_NUMPOOLS-1] of small_pool_ptr ; - large_list : array[0..JPOOL_NUMPOOLS-1] of large_pool_ptr ; - - { Since we only have one lifetime class of virtual arrays, only one - linked list is necessary (for each datatype). Note that the virtual - array control blocks being linked together are actually stored somewhere - in the small-pool list. } - - virt_sarray_list : jvirt_sarray_ptr; - virt_barray_list : jvirt_barray_ptr; - - { This counts total space obtained from jpeg_get_small/large } - total_space_allocated : long; - - { alloc_sarray and alloc_barray set this value for use by virtual - array routines. } - - last_rowsperchunk : JDIMENSION; { from most recent alloc_sarray/barray } - end; {my_memory_mgr;} - - {$ifndef AM_MEMORY_MANAGER} { only jmemmgr.c defines these } - -{ The control blocks for virtual arrays. - Note that these blocks are allocated in the "small" pool area. - System-dependent info for the associated backing store (if any) is hidden - inside the backing_store_info struct. } -type - jvirt_sarray_control = record - mem_buffer : JSAMPARRAY; { => the in-memory buffer } - rows_in_array : JDIMENSION; { total virtual array height } - samplesperrow : JDIMENSION; { width of array (and of memory buffer) } - maxaccess : JDIMENSION; { max rows accessed by access_virt_sarray } - rows_in_mem : JDIMENSION; { height of memory buffer } - rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer } - cur_start_row : JDIMENSION; { first logical row # in the buffer } - first_undef_row : JDIMENSION; { row # of first uninitialized row } - pre_zero : boolean; { pre-zero mode requested? } - dirty : boolean; { do current buffer contents need written? } - b_s_open : boolean; { is backing-store data valid? } - next : jvirt_sarray_ptr; { link to next virtual sarray control block } - b_s_info : backing_store_info; { System-dependent control info } - end; - - jvirt_barray_control = record - mem_buffer : JBLOCKARRAY; { => the in-memory buffer } - rows_in_array : JDIMENSION; { total virtual array height } - blocksperrow : JDIMENSION; { width of array (and of memory buffer) } - maxaccess : JDIMENSION; { max rows accessed by access_virt_barray } - rows_in_mem : JDIMENSION; { height of memory buffer } - rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer } - cur_start_row : JDIMENSION; { first logical row # in the buffer } - first_undef_row : JDIMENSION; { row # of first uninitialized row } - pre_zero : boolean; { pre-zero mode requested? } - dirty : boolean; { do current buffer contents need written? } - b_s_open : boolean; { is backing-store data valid? } - next : jvirt_barray_ptr; { link to next virtual barray control block } - b_s_info : backing_store_info; { System-dependent control info } - end; - {$endif} { AM_MEMORY_MANAGER} - -{$ifdef MEM_STATS} { optional extra stuff for statistics } - -{LOCAL} -procedure print_mem_stats (cinfo : j_common_ptr; pool_id : int); -var - mem : my_mem_ptr; - shdr_ptr : small_pool_ptr; - lhdr_ptr : large_pool_ptr; -begin - mem := my_mem_ptr (cinfo^.mem); - - { Since this is only a debugging stub, we can cheat a little by using - fprintf directly rather than going through the trace message code. - This is helpful because message parm array can't handle longs. } - - WriteLn(output, 'Freeing pool ', pool_id,', total space := ', - mem^.total_space_allocated); - - lhdr_ptr := mem^.large_list[pool_id]; - while (lhdr_ptr <> NIL) do - begin - WriteLn(output, ' Large chunk used ', - long (lhdr_ptr^.hdr.bytes_used)); - lhdr_ptr := lhdr_ptr^.hdr.next; - end; - - shdr_ptr := mem^.small_list[pool_id]; - - while (shdr_ptr <> NIL) do - begin - WriteLn(output, ' Small chunk used ', - long (shdr_ptr^.hdr.bytes_used), ' free ', - long (shdr_ptr^.hdr.bytes_left) ); - shdr_ptr := shdr_ptr^.hdr.next; - end; -end; - -{$endif} { MEM_STATS } - - -{LOCAL} -procedure out_of_memory (cinfo : j_common_ptr; which : int); -{ Report an out-of-memory error and stop execution } -{ If we compiled MEM_STATS support, report alloc requests before dying } -begin -{$ifdef MEM_STATS} - cinfo^.err^.trace_level := 2; { force self_destruct to report stats } -{$endif} - ERREXIT1(cinfo, JERR_OUT_OF_MEMORY, which); -end; - - -{ Allocation of "small" objects. - - For these, we use pooled storage. When a new pool must be created, - we try to get enough space for the current request plus a "slop" factor, - where the slop will be the amount of leftover space in the new pool. - The speed vs. space tradeoff is largely determined by the slop values. - A different slop value is provided for each pool class (lifetime), - and we also distinguish the first pool of a class from later ones. - NOTE: the values given work fairly well on both 16- and 32-bit-int - machines, but may be too small if longs are 64 bits or more. } - -const - first_pool_slop : array[0..JPOOL_NUMPOOLS-1] of size_t = - (1600, { first PERMANENT pool } - 16000); { first IMAGE pool } - -const - extra_pool_slop : array[0..JPOOL_NUMPOOLS-1] of size_t = - (0, { additional PERMANENT pools } - 5000); { additional IMAGE pools } - -const - MIN_SLOP = 50; { greater than 0 to avoid futile looping } - - -{METHODDEF} -function alloc_small (cinfo : j_common_ptr; - pool_id : int; - sizeofobject : size_t) : pointer; -type - byteptr = ^byte; -{ Allocate a "small" object } -var - mem : my_mem_ptr; - hdr_ptr, prev_hdr_ptr : small_pool_ptr; - data_ptr : byteptr; - odd_bytes, min_request, slop : size_t; -begin - mem := my_mem_ptr (cinfo^.mem); - - { Check for unsatisfiable request (do now to ensure no overflow below) } - if (sizeofobject > size_t(MAX_ALLOC_CHUNK-SIZEOF(small_pool_hdr))) then - out_of_memory(cinfo, 1); { request exceeds malloc's ability } - - { Round up the requested size to a multiple of SIZEOF(ALIGN_TYPE) } - odd_bytes := sizeofobject mod SIZEOF(ALIGN_TYPE); - if (odd_bytes > 0) then - Inc(sizeofobject, SIZEOF(ALIGN_TYPE) - odd_bytes); - - { See if space is available in any existing pool } - if (pool_id < 0) or (pool_id >= JPOOL_NUMPOOLS) then - ERREXIT1(j_common_ptr(cinfo), JERR_BAD_POOL_ID, pool_id); { safety check } - prev_hdr_ptr := NIL; - hdr_ptr := mem^.small_list[pool_id]; - while (hdr_ptr <> NIL) do - begin - if (hdr_ptr^.hdr.bytes_left >= sizeofobject) then - break; { found pool with enough space } - prev_hdr_ptr := hdr_ptr; - hdr_ptr := hdr_ptr^.hdr.next; - end; - - { Time to make a new pool? } - if (hdr_ptr = NIL) then - begin - { min_request is what we need now, slop is what will be leftover } - min_request := sizeofobject + SIZEOF(small_pool_hdr); - if (prev_hdr_ptr = NIL) then { first pool in class? } - slop := first_pool_slop[pool_id] - else - slop := extra_pool_slop[pool_id]; - { Don't ask for more than MAX_ALLOC_CHUNK } - if (slop > size_t (MAX_ALLOC_CHUNK-min_request)) then - slop := size_t (MAX_ALLOC_CHUNK-min_request); - { Try to get space, if fail reduce slop and try again } - while TRUE do - begin - hdr_ptr := small_pool_ptr(jpeg_get_small(cinfo, min_request + slop)); - if (hdr_ptr <> NIL) then - break; - slop := slop div 2; - if (slop < MIN_SLOP) then { give up when it gets real small } - out_of_memory(cinfo, 2); { jpeg_get_small failed } - end; - Inc(mem^.total_space_allocated, min_request + slop); - { Success, initialize the new pool header and add to end of list } - hdr_ptr^.hdr.next := NIL; - hdr_ptr^.hdr.bytes_used := 0; - hdr_ptr^.hdr.bytes_left := sizeofobject + slop; - if (prev_hdr_ptr = NIL) then { first pool in class? } - mem^.small_list[pool_id] := hdr_ptr - else - prev_hdr_ptr^.hdr.next := hdr_ptr; - end; - - { OK, allocate the object from the current pool } - data_ptr := byteptr (hdr_ptr); - Inc(small_pool_ptr(data_ptr)); { point to first data byte in pool } - Inc(data_ptr, hdr_ptr^.hdr.bytes_used); { point to place for object } - Inc(hdr_ptr^.hdr.bytes_used, sizeofobject); - Dec(hdr_ptr^.hdr.bytes_left, sizeofobject); - - alloc_small := pointer(data_ptr); -end; - - -{ Allocation of "large" objects. - - The external semantics of these are the same as "small" objects, - except that FAR pointers are used on 80x86. However the pool - management heuristics are quite different. We assume that each - request is large enough that it may as well be passed directly to - jpeg_get_large; the pool management just links everything together - so that we can free it all on demand. - Note: the major use of "large" objects is in JSAMPARRAY and JBLOCKARRAY - structures. The routines that create these structures (see below) - deliberately bunch rows together to ensure a large request size. } - -{METHODDEF} -function alloc_large (cinfo : j_common_ptr; - pool_id : int; - sizeofobject : size_t) : pointer; -{ Allocate a "large" object } -var - mem : my_mem_ptr; - hdr_ptr : large_pool_ptr; - odd_bytes : size_t; -var - dest_ptr : large_pool_ptr; -begin - mem := my_mem_ptr (cinfo^.mem); - - { Check for unsatisfiable request (do now to ensure no overflow below) } - if (sizeofobject > size_t (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr))) then - out_of_memory(cinfo, 3); { request exceeds malloc's ability } - - { Round up the requested size to a multiple of SIZEOF(ALIGN_TYPE) } - odd_bytes := sizeofobject mod SIZEOF(ALIGN_TYPE); - if (odd_bytes > 0) then - Inc(sizeofobject, SIZEOF(ALIGN_TYPE) - odd_bytes); - - { Always make a new pool } - if (pool_id < 0) or (pool_id >= JPOOL_NUMPOOLS) then - ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check } - - hdr_ptr := large_pool_ptr (jpeg_get_large(cinfo, sizeofobject + - SIZEOF(large_pool_hdr))); - if (hdr_ptr = NIL) then - out_of_memory(cinfo, 4); { jpeg_get_large failed } - Inc(mem^.total_space_allocated, sizeofobject + SIZEOF(large_pool_hdr)); - - { Success, initialize the new pool header and add to list } - hdr_ptr^.hdr.next := mem^.large_list[pool_id]; - { We maintain space counts in each pool header for statistical purposes, - even though they are not needed for allocation. } - - hdr_ptr^.hdr.bytes_used := sizeofobject; - hdr_ptr^.hdr.bytes_left := 0; - mem^.large_list[pool_id] := hdr_ptr; - - {alloc_large := pointerFAR (hdr_ptr + 1); - point to first data byte in pool } - dest_ptr := hdr_ptr; - Inc(large_pool_ptr(dest_ptr)); - alloc_large := dest_ptr; -end; - - -{ Creation of 2-D sample arrays. - The pointers are in near heap, the samples themselves in FAR heap. - - To minimize allocation overhead and to allow I/O of large contiguous - blocks, we allocate the sample rows in groups of as many rows as possible - without exceeding MAX_ALLOC_CHUNK total bytes per allocation request. - NB: the virtual array control routines, later in this file, know about - this chunking of rows. The rowsperchunk value is left in the mem manager - object so that it can be saved away if this sarray is the workspace for - a virtual array. } - -{METHODDEF} -function alloc_sarray (cinfo : j_common_ptr; - pool_id : int; - samplesperrow : JDIMENSION; - numrows : JDIMENSION) : JSAMPARRAY; -{ Allocate a 2-D sample array } -var - mem : my_mem_ptr; - the_result : JSAMPARRAY; - workspace : JSAMPROW; - rowsperchunk, currow, i : JDIMENSION; - ltemp : long; -begin - mem := my_mem_ptr(cinfo^.mem); - - { Calculate max # of rows allowed in one allocation chunk } - ltemp := (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr)) div - (long(samplesperrow) * SIZEOF(JSAMPLE)); - if (ltemp <= 0) then - ERREXIT(cinfo, JERR_WIDTH_OVERFLOW); - if (ltemp < long(numrows)) then - rowsperchunk := JDIMENSION (ltemp) - else - rowsperchunk := numrows; - mem^.last_rowsperchunk := rowsperchunk; - - { Get space for row pointers (small object) } - the_result := JSAMPARRAY (alloc_small(cinfo, pool_id, - size_t (numrows * SIZEOF(JSAMPROW)))); - - { Get the rows themselves (large objects) } - currow := 0; - while (currow < numrows) do - begin - {rowsperchunk := MIN(rowsperchunk, numrows - currow);} - if rowsperchunk > numrows - currow then - rowsperchunk := numrows - currow; - - workspace := JSAMPROW (alloc_large(cinfo, pool_id, - size_t (size_t(rowsperchunk) * size_t(samplesperrow) - * SIZEOF(JSAMPLE))) ); - for i := pred(rowsperchunk) downto 0 do - begin - the_result^[currow] := workspace; - Inc(currow); - Inc(JSAMPLE_PTR(workspace), samplesperrow); - end; - end; - - alloc_sarray := the_result; -end; - - -{ Creation of 2-D coefficient-block arrays. - This is essentially the same as the code for sample arrays, above. } - -{METHODDEF} -function alloc_barray (cinfo : j_common_ptr; - pool_id : int; - blocksperrow : JDIMENSION; - numrows : JDIMENSION) : JBLOCKARRAY; -{ Allocate a 2-D coefficient-block array } -var - mem : my_mem_ptr; - the_result : JBLOCKARRAY; - workspace : JBLOCKROW; - rowsperchunk, currow, i : JDIMENSION; - ltemp : long; -begin - mem := my_mem_ptr(cinfo^.mem); - - { Calculate max # of rows allowed in one allocation chunk } - ltemp := (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr)) div - (long(blocksperrow) * SIZEOF(JBLOCK)); - - if (ltemp <= 0) then - ERREXIT(cinfo, JERR_WIDTH_OVERFLOW); - if (ltemp < long(numrows)) then - rowsperchunk := JDIMENSION (ltemp) - else - rowsperchunk := numrows; - mem^.last_rowsperchunk := rowsperchunk; - - { Get space for row pointers (small object) } - the_result := JBLOCKARRAY (alloc_small(cinfo, pool_id, - size_t (numrows * SIZEOF(JBLOCKROW))) ); - - { Get the rows themselves (large objects) } - currow := 0; - while (currow < numrows) do - begin - {rowsperchunk := MIN(rowsperchunk, numrows - currow);} - if rowsperchunk > numrows - currow then - rowsperchunk := numrows - currow; - - workspace := JBLOCKROW (alloc_large(cinfo, pool_id, - size_t (size_t(rowsperchunk) * size_t(blocksperrow) - * SIZEOF(JBLOCK))) ); - for i := rowsperchunk downto 1 do - begin - the_result^[currow] := workspace; - Inc(currow); - Inc(JBLOCK_PTR(workspace), blocksperrow); - end; - end; - - alloc_barray := the_result; -end; - - -{ About virtual array management: - - The above "normal" array routines are only used to allocate strip buffers - (as wide as the image, but just a few rows high). Full-image-sized buffers - are handled as "virtual" arrays. The array is still accessed a strip at a - time, but the memory manager must save the whole array for repeated - accesses. The intended implementation is that there is a strip buffer in - memory (as high as is possible given the desired memory limit), plus a - backing file that holds the rest of the array. - - The request_virt_array routines are told the total size of the image and - the maximum number of rows that will be accessed at once. The in-memory - buffer must be at least as large as the maxaccess value. - - The request routines create control blocks but not the in-memory buffers. - That is postponed until realize_virt_arrays is called. At that time the - total amount of space needed is known (approximately, anyway), so free - memory can be divided up fairly. - - The access_virt_array routines are responsible for making a specific strip - area accessible (after reading or writing the backing file, if necessary). - Note that the access routines are told whether the caller intends to modify - the accessed strip; during a read-only pass this saves having to rewrite - data to disk. The access routines are also responsible for pre-zeroing - any newly accessed rows, if pre-zeroing was requested. - - In current usage, the access requests are usually for nonoverlapping - strips; that is, successive access start_row numbers differ by exactly - num_rows := maxaccess. This means we can get good performance with simple - buffer dump/reload logic, by making the in-memory buffer be a multiple - of the access height; then there will never be accesses across bufferload - boundaries. The code will still work with overlapping access requests, - but it doesn't handle bufferload overlaps very efficiently. } - - -{METHODDEF} -function request_virt_sarray (cinfo : j_common_ptr; - pool_id : int; - pre_zero : boolean; - samplesperrow : JDIMENSION; - numrows : JDIMENSION; - maxaccess : JDIMENSION) : jvirt_sarray_ptr; -{ Request a virtual 2-D sample array } -var - mem : my_mem_ptr; - the_result : jvirt_sarray_ptr; -begin - mem := my_mem_ptr (cinfo^.mem); - - { Only IMAGE-lifetime virtual arrays are currently supported } - if (pool_id <> JPOOL_IMAGE) then - ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check } - - { get control block } - the_result := jvirt_sarray_ptr (alloc_small(cinfo, pool_id, - SIZEOF(jvirt_sarray_control)) ); - - the_result^.mem_buffer := NIL; { marks array not yet realized } - the_result^.rows_in_array := numrows; - the_result^.samplesperrow := samplesperrow; - the_result^.maxaccess := maxaccess; - the_result^.pre_zero := pre_zero; - the_result^.b_s_open := FALSE; { no associated backing-store object } - the_result^.next := mem^.virt_sarray_list; { add to list of virtual arrays } - mem^.virt_sarray_list := the_result; - - request_virt_sarray := the_result; -end; - - -{METHODDEF} -function request_virt_barray (cinfo : j_common_ptr; - pool_id : int; - pre_zero : boolean; - blocksperrow : JDIMENSION; - numrows : JDIMENSION; - maxaccess : JDIMENSION) : jvirt_barray_ptr; -{ Request a virtual 2-D coefficient-block array } -var - mem : my_mem_ptr; - the_result : jvirt_barray_ptr; -begin - mem := my_mem_ptr(cinfo^.mem); - - { Only IMAGE-lifetime virtual arrays are currently supported } - if (pool_id <> JPOOL_IMAGE) then - ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check } - - { get control block } - the_result := jvirt_barray_ptr(alloc_small(cinfo, pool_id, - SIZEOF(jvirt_barray_control)) ); - - the_result^.mem_buffer := NIL; { marks array not yet realized } - the_result^.rows_in_array := numrows; - the_result^.blocksperrow := blocksperrow; - the_result^.maxaccess := maxaccess; - the_result^.pre_zero := pre_zero; - the_result^.b_s_open := FALSE; { no associated backing-store object } - the_result^.next := mem^.virt_barray_list; { add to list of virtual arrays } - mem^.virt_barray_list := the_result; - - request_virt_barray := the_result; -end; - - -{METHODDEF} -procedure realize_virt_arrays (cinfo : j_common_ptr); -{ Allocate the in-memory buffers for any unrealized virtual arrays } -var - mem : my_mem_ptr; - space_per_minheight, maximum_space, avail_mem : long; - minheights, max_minheights : long; - sptr : jvirt_sarray_ptr; - bptr : jvirt_barray_ptr; -begin - mem := my_mem_ptr (cinfo^.mem); - { Compute the minimum space needed (maxaccess rows in each buffer) - and the maximum space needed (full image height in each buffer). - These may be of use to the system-dependent jpeg_mem_available routine. } - - space_per_minheight := 0; - maximum_space := 0; - sptr := mem^.virt_sarray_list; - while (sptr <> NIL) do - begin - if (sptr^.mem_buffer = NIL) then - begin { if not realized yet } - Inc(space_per_minheight, long(sptr^.maxaccess) * - long(sptr^.samplesperrow) * SIZEOF(JSAMPLE)); - Inc(maximum_space, long(sptr^.rows_in_array) * - long(sptr^.samplesperrow) * SIZEOF(JSAMPLE)); - end; - sptr := sptr^.next; - end; - bptr := mem^.virt_barray_list; - while (bptr <> NIL) do - begin - if (bptr^.mem_buffer = NIL) then - begin { if not realized yet } - Inc(space_per_minheight, long(bptr^.maxaccess) * - long(bptr^.blocksperrow) * SIZEOF(JBLOCK)); - Inc(maximum_space, long(bptr^.rows_in_array) * - long(bptr^.blocksperrow) * SIZEOF(JBLOCK)); - end; - bptr := bptr^.next; - end; - - if (space_per_minheight <= 0) then - exit; { no unrealized arrays, no work } - - { Determine amount of memory to actually use; this is system-dependent. } - avail_mem := jpeg_mem_available(cinfo, space_per_minheight, maximum_space, - mem^.total_space_allocated); - - { If the maximum space needed is available, make all the buffers full - height; otherwise parcel it out with the same number of minheights - in each buffer. } - - if (avail_mem >= maximum_space) then - max_minheights := long(1000000000) - else - begin - max_minheights := avail_mem div space_per_minheight; - { If there doesn't seem to be enough space, try to get the minimum - anyway. This allows a "stub" implementation of jpeg_mem_available(). } - if (max_minheights <= 0) then - max_minheights := 1; - end; - - { Allocate the in-memory buffers and initialize backing store as needed. } - - sptr := mem^.virt_sarray_list; - while (sptr <> NIL) do - begin - if (sptr^.mem_buffer = NIL) then - begin { if not realized yet } - minheights := (long(sptr^.rows_in_array) - long(1)) div LongInt(sptr^.maxaccess) + long(1); - if (minheights <= max_minheights) then - begin - { This buffer fits in memory } - sptr^.rows_in_mem := sptr^.rows_in_array; - end - else - begin - { It doesn't fit in memory, create backing store. } - sptr^.rows_in_mem := JDIMENSION(max_minheights) * sptr^.maxaccess; - jpeg_open_backing_store(cinfo, - @sptr^.b_s_info, - long(sptr^.rows_in_array) * - long(sptr^.samplesperrow) * - long(SIZEOF(JSAMPLE))); - sptr^.b_s_open := TRUE; - end; - sptr^.mem_buffer := alloc_sarray(cinfo, JPOOL_IMAGE, - sptr^.samplesperrow, sptr^.rows_in_mem); - sptr^.rowsperchunk := mem^.last_rowsperchunk; - sptr^.cur_start_row := 0; - sptr^.first_undef_row := 0; - sptr^.dirty := FALSE; - end; - sptr := sptr^.next; - end; - - bptr := mem^.virt_barray_list; - while (bptr <> NIL) do - begin - if (bptr^.mem_buffer = NIL) then - begin { if not realized yet } - minheights := (long(bptr^.rows_in_array) - long(1)) div LongInt(bptr^.maxaccess) + long(1); - if (minheights <= max_minheights) then - begin - { This buffer fits in memory } - bptr^.rows_in_mem := bptr^.rows_in_array; - end - else - begin - { It doesn't fit in memory, create backing store. } - bptr^.rows_in_mem := JDIMENSION (max_minheights) * bptr^.maxaccess; - jpeg_open_backing_store(cinfo, - @bptr^.b_s_info, - long(bptr^.rows_in_array) * - long(bptr^.blocksperrow) * - long(SIZEOF(JBLOCK))); - bptr^.b_s_open := TRUE; - end; - bptr^.mem_buffer := alloc_barray(cinfo, JPOOL_IMAGE, - bptr^.blocksperrow, bptr^.rows_in_mem); - bptr^.rowsperchunk := mem^.last_rowsperchunk; - bptr^.cur_start_row := 0; - bptr^.first_undef_row := 0; - bptr^.dirty := FALSE; - end; - bptr := bptr^.next; - end; -end; - - -{LOCAL} -procedure do_sarray_io (cinfo : j_common_ptr; - ptr : jvirt_sarray_ptr; - writing : boolean); -{ Do backing store read or write of a virtual sample array } -var - bytesperrow, file_offset, byte_count, rows, thisrow, i : long; -begin - - bytesperrow := long(ptr^.samplesperrow * SIZEOF(JSAMPLE)); - file_offset := LongInt(ptr^.cur_start_row) * bytesperrow; - { Loop to read or write each allocation chunk in mem_buffer } - i := 0; - while i < long(ptr^.rows_in_mem) do - begin - - { One chunk, but check for short chunk at end of buffer } - {rows := MIN(long(ptr^.rowsperchunk), long(ptr^.rows_in_mem - i));} - rows := long(ptr^.rowsperchunk); - if rows > long(ptr^.rows_in_mem) - i then - rows := long(ptr^.rows_in_mem) - i; - { Transfer no more than is currently defined } - thisrow := long (ptr^.cur_start_row) + i; - {rows := MIN(rows, long(ptr^.first_undef_row) - thisrow);} - if (rows > long(ptr^.first_undef_row) - thisrow) then - rows := long(ptr^.first_undef_row) - thisrow; - { Transfer no more than fits in file } - {rows := MIN(rows, long(ptr^.rows_in_array) - thisrow);} - if (rows > long(ptr^.rows_in_array) - thisrow) then - rows := long(ptr^.rows_in_array) - thisrow; - - if (rows <= 0) then { this chunk might be past end of file! } - break; - byte_count := rows * bytesperrow; - if (writing) then - ptr^.b_s_info.write_backing_store (cinfo, - @ptr^.b_s_info, - pointer {FAR} (ptr^.mem_buffer^[i]), - file_offset, byte_count) - else - ptr^.b_s_info.read_backing_store (cinfo, - @ptr^.b_s_info, - pointer {FAR} (ptr^.mem_buffer^[i]), - file_offset, byte_count); - Inc(file_offset, byte_count); - Inc(i, ptr^.rowsperchunk); - end; -end; - - -{LOCAL} -procedure do_barray_io (cinfo : j_common_ptr; - ptr : jvirt_barray_ptr; - writing : boolean); -{ Do backing store read or write of a virtual coefficient-block array } -var - bytesperrow, file_offset, byte_count, rows, thisrow, i : long; -begin - bytesperrow := long (ptr^.blocksperrow) * SIZEOF(JBLOCK); - file_offset := LongInt(ptr^.cur_start_row) * bytesperrow; - { Loop to read or write each allocation chunk in mem_buffer } - i := 0; - while (i < long(ptr^.rows_in_mem)) do - begin - { One chunk, but check for short chunk at end of buffer } - {rows := MIN(long(ptr^.rowsperchunk), long(ptr^.rows_in_mem - i));} - rows := long(ptr^.rowsperchunk); - if rows > long(ptr^.rows_in_mem) - i then - rows := long(ptr^.rows_in_mem) - i; - { Transfer no more than is currently defined } - thisrow := long (ptr^.cur_start_row) + i; - {rows := MIN(rows, long(ptr^.first_undef_row - thisrow));} - if rows > long(ptr^.first_undef_row) - thisrow then - rows := long(ptr^.first_undef_row) - thisrow; - { Transfer no more than fits in file } - {rows := MIN(rows, long (ptr^.rows_in_array - thisrow));} - if (rows > long (ptr^.rows_in_array) - thisrow) then - rows := long (ptr^.rows_in_array) - thisrow; - - if (rows <= 0) then { this chunk might be past end of file! } - break; - byte_count := rows * bytesperrow; - if (writing) then - ptr^.b_s_info.write_backing_store (cinfo, - @ptr^.b_s_info, - {FAR} pointer(ptr^.mem_buffer^[i]), - file_offset, byte_count) - else - ptr^.b_s_info.read_backing_store (cinfo, - @ptr^.b_s_info, - {FAR} pointer(ptr^.mem_buffer^[i]), - file_offset, byte_count); - Inc(file_offset, byte_count); - Inc(i, ptr^.rowsperchunk); - end; -end; - - -{METHODDEF} -function access_virt_sarray (cinfo : j_common_ptr; - ptr : jvirt_sarray_ptr; - start_row : JDIMENSION; - num_rows : JDIMENSION; - writable : boolean ) : JSAMPARRAY; -{ Access the part of a virtual sample array starting at start_row } -{ and extending for num_rows rows. writable is true if } -{ caller intends to modify the accessed area. } -var - end_row : JDIMENSION; - undef_row : JDIMENSION; -var - bytesperrow : size_t; -var - ltemp : long; -begin - end_row := start_row + num_rows; - { debugging check } - if (end_row > ptr^.rows_in_array) or (num_rows > ptr^.maxaccess) or - (ptr^.mem_buffer = NIL) then - ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); - - { Make the desired part of the virtual array accessible } - if (start_row < ptr^.cur_start_row) or - (end_row > ptr^.cur_start_row+ptr^.rows_in_mem) then - begin - if (not ptr^.b_s_open) then - ERREXIT(cinfo, JERR_VIRTUAL_BUG); - { Flush old buffer contents if necessary } - if (ptr^.dirty) then - begin - do_sarray_io(cinfo, ptr, TRUE); - ptr^.dirty := FALSE; - end; - { Decide what part of virtual array to access. - Algorithm: if target address > current window, assume forward scan, - load starting at target address. If target address < current window, - assume backward scan, load so that target area is top of window. - Note that when switching from forward write to forward read, will have - start_row := 0, so the limiting case applies and we load from 0 anyway. } - if (start_row > ptr^.cur_start_row) then - begin - ptr^.cur_start_row := start_row; - end - else - begin - { use long arithmetic here to avoid overflow & unsigned problems } - - - ltemp := long(end_row) - long(ptr^.rows_in_mem); - if (ltemp < 0) then - ltemp := 0; { don't fall off front end of file } - ptr^.cur_start_row := JDIMENSION(ltemp); - end; - { Read in the selected part of the array. - During the initial write pass, we will do no actual read - because the selected part is all undefined. } - - do_sarray_io(cinfo, ptr, FALSE); - end; - { Ensure the accessed part of the array is defined; prezero if needed. - To improve locality of access, we only prezero the part of the array - that the caller is about to access, not the entire in-memory array. } - if (ptr^.first_undef_row < end_row) then - begin - if (ptr^.first_undef_row < start_row) then - begin - if (writable) then { writer skipped over a section of array } - ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); - undef_row := start_row; { but reader is allowed to read ahead } - end - else - begin - undef_row := ptr^.first_undef_row; - end; - if (writable) then - ptr^.first_undef_row := end_row; - if (ptr^.pre_zero) then - begin - bytesperrow := size_t(ptr^.samplesperrow) * SIZEOF(JSAMPLE); - Dec(undef_row, ptr^.cur_start_row); { make indexes relative to buffer } - Dec(end_row, ptr^.cur_start_row); - while (undef_row < end_row) do - begin - jzero_far({FAR} pointer(ptr^.mem_buffer^[undef_row]), bytesperrow); - Inc(undef_row); - end; - end - else - begin - if (not writable) then { reader looking at undefined data } - ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); - end; - end; - { Flag the buffer dirty if caller will write in it } - if (writable) then - ptr^.dirty := TRUE; - { Return address of proper part of the buffer } - access_virt_sarray := JSAMPARRAY(@ ptr^.mem_buffer^[start_row - ptr^.cur_start_row]); -end; - - -{METHODDEF} -function access_virt_barray (cinfo : j_common_ptr; - ptr : jvirt_barray_ptr; - start_row : JDIMENSION; - num_rows : JDIMENSION; - writable : boolean) : JBLOCKARRAY; -{ Access the part of a virtual block array starting at start_row } -{ and extending for num_rows rows. writable is true if } -{ caller intends to modify the accessed area. } -var - end_row : JDIMENSION; - undef_row : JDIMENSION; - ltemp : long; -var - bytesperrow : size_t; -begin - end_row := start_row + num_rows; - - { debugging check } - if (end_row > ptr^.rows_in_array) or (num_rows > ptr^.maxaccess) or - (ptr^.mem_buffer = NIL) then - ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); - - { Make the desired part of the virtual array accessible } - if (start_row < ptr^.cur_start_row) or - (end_row > ptr^.cur_start_row+ptr^.rows_in_mem) then - begin - if (not ptr^.b_s_open) then - ERREXIT(cinfo, JERR_VIRTUAL_BUG); - { Flush old buffer contents if necessary } - if (ptr^.dirty) then - begin - do_barray_io(cinfo, ptr, TRUE); - ptr^.dirty := FALSE; - end; - { Decide what part of virtual array to access. - Algorithm: if target address > current window, assume forward scan, - load starting at target address. If target address < current window, - assume backward scan, load so that target area is top of window. - Note that when switching from forward write to forward read, will have - start_row := 0, so the limiting case applies and we load from 0 anyway. } - - if (start_row > ptr^.cur_start_row) then - begin - ptr^.cur_start_row := start_row; - end - else - begin - { use long arithmetic here to avoid overflow & unsigned problems } - - ltemp := long(end_row) - long(ptr^.rows_in_mem); - if (ltemp < 0) then - ltemp := 0; { don't fall off front end of file } - ptr^.cur_start_row := JDIMENSION (ltemp); - end; - { Read in the selected part of the array. - During the initial write pass, we will do no actual read - because the selected part is all undefined. } - - do_barray_io(cinfo, ptr, FALSE); - end; - { Ensure the accessed part of the array is defined; prezero if needed. - To improve locality of access, we only prezero the part of the array - that the caller is about to access, not the entire in-memory array. } - - if (ptr^.first_undef_row < end_row) then - begin - if (ptr^.first_undef_row < start_row) then - begin - if (writable) then { writer skipped over a section of array } - ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); - undef_row := start_row; { but reader is allowed to read ahead } - end - else - begin - undef_row := ptr^.first_undef_row; - end; - if (writable) then - ptr^.first_undef_row := end_row; - if (ptr^.pre_zero) then - begin - bytesperrow := size_t (ptr^.blocksperrow) * SIZEOF(JBLOCK); - Dec(undef_row, ptr^.cur_start_row); { make indexes relative to buffer } - Dec(end_row, ptr^.cur_start_row); - while (undef_row < end_row) do - begin - jzero_far({FAR}pointer(ptr^.mem_buffer^[undef_row]), bytesperrow); - Inc(undef_row); - end; - end - else - begin - if (not writable) then { reader looking at undefined data } - ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); - end; - end; - { Flag the buffer dirty if caller will write in it } - if (writable) then - ptr^.dirty := TRUE; - { Return address of proper part of the buffer } - access_virt_barray := JBLOCKARRAY(@ ptr^.mem_buffer^[start_row - ptr^.cur_start_row]); -end; - - -{ Release all objects belonging to a specified pool. } - -{METHODDEF} -procedure free_pool (cinfo : j_common_ptr; pool_id : int); -var - mem : my_mem_ptr; - shdr_ptr : small_pool_ptr; - lhdr_ptr : large_pool_ptr; - space_freed : size_t; -var - sptr : jvirt_sarray_ptr; - bptr : jvirt_barray_ptr; -var - next_lhdr_ptr : large_pool_ptr; - next_shdr_ptr : small_pool_ptr; -begin - mem := my_mem_ptr(cinfo^.mem); - - if (pool_id < 0) or (pool_id >= JPOOL_NUMPOOLS) then - ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check } - -{$ifdef MEM_STATS} - if (cinfo^.err^.trace_level > 1) then - print_mem_stats(cinfo, pool_id); { print pool's memory usage statistics } -{$endif} - - { If freeing IMAGE pool, close any virtual arrays first } - if (pool_id = JPOOL_IMAGE) then - begin - sptr := mem^.virt_sarray_list; - while (sptr <> NIL) do - begin - if (sptr^.b_s_open) then - begin { there may be no backing store } - sptr^.b_s_open := FALSE; { prevent recursive close if error } - sptr^.b_s_info.close_backing_store (cinfo, @sptr^.b_s_info); - end; - sptr := sptr^.next; - end; - mem^.virt_sarray_list := NIL; - bptr := mem^.virt_barray_list; - while (bptr <> NIL) do - begin - if (bptr^.b_s_open) then - begin { there may be no backing store } - bptr^.b_s_open := FALSE; { prevent recursive close if error } - bptr^.b_s_info.close_backing_store (cinfo, @bptr^.b_s_info); - end; - bptr := bptr^.next; - end; - mem^.virt_barray_list := NIL; - end; - - { Release large objects } - lhdr_ptr := mem^.large_list[pool_id]; - mem^.large_list[pool_id] := NIL; - - while (lhdr_ptr <> NIL) do - begin - next_lhdr_ptr := lhdr_ptr^.hdr.next; - space_freed := lhdr_ptr^.hdr.bytes_used + - lhdr_ptr^.hdr.bytes_left + - SIZEOF(large_pool_hdr); - jpeg_free_large(cinfo, {FAR} pointer(lhdr_ptr), space_freed); - Dec(mem^.total_space_allocated, space_freed); - lhdr_ptr := next_lhdr_ptr; - end; - - { Release small objects } - shdr_ptr := mem^.small_list[pool_id]; - mem^.small_list[pool_id] := NIL; - - while (shdr_ptr <> NIL) do - begin - next_shdr_ptr := shdr_ptr^.hdr.next; - space_freed := shdr_ptr^.hdr.bytes_used + - shdr_ptr^.hdr.bytes_left + - SIZEOF(small_pool_hdr); - jpeg_free_small(cinfo, pointer(shdr_ptr), space_freed); - Dec(mem^.total_space_allocated, space_freed); - shdr_ptr := next_shdr_ptr; - end; -end; - - -{ Close up shop entirely. - Note that this cannot be called unless cinfo^.mem is non-NIL. } - -{METHODDEF} -procedure self_destruct (cinfo : j_common_ptr); -var - pool : int; -begin - { Close all backing store, release all memory. - Releasing pools in reverse order might help avoid fragmentation - with some (brain-damaged) malloc libraries. } - - for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT do - begin - free_pool(cinfo, pool); - end; - - { Release the memory manager control block too. } - jpeg_free_small(cinfo, pointer(cinfo^.mem), SIZEOF(my_memory_mgr)); - cinfo^.mem := NIL; { ensures I will be called only once } - - jpeg_mem_term(cinfo); { system-dependent cleanup } -end; - - -{ Memory manager initialization. - When this is called, only the error manager pointer is valid in cinfo! } - -{GLOBAL} -procedure jinit_memory_mgr (cinfo : j_common_ptr); -var - mem : my_mem_ptr; - max_to_use : long; - pool : int; - test_mac : size_t; -{$ifndef NO_GETENV} -var - memenv : string; - code : integer; -{$endif} -begin - cinfo^.mem := NIL; { for safety if init fails } - - { Check for configuration errors. - SIZEOF(ALIGN_TYPE) should be a power of 2; otherwise, it probably - doesn't reflect any real hardware alignment requirement. - The test is a little tricky: for X>0, X and X-1 have no one-bits - in common if and only if X is a power of 2, ie has only one one-bit. - Some compilers may give an "unreachable code" warning here; ignore it. } - if ((SIZEOF(ALIGN_TYPE) and (SIZEOF(ALIGN_TYPE)-1)) <> 0) then - ERREXIT(cinfo, JERR_BAD_ALIGN_TYPE); - { MAX_ALLOC_CHUNK must be representable as type size_t, and must be - a multiple of SIZEOF(ALIGN_TYPE). - Again, an "unreachable code" warning may be ignored here. - But a "constant too large" warning means you need to fix MAX_ALLOC_CHUNK. } - - test_mac := size_t (MAX_ALLOC_CHUNK); - if (long (test_mac) <> MAX_ALLOC_CHUNK) or - ((MAX_ALLOC_CHUNK mod SIZEOF(ALIGN_TYPE)) <> 0) then - ERREXIT(cinfo, JERR_BAD_ALLOC_CHUNK); - - max_to_use := jpeg_mem_init(cinfo); { system-dependent initialization } - - { Attempt to allocate memory manager's control block } - mem := my_mem_ptr (jpeg_get_small(cinfo, SIZEOF(my_memory_mgr))); - - if (mem = NIL) then - begin - jpeg_mem_term(cinfo); { system-dependent cleanup } - ERREXIT1(cinfo, JERR_OUT_OF_MEMORY, 0); - end; - - { OK, fill in the method pointers } - mem^.pub.alloc_small := alloc_small; - mem^.pub.alloc_large := alloc_large; - mem^.pub.alloc_sarray := alloc_sarray; - mem^.pub.alloc_barray := alloc_barray; - mem^.pub.request_virt_sarray := request_virt_sarray; - mem^.pub.request_virt_barray := request_virt_barray; - mem^.pub.realize_virt_arrays := realize_virt_arrays; - mem^.pub.access_virt_sarray := access_virt_sarray; - mem^.pub.access_virt_barray := access_virt_barray; - mem^.pub.free_pool := free_pool; - mem^.pub.self_destruct := self_destruct; - - { Make MAX_ALLOC_CHUNK accessible to other modules } - mem^.pub.max_alloc_chunk := MAX_ALLOC_CHUNK; - - { Initialize working state } - mem^.pub.max_memory_to_use := max_to_use; - - for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT do - begin - mem^.small_list[pool] := NIL; - mem^.large_list[pool] := NIL; - end; - mem^.virt_sarray_list := NIL; - mem^.virt_barray_list := NIL; - - mem^.total_space_allocated := SIZEOF(my_memory_mgr); - - { Declare ourselves open for business } - cinfo^.mem := @mem^.pub; - - { Check for an environment variable JPEGMEM; if found, override the - default max_memory setting from jpeg_mem_init. Note that the - surrounding application may again override this value. - If your system doesn't support getenv(), define NO_GETENV to disable - this feature. } - -{$ifndef NO_GETENV} - memenv := getenv('JPEGMEM'); - if (memenv <> '') then - begin - Val(memenv, max_to_use, code); - if (Code = 0) then - begin - max_to_use := max_to_use * long(1000); - mem^.pub.max_memory_to_use := max_to_use * long(1000); - end; - end; -{$endif} - -end; - -end. +unit imjmemmgr; + +{ This file contains the JPEG system-independent memory management + routines. This code is usable across a wide variety of machines; most + of the system dependencies have been isolated in a separate file. + The major functions provided here are: + * pool-based allocation and freeing of memory; + * policy decisions about how to divide available memory among the + virtual arrays; + * control logic for swapping virtual arrays between main memory and + backing storage. + The separate system-dependent file provides the actual backing-storage + access code, and it contains the policy decision about how much total + main memory to use. + This file is system-dependent in the sense that some of its functions + are unnecessary in some systems. For example, if there is enough virtual + memory so that backing storage will never be used, much of the virtual + array control logic could be removed. (Of course, if you have that much + memory then you shouldn't care about a little bit of unused code...) } + +{ Original : jmemmgr.c ; Copyright (C) 1991-1997, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjdeferr, + imjerror, + imjpeglib, + imjutils, +{$IFDEF VER70} +{$ifndef NO_GETENV} + Dos, { DOS unit should declare getenv() } + { function GetEnv(name : string) : string; } +{$endif} + imjmemdos; { import the system-dependent declarations } +{$ELSE} + imjmemnobs; + {$DEFINE NO_GETENV} +{$ENDIF} + +{ Memory manager initialization. + When this is called, only the error manager pointer is valid in cinfo! } + +{GLOBAL} +procedure jinit_memory_mgr (cinfo : j_common_ptr); + +implementation + + +{ Some important notes: + The allocation routines provided here must never return NIL. + They should exit to error_exit if unsuccessful. + + It's not a good idea to try to merge the sarray and barray routines, + even though they are textually almost the same, because samples are + usually stored as bytes while coefficients are shorts or ints. Thus, + in machines where byte pointers have a different representation from + word pointers, the resulting machine code could not be the same. } + + +{ Many machines require storage alignment: longs must start on 4-byte + boundaries, doubles on 8-byte boundaries, etc. On such machines, malloc() + always returns pointers that are multiples of the worst-case alignment + requirement, and we had better do so too. + There isn't any really portable way to determine the worst-case alignment + requirement. This module assumes that the alignment requirement is + multiples of sizeof(ALIGN_TYPE). + By default, we define ALIGN_TYPE as double. This is necessary on some + workstations (where doubles really do need 8-byte alignment) and will work + fine on nearly everything. If your machine has lesser alignment needs, + you can save a few bytes by making ALIGN_TYPE smaller. + The only place I know of where this will NOT work is certain Macintosh + 680x0 compilers that define double as a 10-byte IEEE extended float. + Doing 10-byte alignment is counterproductive because longwords won't be + aligned well. Put "#define ALIGN_TYPE long" in jconfig.h if you have + such a compiler. } + +{$ifndef ALIGN_TYPE} { so can override from jconfig.h } +type + ALIGN_TYPE = double; +{$endif} + + +{ We allocate objects from "pools", where each pool is gotten with a single + request to jpeg_get_small() or jpeg_get_large(). There is no per-object + overhead within a pool, except for alignment padding. Each pool has a + header with a link to the next pool of the same class. + Small and large pool headers are identical except that the latter's + link pointer must be FAR on 80x86 machines. + Notice that the "real" header fields are union'ed with a dummy ALIGN_TYPE + field. This forces the compiler to make SIZEOF(small_pool_hdr) a multiple + of the alignment requirement of ALIGN_TYPE. } + +type + small_pool_ptr = ^small_pool_hdr; + small_pool_hdr = record + case byte of + 0:(hdr : record + next : small_pool_ptr; { next in list of pools } + bytes_used : size_t; { how many bytes already used within pool } + bytes_left : size_t; { bytes still available in this pool } + end); + 1:(dummy : ALIGN_TYPE); { included in union to ensure alignment } + end; {small_pool_hdr;} + +type + large_pool_ptr = ^large_pool_hdr; {FAR} + large_pool_hdr = record + case byte of + 0:(hdr : record + next : large_pool_ptr; { next in list of pools } + bytes_used : size_t; { how many bytes already used within pool } + bytes_left : size_t; { bytes still available in this pool } + end); + 1:(dummy : ALIGN_TYPE); { included in union to ensure alignment } + end; {large_pool_hdr;} + + +{ Here is the full definition of a memory manager object. } + +type + my_mem_ptr = ^my_memory_mgr; + my_memory_mgr = record + pub : jpeg_memory_mgr; { public fields } + + { Each pool identifier (lifetime class) names a linked list of pools. } + small_list : array[0..JPOOL_NUMPOOLS-1] of small_pool_ptr ; + large_list : array[0..JPOOL_NUMPOOLS-1] of large_pool_ptr ; + + { Since we only have one lifetime class of virtual arrays, only one + linked list is necessary (for each datatype). Note that the virtual + array control blocks being linked together are actually stored somewhere + in the small-pool list. } + + virt_sarray_list : jvirt_sarray_ptr; + virt_barray_list : jvirt_barray_ptr; + + { This counts total space obtained from jpeg_get_small/large } + total_space_allocated : long; + + { alloc_sarray and alloc_barray set this value for use by virtual + array routines. } + + last_rowsperchunk : JDIMENSION; { from most recent alloc_sarray/barray } + end; {my_memory_mgr;} + + {$ifndef AM_MEMORY_MANAGER} { only jmemmgr.c defines these } + +{ The control blocks for virtual arrays. + Note that these blocks are allocated in the "small" pool area. + System-dependent info for the associated backing store (if any) is hidden + inside the backing_store_info struct. } +type + jvirt_sarray_control = record + mem_buffer : JSAMPARRAY; { => the in-memory buffer } + rows_in_array : JDIMENSION; { total virtual array height } + samplesperrow : JDIMENSION; { width of array (and of memory buffer) } + maxaccess : JDIMENSION; { max rows accessed by access_virt_sarray } + rows_in_mem : JDIMENSION; { height of memory buffer } + rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer } + cur_start_row : JDIMENSION; { first logical row # in the buffer } + first_undef_row : JDIMENSION; { row # of first uninitialized row } + pre_zero : boolean; { pre-zero mode requested? } + dirty : boolean; { do current buffer contents need written? } + b_s_open : boolean; { is backing-store data valid? } + next : jvirt_sarray_ptr; { link to next virtual sarray control block } + b_s_info : backing_store_info; { System-dependent control info } + end; + + jvirt_barray_control = record + mem_buffer : JBLOCKARRAY; { => the in-memory buffer } + rows_in_array : JDIMENSION; { total virtual array height } + blocksperrow : JDIMENSION; { width of array (and of memory buffer) } + maxaccess : JDIMENSION; { max rows accessed by access_virt_barray } + rows_in_mem : JDIMENSION; { height of memory buffer } + rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer } + cur_start_row : JDIMENSION; { first logical row # in the buffer } + first_undef_row : JDIMENSION; { row # of first uninitialized row } + pre_zero : boolean; { pre-zero mode requested? } + dirty : boolean; { do current buffer contents need written? } + b_s_open : boolean; { is backing-store data valid? } + next : jvirt_barray_ptr; { link to next virtual barray control block } + b_s_info : backing_store_info; { System-dependent control info } + end; + {$endif} { AM_MEMORY_MANAGER} + +{$ifdef MEM_STATS} { optional extra stuff for statistics } + +{LOCAL} +procedure print_mem_stats (cinfo : j_common_ptr; pool_id : int); +var + mem : my_mem_ptr; + shdr_ptr : small_pool_ptr; + lhdr_ptr : large_pool_ptr; +begin + mem := my_mem_ptr (cinfo^.mem); + + { Since this is only a debugging stub, we can cheat a little by using + fprintf directly rather than going through the trace message code. + This is helpful because message parm array can't handle longs. } + + WriteLn(output, 'Freeing pool ', pool_id,', total space := ', + mem^.total_space_allocated); + + lhdr_ptr := mem^.large_list[pool_id]; + while (lhdr_ptr <> NIL) do + begin + WriteLn(output, ' Large chunk used ', + long (lhdr_ptr^.hdr.bytes_used)); + lhdr_ptr := lhdr_ptr^.hdr.next; + end; + + shdr_ptr := mem^.small_list[pool_id]; + + while (shdr_ptr <> NIL) do + begin + WriteLn(output, ' Small chunk used ', + long (shdr_ptr^.hdr.bytes_used), ' free ', + long (shdr_ptr^.hdr.bytes_left) ); + shdr_ptr := shdr_ptr^.hdr.next; + end; +end; + +{$endif} { MEM_STATS } + + +{LOCAL} +procedure out_of_memory (cinfo : j_common_ptr; which : int); +{ Report an out-of-memory error and stop execution } +{ If we compiled MEM_STATS support, report alloc requests before dying } +begin +{$ifdef MEM_STATS} + cinfo^.err^.trace_level := 2; { force self_destruct to report stats } +{$endif} + ERREXIT1(cinfo, JERR_OUT_OF_MEMORY, which); +end; + + +{ Allocation of "small" objects. + + For these, we use pooled storage. When a new pool must be created, + we try to get enough space for the current request plus a "slop" factor, + where the slop will be the amount of leftover space in the new pool. + The speed vs. space tradeoff is largely determined by the slop values. + A different slop value is provided for each pool class (lifetime), + and we also distinguish the first pool of a class from later ones. + NOTE: the values given work fairly well on both 16- and 32-bit-int + machines, but may be too small if longs are 64 bits or more. } + +const + first_pool_slop : array[0..JPOOL_NUMPOOLS-1] of size_t = + (1600, { first PERMANENT pool } + 16000); { first IMAGE pool } + +const + extra_pool_slop : array[0..JPOOL_NUMPOOLS-1] of size_t = + (0, { additional PERMANENT pools } + 5000); { additional IMAGE pools } + +const + MIN_SLOP = 50; { greater than 0 to avoid futile looping } + + +{METHODDEF} +function alloc_small (cinfo : j_common_ptr; + pool_id : int; + sizeofobject : size_t) : pointer; +type + byteptr = ^byte; +{ Allocate a "small" object } +var + mem : my_mem_ptr; + hdr_ptr, prev_hdr_ptr : small_pool_ptr; + data_ptr : byteptr; + odd_bytes, min_request, slop : size_t; +begin + mem := my_mem_ptr (cinfo^.mem); + + { Check for unsatisfiable request (do now to ensure no overflow below) } + if (sizeofobject > size_t(MAX_ALLOC_CHUNK-SIZEOF(small_pool_hdr))) then + out_of_memory(cinfo, 1); { request exceeds malloc's ability } + + { Round up the requested size to a multiple of SIZEOF(ALIGN_TYPE) } + odd_bytes := sizeofobject mod SIZEOF(ALIGN_TYPE); + if (odd_bytes > 0) then + Inc(sizeofobject, SIZEOF(ALIGN_TYPE) - odd_bytes); + + { See if space is available in any existing pool } + if (pool_id < 0) or (pool_id >= JPOOL_NUMPOOLS) then + ERREXIT1(j_common_ptr(cinfo), JERR_BAD_POOL_ID, pool_id); { safety check } + prev_hdr_ptr := NIL; + hdr_ptr := mem^.small_list[pool_id]; + while (hdr_ptr <> NIL) do + begin + if (hdr_ptr^.hdr.bytes_left >= sizeofobject) then + break; { found pool with enough space } + prev_hdr_ptr := hdr_ptr; + hdr_ptr := hdr_ptr^.hdr.next; + end; + + { Time to make a new pool? } + if (hdr_ptr = NIL) then + begin + { min_request is what we need now, slop is what will be leftover } + min_request := sizeofobject + SIZEOF(small_pool_hdr); + if (prev_hdr_ptr = NIL) then { first pool in class? } + slop := first_pool_slop[pool_id] + else + slop := extra_pool_slop[pool_id]; + { Don't ask for more than MAX_ALLOC_CHUNK } + if (slop > size_t (MAX_ALLOC_CHUNK-min_request)) then + slop := size_t (MAX_ALLOC_CHUNK-min_request); + { Try to get space, if fail reduce slop and try again } + while TRUE do + begin + hdr_ptr := small_pool_ptr(jpeg_get_small(cinfo, min_request + slop)); + if (hdr_ptr <> NIL) then + break; + slop := slop div 2; + if (slop < MIN_SLOP) then { give up when it gets real small } + out_of_memory(cinfo, 2); { jpeg_get_small failed } + end; + Inc(mem^.total_space_allocated, min_request + slop); + { Success, initialize the new pool header and add to end of list } + hdr_ptr^.hdr.next := NIL; + hdr_ptr^.hdr.bytes_used := 0; + hdr_ptr^.hdr.bytes_left := sizeofobject + slop; + if (prev_hdr_ptr = NIL) then { first pool in class? } + mem^.small_list[pool_id] := hdr_ptr + else + prev_hdr_ptr^.hdr.next := hdr_ptr; + end; + + { OK, allocate the object from the current pool } + data_ptr := byteptr (hdr_ptr); + Inc(small_pool_ptr(data_ptr)); { point to first data byte in pool } + Inc(data_ptr, hdr_ptr^.hdr.bytes_used); { point to place for object } + Inc(hdr_ptr^.hdr.bytes_used, sizeofobject); + Dec(hdr_ptr^.hdr.bytes_left, sizeofobject); + + alloc_small := pointer(data_ptr); +end; + + +{ Allocation of "large" objects. + + The external semantics of these are the same as "small" objects, + except that FAR pointers are used on 80x86. However the pool + management heuristics are quite different. We assume that each + request is large enough that it may as well be passed directly to + jpeg_get_large; the pool management just links everything together + so that we can free it all on demand. + Note: the major use of "large" objects is in JSAMPARRAY and JBLOCKARRAY + structures. The routines that create these structures (see below) + deliberately bunch rows together to ensure a large request size. } + +{METHODDEF} +function alloc_large (cinfo : j_common_ptr; + pool_id : int; + sizeofobject : size_t) : pointer; +{ Allocate a "large" object } +var + mem : my_mem_ptr; + hdr_ptr : large_pool_ptr; + odd_bytes : size_t; +var + dest_ptr : large_pool_ptr; +begin + mem := my_mem_ptr (cinfo^.mem); + + { Check for unsatisfiable request (do now to ensure no overflow below) } + if (sizeofobject > size_t (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr))) then + out_of_memory(cinfo, 3); { request exceeds malloc's ability } + + { Round up the requested size to a multiple of SIZEOF(ALIGN_TYPE) } + odd_bytes := sizeofobject mod SIZEOF(ALIGN_TYPE); + if (odd_bytes > 0) then + Inc(sizeofobject, SIZEOF(ALIGN_TYPE) - odd_bytes); + + { Always make a new pool } + if (pool_id < 0) or (pool_id >= JPOOL_NUMPOOLS) then + ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check } + + hdr_ptr := large_pool_ptr (jpeg_get_large(cinfo, sizeofobject + + SIZEOF(large_pool_hdr))); + if (hdr_ptr = NIL) then + out_of_memory(cinfo, 4); { jpeg_get_large failed } + Inc(mem^.total_space_allocated, sizeofobject + SIZEOF(large_pool_hdr)); + + { Success, initialize the new pool header and add to list } + hdr_ptr^.hdr.next := mem^.large_list[pool_id]; + { We maintain space counts in each pool header for statistical purposes, + even though they are not needed for allocation. } + + hdr_ptr^.hdr.bytes_used := sizeofobject; + hdr_ptr^.hdr.bytes_left := 0; + mem^.large_list[pool_id] := hdr_ptr; + + {alloc_large := pointerFAR (hdr_ptr + 1); - point to first data byte in pool } + dest_ptr := hdr_ptr; + Inc(large_pool_ptr(dest_ptr)); + alloc_large := dest_ptr; +end; + + +{ Creation of 2-D sample arrays. + The pointers are in near heap, the samples themselves in FAR heap. + + To minimize allocation overhead and to allow I/O of large contiguous + blocks, we allocate the sample rows in groups of as many rows as possible + without exceeding MAX_ALLOC_CHUNK total bytes per allocation request. + NB: the virtual array control routines, later in this file, know about + this chunking of rows. The rowsperchunk value is left in the mem manager + object so that it can be saved away if this sarray is the workspace for + a virtual array. } + +{METHODDEF} +function alloc_sarray (cinfo : j_common_ptr; + pool_id : int; + samplesperrow : JDIMENSION; + numrows : JDIMENSION) : JSAMPARRAY; +{ Allocate a 2-D sample array } +var + mem : my_mem_ptr; + the_result : JSAMPARRAY; + workspace : JSAMPROW; + rowsperchunk, currow, i : JDIMENSION; + ltemp : long; +begin + mem := my_mem_ptr(cinfo^.mem); + + { Calculate max # of rows allowed in one allocation chunk } + ltemp := (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr)) div + (long(samplesperrow) * SIZEOF(JSAMPLE)); + if (ltemp <= 0) then + ERREXIT(cinfo, JERR_WIDTH_OVERFLOW); + if (ltemp < long(numrows)) then + rowsperchunk := JDIMENSION (ltemp) + else + rowsperchunk := numrows; + mem^.last_rowsperchunk := rowsperchunk; + + { Get space for row pointers (small object) } + the_result := JSAMPARRAY (alloc_small(cinfo, pool_id, + size_t (numrows * SIZEOF(JSAMPROW)))); + + { Get the rows themselves (large objects) } + currow := 0; + while (currow < numrows) do + begin + {rowsperchunk := MIN(rowsperchunk, numrows - currow);} + if rowsperchunk > numrows - currow then + rowsperchunk := numrows - currow; + + workspace := JSAMPROW (alloc_large(cinfo, pool_id, + size_t (size_t(rowsperchunk) * size_t(samplesperrow) + * SIZEOF(JSAMPLE))) ); + for i := pred(rowsperchunk) downto 0 do + begin + the_result^[currow] := workspace; + Inc(currow); + Inc(JSAMPLE_PTR(workspace), samplesperrow); + end; + end; + + alloc_sarray := the_result; +end; + + +{ Creation of 2-D coefficient-block arrays. + This is essentially the same as the code for sample arrays, above. } + +{METHODDEF} +function alloc_barray (cinfo : j_common_ptr; + pool_id : int; + blocksperrow : JDIMENSION; + numrows : JDIMENSION) : JBLOCKARRAY; +{ Allocate a 2-D coefficient-block array } +var + mem : my_mem_ptr; + the_result : JBLOCKARRAY; + workspace : JBLOCKROW; + rowsperchunk, currow, i : JDIMENSION; + ltemp : long; +begin + mem := my_mem_ptr(cinfo^.mem); + + { Calculate max # of rows allowed in one allocation chunk } + ltemp := (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr)) div + (long(blocksperrow) * SIZEOF(JBLOCK)); + + if (ltemp <= 0) then + ERREXIT(cinfo, JERR_WIDTH_OVERFLOW); + if (ltemp < long(numrows)) then + rowsperchunk := JDIMENSION (ltemp) + else + rowsperchunk := numrows; + mem^.last_rowsperchunk := rowsperchunk; + + { Get space for row pointers (small object) } + the_result := JBLOCKARRAY (alloc_small(cinfo, pool_id, + size_t (numrows * SIZEOF(JBLOCKROW))) ); + + { Get the rows themselves (large objects) } + currow := 0; + while (currow < numrows) do + begin + {rowsperchunk := MIN(rowsperchunk, numrows - currow);} + if rowsperchunk > numrows - currow then + rowsperchunk := numrows - currow; + + workspace := JBLOCKROW (alloc_large(cinfo, pool_id, + size_t (size_t(rowsperchunk) * size_t(blocksperrow) + * SIZEOF(JBLOCK))) ); + for i := rowsperchunk downto 1 do + begin + the_result^[currow] := workspace; + Inc(currow); + Inc(JBLOCK_PTR(workspace), blocksperrow); + end; + end; + + alloc_barray := the_result; +end; + + +{ About virtual array management: + + The above "normal" array routines are only used to allocate strip buffers + (as wide as the image, but just a few rows high). Full-image-sized buffers + are handled as "virtual" arrays. The array is still accessed a strip at a + time, but the memory manager must save the whole array for repeated + accesses. The intended implementation is that there is a strip buffer in + memory (as high as is possible given the desired memory limit), plus a + backing file that holds the rest of the array. + + The request_virt_array routines are told the total size of the image and + the maximum number of rows that will be accessed at once. The in-memory + buffer must be at least as large as the maxaccess value. + + The request routines create control blocks but not the in-memory buffers. + That is postponed until realize_virt_arrays is called. At that time the + total amount of space needed is known (approximately, anyway), so free + memory can be divided up fairly. + + The access_virt_array routines are responsible for making a specific strip + area accessible (after reading or writing the backing file, if necessary). + Note that the access routines are told whether the caller intends to modify + the accessed strip; during a read-only pass this saves having to rewrite + data to disk. The access routines are also responsible for pre-zeroing + any newly accessed rows, if pre-zeroing was requested. + + In current usage, the access requests are usually for nonoverlapping + strips; that is, successive access start_row numbers differ by exactly + num_rows := maxaccess. This means we can get good performance with simple + buffer dump/reload logic, by making the in-memory buffer be a multiple + of the access height; then there will never be accesses across bufferload + boundaries. The code will still work with overlapping access requests, + but it doesn't handle bufferload overlaps very efficiently. } + + +{METHODDEF} +function request_virt_sarray (cinfo : j_common_ptr; + pool_id : int; + pre_zero : boolean; + samplesperrow : JDIMENSION; + numrows : JDIMENSION; + maxaccess : JDIMENSION) : jvirt_sarray_ptr; +{ Request a virtual 2-D sample array } +var + mem : my_mem_ptr; + the_result : jvirt_sarray_ptr; +begin + mem := my_mem_ptr (cinfo^.mem); + + { Only IMAGE-lifetime virtual arrays are currently supported } + if (pool_id <> JPOOL_IMAGE) then + ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check } + + { get control block } + the_result := jvirt_sarray_ptr (alloc_small(cinfo, pool_id, + SIZEOF(jvirt_sarray_control)) ); + + the_result^.mem_buffer := NIL; { marks array not yet realized } + the_result^.rows_in_array := numrows; + the_result^.samplesperrow := samplesperrow; + the_result^.maxaccess := maxaccess; + the_result^.pre_zero := pre_zero; + the_result^.b_s_open := FALSE; { no associated backing-store object } + the_result^.next := mem^.virt_sarray_list; { add to list of virtual arrays } + mem^.virt_sarray_list := the_result; + + request_virt_sarray := the_result; +end; + + +{METHODDEF} +function request_virt_barray (cinfo : j_common_ptr; + pool_id : int; + pre_zero : boolean; + blocksperrow : JDIMENSION; + numrows : JDIMENSION; + maxaccess : JDIMENSION) : jvirt_barray_ptr; +{ Request a virtual 2-D coefficient-block array } +var + mem : my_mem_ptr; + the_result : jvirt_barray_ptr; +begin + mem := my_mem_ptr(cinfo^.mem); + + { Only IMAGE-lifetime virtual arrays are currently supported } + if (pool_id <> JPOOL_IMAGE) then + ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check } + + { get control block } + the_result := jvirt_barray_ptr(alloc_small(cinfo, pool_id, + SIZEOF(jvirt_barray_control)) ); + + the_result^.mem_buffer := NIL; { marks array not yet realized } + the_result^.rows_in_array := numrows; + the_result^.blocksperrow := blocksperrow; + the_result^.maxaccess := maxaccess; + the_result^.pre_zero := pre_zero; + the_result^.b_s_open := FALSE; { no associated backing-store object } + the_result^.next := mem^.virt_barray_list; { add to list of virtual arrays } + mem^.virt_barray_list := the_result; + + request_virt_barray := the_result; +end; + + +{METHODDEF} +procedure realize_virt_arrays (cinfo : j_common_ptr); +{ Allocate the in-memory buffers for any unrealized virtual arrays } +var + mem : my_mem_ptr; + space_per_minheight, maximum_space, avail_mem : long; + minheights, max_minheights : long; + sptr : jvirt_sarray_ptr; + bptr : jvirt_barray_ptr; +begin + mem := my_mem_ptr (cinfo^.mem); + { Compute the minimum space needed (maxaccess rows in each buffer) + and the maximum space needed (full image height in each buffer). + These may be of use to the system-dependent jpeg_mem_available routine. } + + space_per_minheight := 0; + maximum_space := 0; + sptr := mem^.virt_sarray_list; + while (sptr <> NIL) do + begin + if (sptr^.mem_buffer = NIL) then + begin { if not realized yet } + Inc(space_per_minheight, long(sptr^.maxaccess) * + long(sptr^.samplesperrow) * SIZEOF(JSAMPLE)); + Inc(maximum_space, long(sptr^.rows_in_array) * + long(sptr^.samplesperrow) * SIZEOF(JSAMPLE)); + end; + sptr := sptr^.next; + end; + bptr := mem^.virt_barray_list; + while (bptr <> NIL) do + begin + if (bptr^.mem_buffer = NIL) then + begin { if not realized yet } + Inc(space_per_minheight, long(bptr^.maxaccess) * + long(bptr^.blocksperrow) * SIZEOF(JBLOCK)); + Inc(maximum_space, long(bptr^.rows_in_array) * + long(bptr^.blocksperrow) * SIZEOF(JBLOCK)); + end; + bptr := bptr^.next; + end; + + if (space_per_minheight <= 0) then + exit; { no unrealized arrays, no work } + + { Determine amount of memory to actually use; this is system-dependent. } + avail_mem := jpeg_mem_available(cinfo, space_per_minheight, maximum_space, + mem^.total_space_allocated); + + { If the maximum space needed is available, make all the buffers full + height; otherwise parcel it out with the same number of minheights + in each buffer. } + + if (avail_mem >= maximum_space) then + max_minheights := long(1000000000) + else + begin + max_minheights := avail_mem div space_per_minheight; + { If there doesn't seem to be enough space, try to get the minimum + anyway. This allows a "stub" implementation of jpeg_mem_available(). } + if (max_minheights <= 0) then + max_minheights := 1; + end; + + { Allocate the in-memory buffers and initialize backing store as needed. } + + sptr := mem^.virt_sarray_list; + while (sptr <> NIL) do + begin + if (sptr^.mem_buffer = NIL) then + begin { if not realized yet } + minheights := (long(sptr^.rows_in_array) - long(1)) div LongInt(sptr^.maxaccess) + long(1); + if (minheights <= max_minheights) then + begin + { This buffer fits in memory } + sptr^.rows_in_mem := sptr^.rows_in_array; + end + else + begin + { It doesn't fit in memory, create backing store. } + sptr^.rows_in_mem := JDIMENSION(max_minheights) * sptr^.maxaccess; + jpeg_open_backing_store(cinfo, + @sptr^.b_s_info, + long(sptr^.rows_in_array) * + long(sptr^.samplesperrow) * + long(SIZEOF(JSAMPLE))); + sptr^.b_s_open := TRUE; + end; + sptr^.mem_buffer := alloc_sarray(cinfo, JPOOL_IMAGE, + sptr^.samplesperrow, sptr^.rows_in_mem); + sptr^.rowsperchunk := mem^.last_rowsperchunk; + sptr^.cur_start_row := 0; + sptr^.first_undef_row := 0; + sptr^.dirty := FALSE; + end; + sptr := sptr^.next; + end; + + bptr := mem^.virt_barray_list; + while (bptr <> NIL) do + begin + if (bptr^.mem_buffer = NIL) then + begin { if not realized yet } + minheights := (long(bptr^.rows_in_array) - long(1)) div LongInt(bptr^.maxaccess) + long(1); + if (minheights <= max_minheights) then + begin + { This buffer fits in memory } + bptr^.rows_in_mem := bptr^.rows_in_array; + end + else + begin + { It doesn't fit in memory, create backing store. } + bptr^.rows_in_mem := JDIMENSION (max_minheights) * bptr^.maxaccess; + jpeg_open_backing_store(cinfo, + @bptr^.b_s_info, + long(bptr^.rows_in_array) * + long(bptr^.blocksperrow) * + long(SIZEOF(JBLOCK))); + bptr^.b_s_open := TRUE; + end; + bptr^.mem_buffer := alloc_barray(cinfo, JPOOL_IMAGE, + bptr^.blocksperrow, bptr^.rows_in_mem); + bptr^.rowsperchunk := mem^.last_rowsperchunk; + bptr^.cur_start_row := 0; + bptr^.first_undef_row := 0; + bptr^.dirty := FALSE; + end; + bptr := bptr^.next; + end; +end; + + +{LOCAL} +procedure do_sarray_io (cinfo : j_common_ptr; + ptr : jvirt_sarray_ptr; + writing : boolean); +{ Do backing store read or write of a virtual sample array } +var + bytesperrow, file_offset, byte_count, rows, thisrow, i : long; +begin + + bytesperrow := long(ptr^.samplesperrow * SIZEOF(JSAMPLE)); + file_offset := LongInt(ptr^.cur_start_row) * bytesperrow; + { Loop to read or write each allocation chunk in mem_buffer } + i := 0; + while i < long(ptr^.rows_in_mem) do + begin + + { One chunk, but check for short chunk at end of buffer } + {rows := MIN(long(ptr^.rowsperchunk), long(ptr^.rows_in_mem - i));} + rows := long(ptr^.rowsperchunk); + if rows > long(ptr^.rows_in_mem) - i then + rows := long(ptr^.rows_in_mem) - i; + { Transfer no more than is currently defined } + thisrow := long (ptr^.cur_start_row) + i; + {rows := MIN(rows, long(ptr^.first_undef_row) - thisrow);} + if (rows > long(ptr^.first_undef_row) - thisrow) then + rows := long(ptr^.first_undef_row) - thisrow; + { Transfer no more than fits in file } + {rows := MIN(rows, long(ptr^.rows_in_array) - thisrow);} + if (rows > long(ptr^.rows_in_array) - thisrow) then + rows := long(ptr^.rows_in_array) - thisrow; + + if (rows <= 0) then { this chunk might be past end of file! } + break; + byte_count := rows * bytesperrow; + if (writing) then + ptr^.b_s_info.write_backing_store (cinfo, + @ptr^.b_s_info, + pointer {FAR} (ptr^.mem_buffer^[i]), + file_offset, byte_count) + else + ptr^.b_s_info.read_backing_store (cinfo, + @ptr^.b_s_info, + pointer {FAR} (ptr^.mem_buffer^[i]), + file_offset, byte_count); + Inc(file_offset, byte_count); + Inc(i, ptr^.rowsperchunk); + end; +end; + + +{LOCAL} +procedure do_barray_io (cinfo : j_common_ptr; + ptr : jvirt_barray_ptr; + writing : boolean); +{ Do backing store read or write of a virtual coefficient-block array } +var + bytesperrow, file_offset, byte_count, rows, thisrow, i : long; +begin + bytesperrow := long (ptr^.blocksperrow) * SIZEOF(JBLOCK); + file_offset := LongInt(ptr^.cur_start_row) * bytesperrow; + { Loop to read or write each allocation chunk in mem_buffer } + i := 0; + while (i < long(ptr^.rows_in_mem)) do + begin + { One chunk, but check for short chunk at end of buffer } + {rows := MIN(long(ptr^.rowsperchunk), long(ptr^.rows_in_mem - i));} + rows := long(ptr^.rowsperchunk); + if rows > long(ptr^.rows_in_mem) - i then + rows := long(ptr^.rows_in_mem) - i; + { Transfer no more than is currently defined } + thisrow := long (ptr^.cur_start_row) + i; + {rows := MIN(rows, long(ptr^.first_undef_row - thisrow));} + if rows > long(ptr^.first_undef_row) - thisrow then + rows := long(ptr^.first_undef_row) - thisrow; + { Transfer no more than fits in file } + {rows := MIN(rows, long (ptr^.rows_in_array - thisrow));} + if (rows > long (ptr^.rows_in_array) - thisrow) then + rows := long (ptr^.rows_in_array) - thisrow; + + if (rows <= 0) then { this chunk might be past end of file! } + break; + byte_count := rows * bytesperrow; + if (writing) then + ptr^.b_s_info.write_backing_store (cinfo, + @ptr^.b_s_info, + {FAR} pointer(ptr^.mem_buffer^[i]), + file_offset, byte_count) + else + ptr^.b_s_info.read_backing_store (cinfo, + @ptr^.b_s_info, + {FAR} pointer(ptr^.mem_buffer^[i]), + file_offset, byte_count); + Inc(file_offset, byte_count); + Inc(i, ptr^.rowsperchunk); + end; +end; + + +{METHODDEF} +function access_virt_sarray (cinfo : j_common_ptr; + ptr : jvirt_sarray_ptr; + start_row : JDIMENSION; + num_rows : JDIMENSION; + writable : boolean ) : JSAMPARRAY; +{ Access the part of a virtual sample array starting at start_row } +{ and extending for num_rows rows. writable is true if } +{ caller intends to modify the accessed area. } +var + end_row : JDIMENSION; + undef_row : JDIMENSION; +var + bytesperrow : size_t; +var + ltemp : long; +begin + end_row := start_row + num_rows; + { debugging check } + if (end_row > ptr^.rows_in_array) or (num_rows > ptr^.maxaccess) or + (ptr^.mem_buffer = NIL) then + ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); + + { Make the desired part of the virtual array accessible } + if (start_row < ptr^.cur_start_row) or + (end_row > ptr^.cur_start_row+ptr^.rows_in_mem) then + begin + if (not ptr^.b_s_open) then + ERREXIT(cinfo, JERR_VIRTUAL_BUG); + { Flush old buffer contents if necessary } + if (ptr^.dirty) then + begin + do_sarray_io(cinfo, ptr, TRUE); + ptr^.dirty := FALSE; + end; + { Decide what part of virtual array to access. + Algorithm: if target address > current window, assume forward scan, + load starting at target address. If target address < current window, + assume backward scan, load so that target area is top of window. + Note that when switching from forward write to forward read, will have + start_row := 0, so the limiting case applies and we load from 0 anyway. } + if (start_row > ptr^.cur_start_row) then + begin + ptr^.cur_start_row := start_row; + end + else + begin + { use long arithmetic here to avoid overflow & unsigned problems } + + + ltemp := long(end_row) - long(ptr^.rows_in_mem); + if (ltemp < 0) then + ltemp := 0; { don't fall off front end of file } + ptr^.cur_start_row := JDIMENSION(ltemp); + end; + { Read in the selected part of the array. + During the initial write pass, we will do no actual read + because the selected part is all undefined. } + + do_sarray_io(cinfo, ptr, FALSE); + end; + { Ensure the accessed part of the array is defined; prezero if needed. + To improve locality of access, we only prezero the part of the array + that the caller is about to access, not the entire in-memory array. } + if (ptr^.first_undef_row < end_row) then + begin + if (ptr^.first_undef_row < start_row) then + begin + if (writable) then { writer skipped over a section of array } + ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); + undef_row := start_row; { but reader is allowed to read ahead } + end + else + begin + undef_row := ptr^.first_undef_row; + end; + if (writable) then + ptr^.first_undef_row := end_row; + if (ptr^.pre_zero) then + begin + bytesperrow := size_t(ptr^.samplesperrow) * SIZEOF(JSAMPLE); + Dec(undef_row, ptr^.cur_start_row); { make indexes relative to buffer } + Dec(end_row, ptr^.cur_start_row); + while (undef_row < end_row) do + begin + jzero_far({FAR} pointer(ptr^.mem_buffer^[undef_row]), bytesperrow); + Inc(undef_row); + end; + end + else + begin + if (not writable) then { reader looking at undefined data } + ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); + end; + end; + { Flag the buffer dirty if caller will write in it } + if (writable) then + ptr^.dirty := TRUE; + { Return address of proper part of the buffer } + access_virt_sarray := JSAMPARRAY(@ ptr^.mem_buffer^[start_row - ptr^.cur_start_row]); +end; + + +{METHODDEF} +function access_virt_barray (cinfo : j_common_ptr; + ptr : jvirt_barray_ptr; + start_row : JDIMENSION; + num_rows : JDIMENSION; + writable : boolean) : JBLOCKARRAY; +{ Access the part of a virtual block array starting at start_row } +{ and extending for num_rows rows. writable is true if } +{ caller intends to modify the accessed area. } +var + end_row : JDIMENSION; + undef_row : JDIMENSION; + ltemp : long; +var + bytesperrow : size_t; +begin + end_row := start_row + num_rows; + + { debugging check } + if (end_row > ptr^.rows_in_array) or (num_rows > ptr^.maxaccess) or + (ptr^.mem_buffer = NIL) then + ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); + + { Make the desired part of the virtual array accessible } + if (start_row < ptr^.cur_start_row) or + (end_row > ptr^.cur_start_row+ptr^.rows_in_mem) then + begin + if (not ptr^.b_s_open) then + ERREXIT(cinfo, JERR_VIRTUAL_BUG); + { Flush old buffer contents if necessary } + if (ptr^.dirty) then + begin + do_barray_io(cinfo, ptr, TRUE); + ptr^.dirty := FALSE; + end; + { Decide what part of virtual array to access. + Algorithm: if target address > current window, assume forward scan, + load starting at target address. If target address < current window, + assume backward scan, load so that target area is top of window. + Note that when switching from forward write to forward read, will have + start_row := 0, so the limiting case applies and we load from 0 anyway. } + + if (start_row > ptr^.cur_start_row) then + begin + ptr^.cur_start_row := start_row; + end + else + begin + { use long arithmetic here to avoid overflow & unsigned problems } + + ltemp := long(end_row) - long(ptr^.rows_in_mem); + if (ltemp < 0) then + ltemp := 0; { don't fall off front end of file } + ptr^.cur_start_row := JDIMENSION (ltemp); + end; + { Read in the selected part of the array. + During the initial write pass, we will do no actual read + because the selected part is all undefined. } + + do_barray_io(cinfo, ptr, FALSE); + end; + { Ensure the accessed part of the array is defined; prezero if needed. + To improve locality of access, we only prezero the part of the array + that the caller is about to access, not the entire in-memory array. } + + if (ptr^.first_undef_row < end_row) then + begin + if (ptr^.first_undef_row < start_row) then + begin + if (writable) then { writer skipped over a section of array } + ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); + undef_row := start_row; { but reader is allowed to read ahead } + end + else + begin + undef_row := ptr^.first_undef_row; + end; + if (writable) then + ptr^.first_undef_row := end_row; + if (ptr^.pre_zero) then + begin + bytesperrow := size_t (ptr^.blocksperrow) * SIZEOF(JBLOCK); + Dec(undef_row, ptr^.cur_start_row); { make indexes relative to buffer } + Dec(end_row, ptr^.cur_start_row); + while (undef_row < end_row) do + begin + jzero_far({FAR}pointer(ptr^.mem_buffer^[undef_row]), bytesperrow); + Inc(undef_row); + end; + end + else + begin + if (not writable) then { reader looking at undefined data } + ERREXIT(cinfo, JERR_BAD_VIRTUAL_ACCESS); + end; + end; + { Flag the buffer dirty if caller will write in it } + if (writable) then + ptr^.dirty := TRUE; + { Return address of proper part of the buffer } + access_virt_barray := JBLOCKARRAY(@ ptr^.mem_buffer^[start_row - ptr^.cur_start_row]); +end; + + +{ Release all objects belonging to a specified pool. } + +{METHODDEF} +procedure free_pool (cinfo : j_common_ptr; pool_id : int); +var + mem : my_mem_ptr; + shdr_ptr : small_pool_ptr; + lhdr_ptr : large_pool_ptr; + space_freed : size_t; +var + sptr : jvirt_sarray_ptr; + bptr : jvirt_barray_ptr; +var + next_lhdr_ptr : large_pool_ptr; + next_shdr_ptr : small_pool_ptr; +begin + mem := my_mem_ptr(cinfo^.mem); + + if (pool_id < 0) or (pool_id >= JPOOL_NUMPOOLS) then + ERREXIT1(cinfo, JERR_BAD_POOL_ID, pool_id); { safety check } + +{$ifdef MEM_STATS} + if (cinfo^.err^.trace_level > 1) then + print_mem_stats(cinfo, pool_id); { print pool's memory usage statistics } +{$endif} + + { If freeing IMAGE pool, close any virtual arrays first } + if (pool_id = JPOOL_IMAGE) then + begin + sptr := mem^.virt_sarray_list; + while (sptr <> NIL) do + begin + if (sptr^.b_s_open) then + begin { there may be no backing store } + sptr^.b_s_open := FALSE; { prevent recursive close if error } + sptr^.b_s_info.close_backing_store (cinfo, @sptr^.b_s_info); + end; + sptr := sptr^.next; + end; + mem^.virt_sarray_list := NIL; + bptr := mem^.virt_barray_list; + while (bptr <> NIL) do + begin + if (bptr^.b_s_open) then + begin { there may be no backing store } + bptr^.b_s_open := FALSE; { prevent recursive close if error } + bptr^.b_s_info.close_backing_store (cinfo, @bptr^.b_s_info); + end; + bptr := bptr^.next; + end; + mem^.virt_barray_list := NIL; + end; + + { Release large objects } + lhdr_ptr := mem^.large_list[pool_id]; + mem^.large_list[pool_id] := NIL; + + while (lhdr_ptr <> NIL) do + begin + next_lhdr_ptr := lhdr_ptr^.hdr.next; + space_freed := lhdr_ptr^.hdr.bytes_used + + lhdr_ptr^.hdr.bytes_left + + SIZEOF(large_pool_hdr); + jpeg_free_large(cinfo, {FAR} pointer(lhdr_ptr), space_freed); + Dec(mem^.total_space_allocated, space_freed); + lhdr_ptr := next_lhdr_ptr; + end; + + { Release small objects } + shdr_ptr := mem^.small_list[pool_id]; + mem^.small_list[pool_id] := NIL; + + while (shdr_ptr <> NIL) do + begin + next_shdr_ptr := shdr_ptr^.hdr.next; + space_freed := shdr_ptr^.hdr.bytes_used + + shdr_ptr^.hdr.bytes_left + + SIZEOF(small_pool_hdr); + jpeg_free_small(cinfo, pointer(shdr_ptr), space_freed); + Dec(mem^.total_space_allocated, space_freed); + shdr_ptr := next_shdr_ptr; + end; +end; + + +{ Close up shop entirely. + Note that this cannot be called unless cinfo^.mem is non-NIL. } + +{METHODDEF} +procedure self_destruct (cinfo : j_common_ptr); +var + pool : int; +begin + { Close all backing store, release all memory. + Releasing pools in reverse order might help avoid fragmentation + with some (brain-damaged) malloc libraries. } + + for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT do + begin + free_pool(cinfo, pool); + end; + + { Release the memory manager control block too. } + jpeg_free_small(cinfo, pointer(cinfo^.mem), SIZEOF(my_memory_mgr)); + cinfo^.mem := NIL; { ensures I will be called only once } + + jpeg_mem_term(cinfo); { system-dependent cleanup } +end; + + +{ Memory manager initialization. + When this is called, only the error manager pointer is valid in cinfo! } + +{GLOBAL} +procedure jinit_memory_mgr (cinfo : j_common_ptr); +var + mem : my_mem_ptr; + max_to_use : long; + pool : int; + test_mac : size_t; +{$ifndef NO_GETENV} +var + memenv : string; + code : integer; +{$endif} +begin + cinfo^.mem := NIL; { for safety if init fails } + + { Check for configuration errors. + SIZEOF(ALIGN_TYPE) should be a power of 2; otherwise, it probably + doesn't reflect any real hardware alignment requirement. + The test is a little tricky: for X>0, X and X-1 have no one-bits + in common if and only if X is a power of 2, ie has only one one-bit. + Some compilers may give an "unreachable code" warning here; ignore it. } + if ((SIZEOF(ALIGN_TYPE) and (SIZEOF(ALIGN_TYPE)-1)) <> 0) then + ERREXIT(cinfo, JERR_BAD_ALIGN_TYPE); + { MAX_ALLOC_CHUNK must be representable as type size_t, and must be + a multiple of SIZEOF(ALIGN_TYPE). + Again, an "unreachable code" warning may be ignored here. + But a "constant too large" warning means you need to fix MAX_ALLOC_CHUNK. } + + test_mac := size_t (MAX_ALLOC_CHUNK); + if (long (test_mac) <> MAX_ALLOC_CHUNK) or + ((MAX_ALLOC_CHUNK mod SIZEOF(ALIGN_TYPE)) <> 0) then + ERREXIT(cinfo, JERR_BAD_ALLOC_CHUNK); + + max_to_use := jpeg_mem_init(cinfo); { system-dependent initialization } + + { Attempt to allocate memory manager's control block } + mem := my_mem_ptr (jpeg_get_small(cinfo, SIZEOF(my_memory_mgr))); + + if (mem = NIL) then + begin + jpeg_mem_term(cinfo); { system-dependent cleanup } + ERREXIT1(cinfo, JERR_OUT_OF_MEMORY, 0); + end; + + { OK, fill in the method pointers } + mem^.pub.alloc_small := alloc_small; + mem^.pub.alloc_large := alloc_large; + mem^.pub.alloc_sarray := alloc_sarray; + mem^.pub.alloc_barray := alloc_barray; + mem^.pub.request_virt_sarray := request_virt_sarray; + mem^.pub.request_virt_barray := request_virt_barray; + mem^.pub.realize_virt_arrays := realize_virt_arrays; + mem^.pub.access_virt_sarray := access_virt_sarray; + mem^.pub.access_virt_barray := access_virt_barray; + mem^.pub.free_pool := free_pool; + mem^.pub.self_destruct := self_destruct; + + { Make MAX_ALLOC_CHUNK accessible to other modules } + mem^.pub.max_alloc_chunk := MAX_ALLOC_CHUNK; + + { Initialize working state } + mem^.pub.max_memory_to_use := max_to_use; + + for pool := JPOOL_NUMPOOLS-1 downto JPOOL_PERMANENT do + begin + mem^.small_list[pool] := NIL; + mem^.large_list[pool] := NIL; + end; + mem^.virt_sarray_list := NIL; + mem^.virt_barray_list := NIL; + + mem^.total_space_allocated := SIZEOF(my_memory_mgr); + + { Declare ourselves open for business } + cinfo^.mem := @mem^.pub; + + { Check for an environment variable JPEGMEM; if found, override the + default max_memory setting from jpeg_mem_init. Note that the + surrounding application may again override this value. + If your system doesn't support getenv(), define NO_GETENV to disable + this feature. } + +{$ifndef NO_GETENV} + memenv := getenv('JPEGMEM'); + if (memenv <> '') then + begin + Val(memenv, max_to_use, code); + if (Code = 0) then + begin + max_to_use := max_to_use * long(1000); + mem^.pub.max_memory_to_use := max_to_use * long(1000); + end; + end; +{$endif} + +end; + +end. diff --git a/Imaging/JpegLib/imjmemnobs.pas b/Imaging/JpegLib/imjmemnobs.pas index 750fd80..9698b05 100644 --- a/Imaging/JpegLib/imjmemnobs.pas +++ b/Imaging/JpegLib/imjmemnobs.pas @@ -1,259 +1,259 @@ -unit imjmemnobs; -{ Delphi3 -- > jmemnobs from jmemwin } -{ This file provides an Win32-compatible implementation of the system- - dependent portion of the JPEG memory manager. } - -{ Check jmemnobs.c } -{ Copyright (C) 1996, Jacques Nomssi Nzali } - - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjdeferr, - imjerror, - imjpeglib; - -{ The macro MAX_ALLOC_CHUNK designates the maximum number of bytes that may - be requested in a single call to jpeg_get_large (and jpeg_get_small for that - matter, but that case should never come into play). This macro is needed - to model the 64Kb-segment-size limit of far addressing on 80x86 machines. - On those machines, we expect that jconfig.h will provide a proper value. - On machines with 32-bit flat address spaces, any large constant may be used. - - NB: jmemmgr.c expects that MAX_ALLOC_CHUNK will be representable as type - size_t and will be a multiple of sizeof(align_type). } - -const - MAX_ALLOC_CHUNK = long(1000000000); - -{GLOBAL} -procedure jpeg_open_backing_store (cinfo : j_common_ptr; - info : backing_store_ptr; - total_bytes_needed : long); - -{ These routines take care of any system-dependent initialization and - cleanup required. } - -{GLOBAL} -function jpeg_mem_init (cinfo : j_common_ptr) : long; - -{GLOBAL} -procedure jpeg_mem_term (cinfo : j_common_ptr); - -{ These two functions are used to allocate and release small chunks of - memory. (Typically the total amount requested through jpeg_get_small is - no more than 20K or so; this will be requested in chunks of a few K each.) - Behavior should be the same as for the standard library functions malloc - and free; in particular, jpeg_get_small must return NIL on failure. - On most systems, these ARE malloc and free. jpeg_free_small is passed the - size of the object being freed, just in case it's needed. - On an 80x86 machine using small-data memory model, these manage near heap. } - - -{ Near-memory allocation and freeing are controlled by the regular library - routines malloc() and free(). } - -{GLOBAL} -function jpeg_get_small (cinfo : j_common_ptr; - sizeofobject : size_t) : pointer; - -{GLOBAL} -{object is a reserved word in Borland Pascal } -procedure jpeg_free_small (cinfo : j_common_ptr; - an_object : pointer; - sizeofobject : size_t); - -{ These two functions are used to allocate and release large chunks of - memory (up to the total free space designated by jpeg_mem_available). - The interface is the same as above, except that on an 80x86 machine, - far pointers are used. On most other machines these are identical to - the jpeg_get/free_small routines; but we keep them separate anyway, - in case a different allocation strategy is desirable for large chunks. } - - -{ "Large" objects are allocated in far memory, if possible } - - -{GLOBAL} -function jpeg_get_large (cinfo : j_common_ptr; - sizeofobject : size_t) : voidp; {far} - -{GLOBAL} -procedure jpeg_free_large (cinfo : j_common_ptr; - {var?} an_object : voidp; {FAR} - sizeofobject : size_t); - -{ This routine computes the total memory space available for allocation. - It's impossible to do this in a portable way; our current solution is - to make the user tell us (with a default value set at compile time). - If you can actually get the available space, it's a good idea to subtract - a slop factor of 5% or so. } - -{GLOBAL} -function jpeg_mem_available (cinfo : j_common_ptr; - min_bytes_needed : long; - max_bytes_needed : long; - already_allocated : long) : long; - - -implementation - -{ This structure holds whatever state is needed to access a single - backing-store object. The read/write/close method pointers are called - by jmemmgr.c to manipulate the backing-store object; all other fields - are private to the system-dependent backing store routines. } - - - -{ These two functions are used to allocate and release small chunks of - memory. (Typically the total amount requested through jpeg_get_small is - no more than 20K or so; this will be requested in chunks of a few K each.) - Behavior should be the same as for the standard library functions malloc - and free; in particular, jpeg_get_small must return NIL on failure. - On most systems, these ARE malloc and free. jpeg_free_small is passed the - size of the object being freed, just in case it's needed. - On an 80x86 machine using small-data memory model, these manage near heap. } - - -{ Near-memory allocation and freeing are controlled by the regular library - routines malloc() and free(). } - -{GLOBAL} -function jpeg_get_small (cinfo : j_common_ptr; - sizeofobject : size_t) : pointer; -var - p : pointer; -begin - GetMem(p, sizeofobject); - jpeg_get_small := p; -end; - -{GLOBAL} -{object is a reserved word in Object Pascal } -procedure jpeg_free_small (cinfo : j_common_ptr; - an_object : pointer; - sizeofobject : size_t); -begin - FreeMem(an_object, sizeofobject); -end; - -{ These two functions are used to allocate and release large chunks of - memory (up to the total free space designated by jpeg_mem_available). - The interface is the same as above, except that on an 80x86 machine, - far pointers are used. On most other machines these are identical to - the jpeg_get/free_small routines; but we keep them separate anyway, - in case a different allocation strategy is desirable for large chunks. } - - - -{GLOBAL} -function jpeg_get_large (cinfo : j_common_ptr; - sizeofobject : size_t) : voidp; {far} -var - p : pointer; -begin - GetMem(p, sizeofobject); - jpeg_get_large := p; -end; - -{GLOBAL} -procedure jpeg_free_large (cinfo : j_common_ptr; - {var?} an_object : voidp; {FAR} - sizeofobject : size_t); -begin - Freemem(an_object, sizeofobject); -end; - -{ This routine computes the total space still available for allocation by - jpeg_get_large. If more space than this is needed, backing store will be - used. NOTE: any memory already allocated must not be counted. - - There is a minimum space requirement, corresponding to the minimum - feasible buffer sizes; jmemmgr.c will request that much space even if - jpeg_mem_available returns zero. The maximum space needed, enough to hold - all working storage in memory, is also passed in case it is useful. - Finally, the total space already allocated is passed. If no better - method is available, cinfo^.mem^.max_memory_to_use - already_allocated - is often a suitable calculation. - - It is OK for jpeg_mem_available to underestimate the space available - (that'll just lead to more backing-store access than is really necessary). - However, an overestimate will lead to failure. Hence it's wise to subtract - a slop factor from the true available space. 5% should be enough. - - On machines with lots of virtual memory, any large constant may be returned. - Conversely, zero may be returned to always use the minimum amount of memory.} - - - -{ This routine computes the total memory space available for allocation. - It's impossible to do this in a portable way; our current solution is - to make the user tell us (with a default value set at compile time). - If you can actually get the available space, it's a good idea to subtract - a slop factor of 5% or so. } - -const - DEFAULT_MAX_MEM = long(300000); { for total usage about 450K } - -{GLOBAL} -function jpeg_mem_available (cinfo : j_common_ptr; - min_bytes_needed : long; - max_bytes_needed : long; - already_allocated : long) : long; -begin - {jpeg_mem_available := cinfo^.mem^.max_memory_to_use - already_allocated;} - jpeg_mem_available := max_bytes_needed; -end; - - -{ Initial opening of a backing-store object. This must fill in the - read/write/close pointers in the object. The read/write routines - may take an error exit if the specified maximum file size is exceeded. - (If jpeg_mem_available always returns a large value, this routine can - just take an error exit.) } - - - -{ Initial opening of a backing-store object. } - -{GLOBAL} -procedure jpeg_open_backing_store (cinfo : j_common_ptr; - info : backing_store_ptr; - total_bytes_needed : long); -begin - ERREXIT(cinfo, JERR_NO_BACKING_STORE); -end; - -{ These routines take care of any system-dependent initialization and - cleanup required. jpeg_mem_init will be called before anything is - allocated (and, therefore, nothing in cinfo is of use except the error - manager pointer). It should return a suitable default value for - max_memory_to_use; this may subsequently be overridden by the surrounding - application. (Note that max_memory_to_use is only important if - jpeg_mem_available chooses to consult it ... no one else will.) - jpeg_mem_term may assume that all requested memory has been freed and that - all opened backing-store objects have been closed. } - - -{ These routines take care of any system-dependent initialization and - cleanup required. } - - -{GLOBAL} -function jpeg_mem_init (cinfo : j_common_ptr) : long; -begin - jpeg_mem_init := DEFAULT_MAX_MEM; { default for max_memory_to_use } -end; - -{GLOBAL} -procedure jpeg_mem_term (cinfo : j_common_ptr); -begin - -end; - - -end. +unit imjmemnobs; +{ Delphi3 -- > jmemnobs from jmemwin } +{ This file provides an Win32-compatible implementation of the system- + dependent portion of the JPEG memory manager. } + +{ Check jmemnobs.c } +{ Copyright (C) 1996, Jacques Nomssi Nzali } + + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjdeferr, + imjerror, + imjpeglib; + +{ The macro MAX_ALLOC_CHUNK designates the maximum number of bytes that may + be requested in a single call to jpeg_get_large (and jpeg_get_small for that + matter, but that case should never come into play). This macro is needed + to model the 64Kb-segment-size limit of far addressing on 80x86 machines. + On those machines, we expect that jconfig.h will provide a proper value. + On machines with 32-bit flat address spaces, any large constant may be used. + + NB: jmemmgr.c expects that MAX_ALLOC_CHUNK will be representable as type + size_t and will be a multiple of sizeof(align_type). } + +const + MAX_ALLOC_CHUNK = long(1000000000); + +{GLOBAL} +procedure jpeg_open_backing_store (cinfo : j_common_ptr; + info : backing_store_ptr; + total_bytes_needed : long); + +{ These routines take care of any system-dependent initialization and + cleanup required. } + +{GLOBAL} +function jpeg_mem_init (cinfo : j_common_ptr) : long; + +{GLOBAL} +procedure jpeg_mem_term (cinfo : j_common_ptr); + +{ These two functions are used to allocate and release small chunks of + memory. (Typically the total amount requested through jpeg_get_small is + no more than 20K or so; this will be requested in chunks of a few K each.) + Behavior should be the same as for the standard library functions malloc + and free; in particular, jpeg_get_small must return NIL on failure. + On most systems, these ARE malloc and free. jpeg_free_small is passed the + size of the object being freed, just in case it's needed. + On an 80x86 machine using small-data memory model, these manage near heap. } + + +{ Near-memory allocation and freeing are controlled by the regular library + routines malloc() and free(). } + +{GLOBAL} +function jpeg_get_small (cinfo : j_common_ptr; + sizeofobject : size_t) : pointer; + +{GLOBAL} +{object is a reserved word in Borland Pascal } +procedure jpeg_free_small (cinfo : j_common_ptr; + an_object : pointer; + sizeofobject : size_t); + +{ These two functions are used to allocate and release large chunks of + memory (up to the total free space designated by jpeg_mem_available). + The interface is the same as above, except that on an 80x86 machine, + far pointers are used. On most other machines these are identical to + the jpeg_get/free_small routines; but we keep them separate anyway, + in case a different allocation strategy is desirable for large chunks. } + + +{ "Large" objects are allocated in far memory, if possible } + + +{GLOBAL} +function jpeg_get_large (cinfo : j_common_ptr; + sizeofobject : size_t) : voidp; {far} + +{GLOBAL} +procedure jpeg_free_large (cinfo : j_common_ptr; + {var?} an_object : voidp; {FAR} + sizeofobject : size_t); + +{ This routine computes the total memory space available for allocation. + It's impossible to do this in a portable way; our current solution is + to make the user tell us (with a default value set at compile time). + If you can actually get the available space, it's a good idea to subtract + a slop factor of 5% or so. } + +{GLOBAL} +function jpeg_mem_available (cinfo : j_common_ptr; + min_bytes_needed : long; + max_bytes_needed : long; + already_allocated : long) : long; + + +implementation + +{ This structure holds whatever state is needed to access a single + backing-store object. The read/write/close method pointers are called + by jmemmgr.c to manipulate the backing-store object; all other fields + are private to the system-dependent backing store routines. } + + + +{ These two functions are used to allocate and release small chunks of + memory. (Typically the total amount requested through jpeg_get_small is + no more than 20K or so; this will be requested in chunks of a few K each.) + Behavior should be the same as for the standard library functions malloc + and free; in particular, jpeg_get_small must return NIL on failure. + On most systems, these ARE malloc and free. jpeg_free_small is passed the + size of the object being freed, just in case it's needed. + On an 80x86 machine using small-data memory model, these manage near heap. } + + +{ Near-memory allocation and freeing are controlled by the regular library + routines malloc() and free(). } + +{GLOBAL} +function jpeg_get_small (cinfo : j_common_ptr; + sizeofobject : size_t) : pointer; +var + p : pointer; +begin + GetMem(p, sizeofobject); + jpeg_get_small := p; +end; + +{GLOBAL} +{object is a reserved word in Object Pascal } +procedure jpeg_free_small (cinfo : j_common_ptr; + an_object : pointer; + sizeofobject : size_t); +begin + FreeMem(an_object, sizeofobject); +end; + +{ These two functions are used to allocate and release large chunks of + memory (up to the total free space designated by jpeg_mem_available). + The interface is the same as above, except that on an 80x86 machine, + far pointers are used. On most other machines these are identical to + the jpeg_get/free_small routines; but we keep them separate anyway, + in case a different allocation strategy is desirable for large chunks. } + + + +{GLOBAL} +function jpeg_get_large (cinfo : j_common_ptr; + sizeofobject : size_t) : voidp; {far} +var + p : pointer; +begin + GetMem(p, sizeofobject); + jpeg_get_large := p; +end; + +{GLOBAL} +procedure jpeg_free_large (cinfo : j_common_ptr; + {var?} an_object : voidp; {FAR} + sizeofobject : size_t); +begin + Freemem(an_object, sizeofobject); +end; + +{ This routine computes the total space still available for allocation by + jpeg_get_large. If more space than this is needed, backing store will be + used. NOTE: any memory already allocated must not be counted. + + There is a minimum space requirement, corresponding to the minimum + feasible buffer sizes; jmemmgr.c will request that much space even if + jpeg_mem_available returns zero. The maximum space needed, enough to hold + all working storage in memory, is also passed in case it is useful. + Finally, the total space already allocated is passed. If no better + method is available, cinfo^.mem^.max_memory_to_use - already_allocated + is often a suitable calculation. + + It is OK for jpeg_mem_available to underestimate the space available + (that'll just lead to more backing-store access than is really necessary). + However, an overestimate will lead to failure. Hence it's wise to subtract + a slop factor from the true available space. 5% should be enough. + + On machines with lots of virtual memory, any large constant may be returned. + Conversely, zero may be returned to always use the minimum amount of memory.} + + + +{ This routine computes the total memory space available for allocation. + It's impossible to do this in a portable way; our current solution is + to make the user tell us (with a default value set at compile time). + If you can actually get the available space, it's a good idea to subtract + a slop factor of 5% or so. } + +const + DEFAULT_MAX_MEM = long(300000); { for total usage about 450K } + +{GLOBAL} +function jpeg_mem_available (cinfo : j_common_ptr; + min_bytes_needed : long; + max_bytes_needed : long; + already_allocated : long) : long; +begin + {jpeg_mem_available := cinfo^.mem^.max_memory_to_use - already_allocated;} + jpeg_mem_available := max_bytes_needed; +end; + + +{ Initial opening of a backing-store object. This must fill in the + read/write/close pointers in the object. The read/write routines + may take an error exit if the specified maximum file size is exceeded. + (If jpeg_mem_available always returns a large value, this routine can + just take an error exit.) } + + + +{ Initial opening of a backing-store object. } + +{GLOBAL} +procedure jpeg_open_backing_store (cinfo : j_common_ptr; + info : backing_store_ptr; + total_bytes_needed : long); +begin + ERREXIT(cinfo, JERR_NO_BACKING_STORE); +end; + +{ These routines take care of any system-dependent initialization and + cleanup required. jpeg_mem_init will be called before anything is + allocated (and, therefore, nothing in cinfo is of use except the error + manager pointer). It should return a suitable default value for + max_memory_to_use; this may subsequently be overridden by the surrounding + application. (Note that max_memory_to_use is only important if + jpeg_mem_available chooses to consult it ... no one else will.) + jpeg_mem_term may assume that all requested memory has been freed and that + all opened backing-store objects have been closed. } + + +{ These routines take care of any system-dependent initialization and + cleanup required. } + + +{GLOBAL} +function jpeg_mem_init (cinfo : j_common_ptr) : long; +begin + jpeg_mem_init := DEFAULT_MAX_MEM; { default for max_memory_to_use } +end; + +{GLOBAL} +procedure jpeg_mem_term (cinfo : j_common_ptr); +begin + +end; + + +end. diff --git a/Imaging/JpegLib/imjmorecfg.pas b/Imaging/JpegLib/imjmorecfg.pas index 316a9a7..b51fc3d 100644 --- a/Imaging/JpegLib/imjmorecfg.pas +++ b/Imaging/JpegLib/imjmorecfg.pas @@ -1,247 +1,219 @@ -unit imjmorecfg; - -{ This file contains additional configuration options that customize the - JPEG software for special applications or support machine-dependent - optimizations. Most users will not need to touch this file. } - -{ Source: jmorecfg.h; Copyright (C) 1991-1996, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -{$IFDEF FPC} { Free Pascal Compiler } - type - int = longint; - uInt = Cardinal; { unsigned int } - short = Integer; - ushort = Word; - long = longint; -{$ELSE} -{$IFDEF WIN32} - { Delphi 2.0 } - type - int = Integer; - uInt = Cardinal; - short = SmallInt; - ushort = Word; - long = longint; - {$ELSE} - {$IFDEF VIRTUALPASCAL} - type - int = longint; - uInt = longint; { unsigned int } - short = system.Integer; - ushort = system.Word; - long = longint; - {$ELSE} - type - int = Integer; - uInt = Word; { unsigned int } - short = Integer; - ushort = Word; - long = longint; - {$ENDIF} -{$ENDIF} -{$ENDIF} -type - voidp = pointer; - -type - int_ptr = ^int; - size_t = int; - -{ Define BITS_IN_JSAMPLE as either - 8 for 8-bit sample values (the usual setting) - 12 for 12-bit sample values - Only 8 and 12 are legal data precisions for lossy JPEG according to the - JPEG standard, and the IJG code does not support anything else! - We do not support run-time selection of data precision, sorry. } - -{$ifdef BITS_IN_JSAMPLE_IS_8} { use 8 or 12 } -const - BITS_IN_JSAMPLE = 8; -{$else} -const - BITS_IN_JSAMPLE = 12; -{$endif} - - - - -{ Maximum number of components (color channels) allowed in JPEG image. - To meet the letter of the JPEG spec, set this to 255. However, darn - few applications need more than 4 channels (maybe 5 for CMYK + alpha - mask). We recommend 10 as a reasonable compromise; use 4 if you are - really short on memory. (Each allowed component costs a hundred or so - bytes of storage, whether actually used in an image or not.) } - - -const - MAX_COMPONENTS = 10; { maximum number of image components } - - -{ Basic data types. - You may need to change these if you have a machine with unusual data - type sizes; for example, "char" not 8 bits, "short" not 16 bits, - or "long" not 32 bits. We don't care whether "int" is 16 or 32 bits, - but it had better be at least 16. } - - -{ Representation of a single sample (pixel element value). - We frequently allocate large arrays of these, so it's important to keep - them small. But if you have memory to burn and access to char or short - arrays is very slow on your hardware, you might want to change these. } - - -{$ifdef BITS_IN_JSAMPLE_IS_8} -{ JSAMPLE should be the smallest type that will hold the values 0..255. - You can use a signed char by having GETJSAMPLE mask it with $FF. } - -{ CHAR_IS_UNSIGNED } -type - JSAMPLE = byte; { Pascal unsigned char } - GETJSAMPLE = int; - -const - MAXJSAMPLE = 255; - CENTERJSAMPLE = 128; - -{$endif} - -{$ifndef BITS_IN_JSAMPLE_IS_8} -{ JSAMPLE should be the smallest type that will hold the values 0..4095. - On nearly all machines "short" will do nicely. } - -type - JSAMPLE = short; - GETJSAMPLE = int; - -const - MAXJSAMPLE = 4095; - CENTERJSAMPLE = 2048; - -{$endif} { BITS_IN_JSAMPLE = 12 } - - -{ Representation of a DCT frequency coefficient. - This should be a signed value of at least 16 bits; "short" is usually OK. - Again, we allocate large arrays of these, but you can change to int - if you have memory to burn and "short" is really slow. } -type - JCOEF = int; - JCOEF_PTR = ^JCOEF; - - -{ Compressed datastreams are represented as arrays of JOCTET. - These must be EXACTLY 8 bits wide, at least once they are written to - external storage. Note that when using the stdio data source/destination - managers, this is also the data type passed to fread/fwrite. } - - -type - JOCTET = Byte; - jTOctet = 0..(MaxInt div SizeOf(JOCTET))-1; - JOCTET_FIELD = array[jTOctet] of JOCTET; - JOCTET_FIELD_PTR = ^JOCTET_FIELD; - JOCTETPTR = ^JOCTET; - - GETJOCTET = JOCTET; { A work around } - - -{ These typedefs are used for various table entries and so forth. - They must be at least as wide as specified; but making them too big - won't cost a huge amount of memory, so we don't provide special - extraction code like we did for JSAMPLE. (In other words, these - typedefs live at a different point on the speed/space tradeoff curve.) } - - -{ UINT8 must hold at least the values 0..255. } - -type - UINT8 = byte; - -{ UINT16 must hold at least the values 0..65535. } - - UINT16 = Word; - -{ INT16 must hold at least the values -32768..32767. } - - INT16 = int; - -{ INT32 must hold at least signed 32-bit values. } - - INT32 = longint; -type - INT32PTR = ^INT32; - -{ Datatype used for image dimensions. The JPEG standard only supports - images up to 64K*64K due to 16-bit fields in SOF markers. Therefore - "unsigned int" is sufficient on all machines. However, if you need to - handle larger images and you don't mind deviating from the spec, you - can change this datatype. } - -type - JDIMENSION = uInt; - -const - JPEG_MAX_DIMENSION = 65500; { a tad under 64K to prevent overflows } - - -{ Ordering of RGB data in scanlines passed to or from the application. - If your application wants to deal with data in the order B,G,R, just - change these macros. You can also deal with formats such as R,G,B,X - (one extra byte per pixel) by changing RGB_PIXELSIZE. Note that changing - the offsets will also change the order in which colormap data is organized. - RESTRICTIONS: - 1. The sample applications cjpeg,djpeg do NOT support modified RGB formats. - 2. These macros only affect RGB<=>YCbCr color conversion, so they are not - useful if you are using JPEG color spaces other than YCbCr or grayscale. - 3. The color quantizer modules will not behave desirably if RGB_PIXELSIZE - is not 3 (they don't understand about dummy color components!). So you - can't use color quantization if you change that value. } - -{$ifdef RGB_RED_IS_0} -const - RGB_RED = 0; { Offset of Red in an RGB scanline element } - RGB_GREEN = 1; { Offset of Green } - RGB_BLUE = 2; { Offset of Blue } -{$else} -const - RGB_RED = 2; { Offset of Red in an RGB scanline element } - RGB_GREEN = 1; { Offset of Green } - RGB_BLUE = 0; { Offset of Blue } -{$endif} - -{$ifdef RGB_PIXELSIZE_IS_3} -const - RGB_PIXELSIZE = 3; { JSAMPLEs per RGB scanline element } -{$else} -const - RGB_PIXELSIZE = ??; { Nomssi: deliberate syntax error. Set this value } -{$endif} - -{ Definitions for speed-related optimizations. } - -{ On some machines (notably 68000 series) "int" is 32 bits, but multiplying - two 16-bit shorts is faster than multiplying two ints. Define MULTIPLIER - as short on such a machine. MULTIPLIER must be at least 16 bits wide. } -type - MULTIPLIER = int; { type for fastest integer multiply } - - -{ FAST_FLOAT should be either float or double, whichever is done faster - by your compiler. (Note that this type is only used in the floating point - DCT routines, so it only matters if you've defined DCT_FLOAT_SUPPORTED.) - Typically, float is faster in ANSI C compilers, while double is faster in - pre-ANSI compilers (because they insist on converting to double anyway). - The code below therefore chooses float if we have ANSI-style prototypes. } - -type - FAST_FLOAT = double; {float} - - -implementation - - -end. +unit imjmorecfg; + +{ This file contains additional configuration options that customize the + JPEG software for special applications or support machine-dependent + optimizations. Most users will not need to touch this file. } + +{ Source: jmorecfg.h; Copyright (C) 1991-1996, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +type + int = Integer; + uInt = Cardinal; + short = SmallInt; + ushort = Word; + long = LongInt; + +type + voidp = pointer; + +type + int_ptr = ^int; + size_t = int; + +{ Define BITS_IN_JSAMPLE as either + 8 for 8-bit sample values (the usual setting) + 12 for 12-bit sample values + Only 8 and 12 are legal data precisions for lossy JPEG according to the + JPEG standard, and the IJG code does not support anything else! + We do not support run-time selection of data precision, sorry. } + + +{$ifdef BITS_IN_JSAMPLE_IS_8} { use 8 or 12 } +const + BITS_IN_JSAMPLE = 8; +{$else} +const + BITS_IN_JSAMPLE = 12; +{$endif} + + +{ Maximum number of components (color channels) allowed in JPEG image. + To meet the letter of the JPEG spec, set this to 255. However, darn + few applications need more than 4 channels (maybe 5 for CMYK + alpha + mask). We recommend 10 as a reasonable compromise; use 4 if you are + really short on memory. (Each allowed component costs a hundred or so + bytes of storage, whether actually used in an image or not.) } + + +const + MAX_COMPONENTS = 10; { maximum number of image components } + + +{ Basic data types. + You may need to change these if you have a machine with unusual data + type sizes; for example, "char" not 8 bits, "short" not 16 bits, + or "long" not 32 bits. We don't care whether "int" is 16 or 32 bits, + but it had better be at least 16. } + + +{ Representation of a single sample (pixel element value). + We frequently allocate large arrays of these, so it's important to keep + them small. But if you have memory to burn and access to char or short + arrays is very slow on your hardware, you might want to change these. } + + +{$ifdef BITS_IN_JSAMPLE_IS_8} +{ JSAMPLE should be the smallest type that will hold the values 0..255. + You can use a signed char by having GETJSAMPLE mask it with $FF. } + +{ CHAR_IS_UNSIGNED } +type + JSAMPLE = byte; { Pascal unsigned char } + GETJSAMPLE = int; + +const + MAXJSAMPLE = 255; + CENTERJSAMPLE = 128; + +{$endif} + +{$ifndef BITS_IN_JSAMPLE_IS_8} +{ JSAMPLE should be the smallest type that will hold the values 0..4095. + On nearly all machines "short" will do nicely. } + +type + JSAMPLE = short; + GETJSAMPLE = int; + +const + MAXJSAMPLE = 4095; + CENTERJSAMPLE = 2048; + +{$endif} { BITS_IN_JSAMPLE = 12 } + + +{ Representation of a DCT frequency coefficient. + This should be a signed value of at least 16 bits; "short" is usually OK. + Again, we allocate large arrays of these, but you can change to int + if you have memory to burn and "short" is really slow. } +type + JCOEF = int; + JCOEF_PTR = ^JCOEF; + + +{ Compressed datastreams are represented as arrays of JOCTET. + These must be EXACTLY 8 bits wide, at least once they are written to + external storage. Note that when using the stdio data source/destination + managers, this is also the data type passed to fread/fwrite. } + + +type + JOCTET = Byte; + jTOctet = 0..(MaxInt div SizeOf(JOCTET))-1; + JOCTET_FIELD = array[jTOctet] of JOCTET; + JOCTET_FIELD_PTR = ^JOCTET_FIELD; + JOCTETPTR = ^JOCTET; + + GETJOCTET = JOCTET; { A work around } + + +{ These typedefs are used for various table entries and so forth. + They must be at least as wide as specified; but making them too big + won't cost a huge amount of memory, so we don't provide special + extraction code like we did for JSAMPLE. (In other words, these + typedefs live at a different point on the speed/space tradeoff curve.) } + + +{ UINT8 must hold at least the values 0..255. } + +type + UINT8 = Byte; + +{ UINT16 must hold at least the values 0..65535. } + + UINT16 = Word; + +{ INT16 must hold at least the values -32768..32767. } + + INT16 = SmallInt; + +{ INT32 must hold at least signed 32-bit values. } + + INT32 = LongInt; +type + INT32PTR = ^INT32; + +{ Datatype used for image dimensions. The JPEG standard only supports + images up to 64K*64K due to 16-bit fields in SOF markers. Therefore + "unsigned int" is sufficient on all machines. However, if you need to + handle larger images and you don't mind deviating from the spec, you + can change this datatype. } + +type + JDIMENSION = uInt; + +const + JPEG_MAX_DIMENSION = 65500; { a tad under 64K to prevent overflows } + + +{ Ordering of RGB data in scanlines passed to or from the application. + If your application wants to deal with data in the order B,G,R, just + change these macros. You can also deal with formats such as R,G,B,X + (one extra byte per pixel) by changing RGB_PIXELSIZE. Note that changing + the offsets will also change the order in which colormap data is organized. + RESTRICTIONS: + 1. The sample applications cjpeg,djpeg do NOT support modified RGB formats. + 2. These macros only affect RGB<=>YCbCr color conversion, so they are not + useful if you are using JPEG color spaces other than YCbCr or grayscale. + 3. The color quantizer modules will not behave desirably if RGB_PIXELSIZE + is not 3 (they don't understand about dummy color components!). So you + can't use color quantization if you change that value. } + +{$ifdef RGB_RED_IS_0} +const + RGB_RED = 0; { Offset of Red in an RGB scanline element } + RGB_GREEN = 1; { Offset of Green } + RGB_BLUE = 2; { Offset of Blue } +{$else} +const + RGB_RED = 2; { Offset of Red in an RGB scanline element } + RGB_GREEN = 1; { Offset of Green } + RGB_BLUE = 0; { Offset of Blue } +{$endif} + +{$ifdef RGB_PIXELSIZE_IS_3} +const + RGB_PIXELSIZE = 3; { JSAMPLEs per RGB scanline element } +{$else} +const + RGB_PIXELSIZE = ??; { Nomssi: deliberate syntax error. Set this value } +{$endif} + +{ Definitions for speed-related optimizations. } + +{ On some machines (notably 68000 series) "int" is 32 bits, but multiplying + two 16-bit shorts is faster than multiplying two ints. Define MULTIPLIER + as short on such a machine. MULTIPLIER must be at least 16 bits wide. } +type + MULTIPLIER = int; { type for fastest integer multiply } + + +{ FAST_FLOAT should be either float or double, whichever is done faster + by your compiler. (Note that this type is only used in the floating point + DCT routines, so it only matters if you've defined DCT_FLOAT_SUPPORTED.) + Typically, float is faster in ANSI C compilers, while double is faster in + pre-ANSI compilers (because they insist on converting to double anyway). + The code below therefore chooses float if we have ANSI-style prototypes. } + +type + FAST_FLOAT = double; {float} + + +implementation + + +end. diff --git a/Imaging/JpegLib/imjpeglib.pas b/Imaging/JpegLib/imjpeglib.pas index e859702..9da5b41 100644 --- a/Imaging/JpegLib/imjpeglib.pas +++ b/Imaging/JpegLib/imjpeglib.pas @@ -1,1300 +1,1300 @@ -unit imjpeglib; - -{ This file defines the application interface for the JPEG library. - Most applications using the library need only include this file, - and perhaps jerror.h if they want to know the exact error codes. } - -{ Source:jpeglib.h+jpegint.h; Copyright (C) 1991-1998, Thomas G. Lane. } - - -interface - -{$I imjconfig.inc} - -{ First we include the configuration files that record how this - installation of the JPEG library is set up. jconfig.h can be - generated automatically for many systems. jmorecfg.h contains - manual configuration options that most people need not worry about. } - -uses - imjdeferr, - imjmorecfg; { seldom changed options } - -{ Version ID for the JPEG library. - Might be useful for tests like "#if JPEG_LIB_VERSION >= 60". } - - -Const - JPEG_LIB_VERSION = 62; { Version 6b } - - -{ These marker codes are exported since applications and data source modules - are likely to want to use them. } - -const - JPEG_RST0 = $D0; { RST0 marker code } - JPEG_EOI = $D9; { EOI marker code } - JPEG_APP0 = $E0; { APP0 marker code } - JPEG_COM = $FE; { COM marker code } - - -{ Various constants determining the sizes of things. - All of these are specified by the JPEG standard, so don't change them - if you want to be compatible. } - -const - DCTSIZE = 8; { The basic DCT block is 8x8 samples } - DCTSIZE2 = 64; { DCTSIZE squared; # of elements in a block } - NUM_QUANT_TBLS = 4; { Quantization tables are numbered 0..3 } - NUM_HUFF_TBLS = 4; { Huffman tables are numbered 0..3 } - NUM_ARITH_TBLS = 16; { Arith-coding tables are numbered 0..15 } - MAX_COMPS_IN_SCAN = 4; { JPEG limit on # of components in one scan } - MAX_SAMP_FACTOR = 4; { JPEG limit on sampling factors } -{ Unfortunately, some bozo at Adobe saw no reason to be bound by the standard; - the PostScript DCT filter can emit files with many more than 10 blocks/MCU. - If you happen to run across such a file, you can up D_MAX_BLOCKS_IN_MCU - to handle it. We even let you do this from the jconfig.h file. However, - we strongly discourage changing C_MAX_BLOCKS_IN_MCU; just because Adobe - sometimes emits noncompliant files doesn't mean you should too. } - C_MAX_BLOCKS_IN_MCU = 10; { compressor's limit on blocks per MCU } - D_MAX_BLOCKS_IN_MCU = 10; { decompressor's limit on blocks per MCU } - - -{ Data structures for images (arrays of samples and of DCT coefficients). - On 80x86 machines, the image arrays are too big for near pointers, - but the pointer arrays can fit in near memory. } - -type -{ for typecasting } - JSAMPLE_PTR = ^JSAMPLE; - JSAMPROW_PTR = ^JSAMPROW; - JBLOCKROW_PTR = ^JBLOCKROW; - - jTSample = 0..(MaxInt div SIZEOF(JSAMPLE))-1; - JSAMPLE_ARRAY = Array[jTSample] of JSAMPLE; {far} - JSAMPROW = ^JSAMPLE_ARRAY; { ptr to one image row of pixel samples. } - - jTRow = 0..(MaxInt div SIZEOF(JSAMPROW))-1; - JSAMPROW_ARRAY = Array[jTRow] of JSAMPROW; - JSAMPARRAY = ^JSAMPROW_ARRAY; { ptr to some rows (a 2-D sample array) } - - jTArray = 0..(MaxInt div SIZEOF(JSAMPARRAY))-1; - JSAMP_ARRAY = Array[jTArray] of JSAMPARRAY; - JSAMPIMAGE = ^JSAMP_ARRAY; { a 3-D sample array: top index is color } - - JBLOCK = Array[0..DCTSIZE2-1] of JCOEF; { one block of coefficients } - JBLOCK_PTR = ^JBLOCK; - - jTBlockRow = 0..(MaxInt div SIZEOF(JBLOCK))-1; - JBLOCK_ROWS = Array[jTBlockRow] of JBLOCK; - JBLOCKROW = ^JBLOCK_ROWS; {far} { pointer to one row of coefficient blocks } - - - jTBlockArray = 0..(MaxInt div SIZEOF(JBLOCKROW))-1; - JBLOCK_ARRAY = Array[jTBlockArray] of JBLOCKROW; - JBLOCKARRAY = ^JBLOCK_ARRAY; { a 2-D array of coefficient blocks } - - jTBlockImage = 0..(MaxInt div SIZEOF(JBLOCKARRAY))-1; - JBLOCK_IMAGE = Array[jTBlockImage] of JBLOCKARRAY; - JBLOCKIMAGE = ^JBLOCK_IMAGE; { a 3-D array of coefficient blocks } - - jTCoef = 0..(MaxInt div SIZEOF(JCOEF))-1; - JCOEF_ROW = Array[jTCoef] of JCOEF; - JCOEFPTR = ^JCOEF_ROW; {far} { useful in a couple of places } - - -type - jTByte = 0..(MaxInt div SIZEOF(byte))-1; - JByteArray = Array[jTByte] of byte; - JBytePtr = ^JByteArray; -type - byteptr = ^byte; - -{ Types for JPEG compression parameters and working tables. } - - -{ DCT coefficient quantization tables. } - -type - JQUANT_TBL_PTR = ^JQUANT_TBL; - JQUANT_TBL = record - { This array gives the coefficient quantizers in natural array order - (not the zigzag order in which they are stored in a JPEG DQT marker). - CAUTION: IJG versions prior to v6a kept this array in zigzag order. } - quantval : Array[0..DCTSIZE2-1] of UINT16; - { quantization step for each coefficient } - { This field is used only during compression. It's initialized FALSE when - the table is created, and set TRUE when it's been output to the file. - You could suppress output of a table by setting this to TRUE. - (See jpeg_suppress_tables for an example.) } - sent_table : boolean; { TRUE when table has been output } - end; - JQUANT_TBL_FIELD = Array[0..(MaxInt div SizeOf(JQUANT_TBL))-1] of JQUANT_TBL; - -{ Huffman coding tables. } - -type - JHUFF_TBL_PTR = ^JHUFF_TBL; - JHUFF_TBL = record - { These two fields directly represent the contents of a JPEG DHT marker } - bits : Array[0..17-1] of UINT8; { bits[k] = # of symbols with codes of } - { length k bits; bits[0] is unused } - huffval : Array[0..256-1] of UINT8; - { The symbols, in order of incr code length } - { This field is used only during compression. It's initialized FALSE when - the table is created, and set TRUE when it's been output to the file. - You could suppress output of a table by setting this to TRUE. - (See jpeg_suppress_tables for an example.) } - sent_table : boolean; { TRUE when table has been output } - end; - JHUFF_TBL_FIELD = Array[0..(MaxInt div SizeOf(JHUFF_TBL))-1] of JHUFF_TBL; - -{ Declarations for both compression & decompression } - -type - J_BUF_MODE = ( { Operating modes for buffer controllers } - JBUF_PASS_THRU, { Plain stripwise operation } - { Remaining modes require a full-image buffer to have been created } - JBUF_SAVE_SOURCE, { Run source subobject only, save output } - JBUF_CRANK_DEST, { Run dest subobject only, using saved data } - JBUF_SAVE_AND_PASS { Run both subobjects, save output } - ); - -{ Values of global_state field (jdapi.c has some dependencies on ordering!) } -const - CSTATE_START = 100; { after create_compress } - CSTATE_SCANNING = 101; { start_compress done, write_scanlines OK } - CSTATE_RAW_OK = 102; { start_compress done, write_raw_data OK } - CSTATE_WRCOEFS = 103; { jpeg_write_coefficients done } - DSTATE_START = 200; { after create_decompress } - DSTATE_INHEADER = 201; { reading header markers, no SOS yet } - DSTATE_READY = 202; { found SOS, ready for start_decompress } - DSTATE_PRELOAD = 203; { reading multiscan file in start_decompress} - DSTATE_PRESCAN = 204; { performing dummy pass for 2-pass quant } - DSTATE_SCANNING = 205; { start_decompress done, read_scanlines OK } - DSTATE_RAW_OK = 206; { start_decompress done, read_raw_data OK } - DSTATE_BUFIMAGE = 207; { expecting jpeg_start_output } - DSTATE_BUFPOST = 208; { looking for SOS/EOI in jpeg_finish_output } - DSTATE_RDCOEFS = 209; { reading file in jpeg_read_coefficients } - DSTATE_STOPPING = 210; { looking for EOI in jpeg_finish_decompress } - - - -{ Basic info about one component (color channel). } - -type - jpeg_component_info_ptr = ^jpeg_component_info; - jpeg_component_info = record - { These values are fixed over the whole image. } - { For compression, they must be supplied by parameter setup; } - { for decompression, they are read from the SOF marker. } - component_id : int; { identifier for this component (0..255) } - component_index : int; { its index in SOF or cinfo^.comp_info[] } - h_samp_factor : int; { horizontal sampling factor (1..4) } - v_samp_factor : int; { vertical sampling factor (1..4) } - quant_tbl_no : int; { quantization table selector (0..3) } - { These values may vary between scans. } - { For compression, they must be supplied by parameter setup; } - { for decompression, they are read from the SOS marker. } - { The decompressor output side may not use these variables. } - dc_tbl_no : int; { DC entropy table selector (0..3) } - ac_tbl_no : int; { AC entropy table selector (0..3) } - - { Remaining fields should be treated as private by applications. } - - { These values are computed during compression or decompression startup: } - { Component's size in DCT blocks. - Any dummy blocks added to complete an MCU are not counted; therefore - these values do not depend on whether a scan is interleaved or not. } - width_in_blocks : JDIMENSION; - height_in_blocks : JDIMENSION; - { Size of a DCT block in samples. Always DCTSIZE for compression. - For decompression this is the size of the output from one DCT block, - reflecting any scaling we choose to apply during the IDCT step. - Values of 1,2,4,8 are likely to be supported. Note that different - components may receive different IDCT scalings. } - - DCT_scaled_size : int; - { The downsampled dimensions are the component's actual, unpadded number - of samples at the main buffer (preprocessing/compression interface), thus - downsampled_width = ceil(image_width * Hi/Hmax) - and similarly for height. For decompression, IDCT scaling is included, so - downsampled_width = ceil(image_width * Hi/Hmax * DCT_scaled_size/DCTSIZE)} - - downsampled_width : JDIMENSION; { actual width in samples } - downsampled_height : JDIMENSION; { actual height in samples } - { This flag is used only for decompression. In cases where some of the - components will be ignored (eg grayscale output from YCbCr image), - we can skip most computations for the unused components. } - - component_needed : boolean; { do we need the value of this component? } - - { These values are computed before starting a scan of the component. } - { The decompressor output side may not use these variables. } - MCU_width : int; { number of blocks per MCU, horizontally } - MCU_height : int; { number of blocks per MCU, vertically } - MCU_blocks : int; { MCU_width * MCU_height } - MCU_sample_width : int; { MCU width in samples, MCU_width*DCT_scaled_size } - last_col_width : int; { # of non-dummy blocks across in last MCU } - last_row_height : int; { # of non-dummy blocks down in last MCU } - - { Saved quantization table for component; NIL if none yet saved. - See jdinput.c comments about the need for this information. - This field is currently used only for decompression. } - - quant_table : JQUANT_TBL_PTR; - - { Private per-component storage for DCT or IDCT subsystem. } - dct_table : pointer; - end; { record jpeg_component_info } - - jTCinfo = 0..(MaxInt div SizeOf(jpeg_component_info))-1; - jpeg_component_info_array = array[jTCinfo] of jpeg_component_info; - jpeg_component_info_list_ptr = ^jpeg_component_info_array; - - -{ The script for encoding a multiple-scan file is an array of these: } - -type - jpeg_scan_info_ptr = ^jpeg_scan_info; - jpeg_scan_info = record - comps_in_scan : int; { number of components encoded in this scan } - component_index : Array[0..MAX_COMPS_IN_SCAN-1] of int; - { their SOF/comp_info[] indexes } - Ss, Se : int; { progressive JPEG spectral selection parms } - Ah, Al : int; { progressive JPEG successive approx. parms } - end; - -{ The decompressor can save APPn and COM markers in a list of these: } - -type - jpeg_saved_marker_ptr = ^jpeg_marker_struct; - jpeg_marker_struct = record - next : jpeg_saved_marker_ptr; { next in list, or NULL } - marker : UINT8; { marker code: JPEG_COM, or JPEG_APP0+n } - original_length : uint; { # bytes of data in the file } - data_length : uint; { # bytes of data saved at data[] } - data : JOCTET_FIELD_PTR; { the data contained in the marker } - { the marker length word is not counted in data_length or original_length } - end; - -{ Known color spaces. } - -type - J_COLOR_SPACE = ( - JCS_UNKNOWN, { error/unspecified } - JCS_GRAYSCALE, { monochrome } - JCS_RGB, { red/green/blue } - JCS_YCbCr, { Y/Cb/Cr (also known as YUV) } - JCS_CMYK, { C/M/Y/K } - JCS_YCCK { Y/Cb/Cr/K } - ); - -{ DCT/IDCT algorithm options. } - -type - J_DCT_METHOD = ( - JDCT_ISLOW, { slow but accurate integer algorithm } - JDCT_IFAST, { faster, less accurate integer method } - JDCT_FLOAT { floating-point: accurate, fast on fast HW } - ); - -const - JDCT_DEFAULT = JDCT_ISLOW; - JDCT_FASTEST = JDCT_IFAST; - -{ Dithering options for decompression. } - -type - J_DITHER_MODE = ( - JDITHER_NONE, { no dithering } - JDITHER_ORDERED, { simple ordered dither } - JDITHER_FS { Floyd-Steinberg error diffusion dither } - ); - - -const - JPOOL_PERMANENT = 0; { lasts until master record is destroyed } - JPOOL_IMAGE = 1; { lasts until done with image/datastream } - JPOOL_NUMPOOLS = 2; - - -{ "Object" declarations for JPEG modules that may be supplied or called - directly by the surrounding application. - As with all objects in the JPEG library, these structs only define the - publicly visible methods and state variables of a module. Additional - private fields may exist after the public ones. } - - -{ Error handler object } - -const - JMSG_LENGTH_MAX = 200; { recommended size of format_message buffer } - JMSG_STR_PARM_MAX = 80; - -const - TEMP_NAME_LENGTH = 64; { max length of a temporary file's name } -type - TEMP_STRING = string[TEMP_NAME_LENGTH]; - -{$ifdef USE_MSDOS_MEMMGR} { DOS-specific junk } -type - XMSH = ushort; { type of extended-memory handles } - EMSH = ushort; { type of expanded-memory handles } - - handle_union = record - case byte of - 0:(file_handle : short); { DOS file handle if it's a temp file } - 1:(xms_handle : XMSH); { handle if it's a chunk of XMS } - 2:(ems_handle : EMSH); { handle if it's a chunk of EMS } - end; -{$endif} { USE_MSDOS_MEMMGR } - -type - jpeg_error_mgr_ptr = ^jpeg_error_mgr; - jpeg_memory_mgr_ptr = ^jpeg_memory_mgr; - jpeg_progress_mgr_ptr = ^jpeg_progress_mgr; - - -{$ifdef common} -{ Common fields between JPEG compression and decompression master structs. } - err : jpeg_error_mgr_ptr; { Error handler module } - mem : jpeg_memory_mgr_ptr; { Memory manager module } - progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none } - client_data : voidp; { Available for use by application } - is_decompressor : boolean; { so common code can tell which is which } - global_state : int; { for checking call sequence validity } -{$endif} - - j_common_ptr = ^jpeg_common_struct; - j_compress_ptr = ^jpeg_compress_struct; - j_decompress_ptr = ^jpeg_decompress_struct; - - {$ifdef AM_MEMORY_MANAGER} { only jmemmgr.c defines these } - -{ This structure holds whatever state is needed to access a single - backing-store object. The read/write/close method pointers are called - by jmemmgr.c to manipulate the backing-store object; all other fields - are private to the system-dependent backing store routines. } - - - backing_store_ptr = ^backing_store_info; - backing_store_info = record - { Methods for reading/writing/closing this backing-store object } - read_backing_store : procedure (cinfo : j_common_ptr; - info : backing_store_ptr; - buffer_address : pointer; {far} - file_offset : long; - byte_count : long); - write_backing_store : procedure (cinfo : j_common_ptr; - info : backing_store_ptr; - buffer_address : pointer; {far} - file_offset : long; - byte_count : long); - - close_backing_store : procedure (cinfo : j_common_ptr; - info : backing_store_ptr); - - { Private fields for system-dependent backing-store management } - {$ifdef USE_MSDOS_MEMMGR} - { For the MS-DOS manager (jmemdos.c), we need: } - handle : handle_union; { reference to backing-store storage object } - temp_name : TEMP_STRING; { name if it's a file } - {$else} - { For a typical implementation with temp files, we need: } - temp_file : file; { stdio reference to temp file } - temp_name : TEMP_STRING; { name of temp file } - {$endif} - end; - - -{ The control blocks for virtual arrays. - Note that these blocks are allocated in the "small" pool area. - System-dependent info for the associated backing store (if any) is hidden - inside the backing_store_info struct. } - - jvirt_sarray_ptr = ^jvirt_sarray_control; - jvirt_sarray_control = record - mem_buffer : JSAMPARRAY; { => the in-memory buffer } - rows_in_array : JDIMENSION; { total virtual array height } - samplesperrow : JDIMENSION; { width of array (and of memory buffer) } - maxaccess : JDIMENSION; { max rows accessed by access_virt_sarray } - rows_in_mem : JDIMENSION; { height of memory buffer } - rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer } - cur_start_row : JDIMENSION; { first logical row # in the buffer } - first_undef_row : JDIMENSION; { row # of first uninitialized row } - pre_zero : boolean; { pre-zero mode requested? } - dirty : boolean; { do current buffer contents need written? } - b_s_open : boolean; { is backing-store data valid? } - next : jvirt_sarray_ptr; { link to next virtual sarray control block } - b_s_info : backing_store_info; { System-dependent control info } - end; - - jvirt_barray_ptr = ^jvirt_barray_control; - jvirt_barray_control = record - mem_buffer : JBLOCKARRAY; { => the in-memory buffer } - rows_in_array : JDIMENSION; { total virtual array height } - blocksperrow : JDIMENSION; { width of array (and of memory buffer) } - maxaccess : JDIMENSION; { max rows accessed by access_virt_barray } - rows_in_mem : JDIMENSION; { height of memory buffer } - rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer } - cur_start_row : JDIMENSION; { first logical row # in the buffer } - first_undef_row : JDIMENSION; { row # of first uninitialized row } - pre_zero : boolean; { pre-zero mode requested? } - dirty : boolean; { do current buffer contents need written? } - b_s_open : boolean; { is backing-store data valid? } - next : jvirt_barray_ptr; { link to next virtual barray control block } - b_s_info : backing_store_info; { System-dependent control info } - end; - - {$endif} { AM_MEMORY_MANAGER } - -{ Declarations for compression modules } - -{ Master control module } - jpeg_comp_master_ptr = ^jpeg_comp_master; - jpeg_comp_master = record - prepare_for_pass : procedure(cinfo : j_compress_ptr); - pass_startup : procedure(cinfo : j_compress_ptr); - finish_pass : procedure(cinfo : j_compress_ptr); - - { State variables made visible to other modules } - call_pass_startup : Boolean; { True if pass_startup must be called } - is_last_pass : Boolean; { True during last pass } - end; - -{ Main buffer control (downsampled-data buffer) } - jpeg_c_main_controller_ptr = ^jpeg_c_main_controller; - jpeg_c_main_controller = record - start_pass : procedure(cinfo : j_compress_ptr; pass_mode : J_BUF_MODE); - process_data : procedure(cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - var in_row_ctr : JDIMENSION; - in_rows_avail : JDIMENSION); - end; - -{ Compression preprocessing (downsampling input buffer control) } - jpeg_c_prep_controller_ptr = ^jpeg_c_prep_controller; - jpeg_c_prep_controller = record - start_pass : procedure(cinfo : j_compress_ptr; pass_mode : J_BUF_MODE); - pre_process_data : procedure(cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - var in_row_ctr : JDIMENSION; - in_rows_avail : JDIMENSION; - output_buf : JSAMPIMAGE; - var out_row_group_ctr : JDIMENSION; - out_row_groups_avail : JDIMENSION); - end; - -{ Coefficient buffer control } - jpeg_c_coef_controller_ptr = ^jpeg_c_coef_controller; - jpeg_c_coef_controller = record - start_pass : procedure(cinfo : j_compress_ptr; pass_mode : J_BUF_MODE); - compress_data : function(cinfo : j_compress_ptr; - input_buf : JSAMPIMAGE) : boolean; - end; - -{ Colorspace conversion } - jpeg_color_converter_ptr = ^jpeg_color_converter; - jpeg_color_converter = record - start_pass : procedure(cinfo : j_compress_ptr); - color_convert : procedure(cinfo : j_compress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPIMAGE; - output_row : JDIMENSION; - num_rows : int); - end; - -{ Downsampling } - jpeg_downsampler_ptr = ^jpeg_downsampler; - jpeg_downsampler = record - start_pass : procedure(cinfo : j_compress_ptr); - downsample : procedure(cinfo : j_compress_ptr; - input_buf : JSAMPIMAGE; - in_row_index : JDIMENSION; - output_buf : JSAMPIMAGE; - out_row_group_index: JDIMENSION); - need_context_rows : Boolean; { TRUE if need rows above & below } - end; - -{ Forward DCT (also controls coefficient quantization) } - jpeg_forward_dct_ptr = ^jpeg_forward_dct; - jpeg_forward_dct = record - start_pass : procedure(cinfo : j_compress_ptr); - { perhaps this should be an array??? } - forward_DCT : procedure(cinfo : j_compress_ptr; - compptr : jpeg_component_info_ptr; - sample_data : JSAMPARRAY; - coef_blocks : JBLOCKROW; - start_row : JDIMENSION; - start_col : JDIMENSION; - num_blocks : JDIMENSION); - end; - -{ Entropy encoding } - - jpeg_entropy_encoder_ptr = ^jpeg_entropy_encoder; - jpeg_entropy_encoder = record - start_pass : procedure(cinfo : j_compress_ptr; gather_statistics : boolean); - encode_mcu : function(cinfo : j_compress_ptr; - const MCU_data: array of JBLOCKROW) : boolean; - finish_pass : procedure(cinfo : j_compress_ptr); - end; - -{ Marker writing } - jpeg_marker_writer_ptr = ^jpeg_marker_writer; - jpeg_marker_writer = record - write_file_header : procedure(cinfo : j_compress_ptr); - write_frame_header : procedure(cinfo : j_compress_ptr); - write_scan_header : procedure(cinfo : j_compress_ptr); - write_file_trailer : procedure(cinfo : j_compress_ptr); - write_tables_only : procedure(cinfo : j_compress_ptr); - { These routines are exported to allow insertion of extra markers } - { Probably only COM and APPn markers should be written this way } - write_marker_header : procedure (cinfo : j_compress_ptr; - marker : int; - datalen : uint); - write_marker_byte : procedure (cinfo : j_compress_ptr; val : int); - end; - -{ Declarations for decompression modules } - -{ Master control module } - jpeg_decomp_master_ptr = ^jpeg_decomp_master; - jpeg_decomp_master = record - prepare_for_output_pass : procedure( cinfo : j_decompress_ptr); - finish_output_pass : procedure(cinfo : j_decompress_ptr); - - { State variables made visible to other modules } - is_dummy_pass : Boolean; { True during 1st pass for 2-pass quant } - end; - -{ Input control module } - jpeg_input_controller_ptr = ^jpeg_input_controller; - jpeg_input_controller = record - consume_input : function (cinfo : j_decompress_ptr) : int; - reset_input_controller : procedure(cinfo : j_decompress_ptr); - start_input_pass : procedure(cinfo : j_decompress_ptr); - finish_input_pass : procedure(cinfo : j_decompress_ptr); - - { State variables made visible to other modules } - has_multiple_scans : Boolean; { True if file has multiple scans } - eoi_reached : Boolean; { True when EOI has been consumed } - end; - -{ Main buffer control (downsampled-data buffer) } - - jpeg_d_main_controller_ptr = ^jpeg_d_main_controller; - jpeg_d_main_controller = record - start_pass : procedure(cinfo : j_decompress_ptr; pass_mode : J_BUF_MODE); - process_data : procedure(cinfo : j_decompress_ptr; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); - end; - -{ Coefficient buffer control } - jvirt_barray_tbl = array[0..MAX_COMPONENTS-1] of jvirt_barray_ptr; - jvirt_barray_tbl_ptr = ^jvirt_barray_tbl; - jpeg_d_coef_controller_ptr = ^jpeg_d_coef_controller; - jpeg_d_coef_controller = record - start_input_pass : procedure(cinfo : j_decompress_ptr); - consume_data : function (cinfo : j_decompress_ptr) : int; - start_output_pass : procedure(cinfo : j_decompress_ptr); - decompress_data : function (cinfo : j_decompress_ptr; - output_buf : JSAMPIMAGE) : int; - { Pointer to array of coefficient virtual arrays, or NIL if none } - coef_arrays : jvirt_barray_tbl_ptr; - end; - -{ Decompression postprocessing (color quantization buffer control) } - jpeg_d_post_controller_ptr = ^jpeg_d_post_controller; - jpeg_d_post_controller = record - start_pass : procedure(cinfo : j_decompress_ptr; - pass_mode : J_BUF_MODE); - post_process_data : procedure(cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); - end; - - -{ Routine signature for application-supplied marker processing methods. - Need not pass marker code since it is stored in cinfo^.unread_marker. } - - jpeg_marker_parser_method = function(cinfo : j_decompress_ptr) : boolean; - -{ Marker reading & parsing } - jpeg_marker_reader_ptr = ^jpeg_marker_reader; - jpeg_marker_reader = record - reset_marker_reader : procedure(cinfo : j_decompress_ptr); - { Read markers until SOS or EOI. - Returns same codes as are defined for jpeg_consume_input: - JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. } - - read_markers : function (cinfo : j_decompress_ptr) : int; - { Read a restart marker --- exported for use by entropy decoder only } - read_restart_marker : jpeg_marker_parser_method; - - { State of marker reader --- nominally internal, but applications - supplying COM or APPn handlers might like to know the state. } - - saw_SOI : boolean; { found SOI? } - saw_SOF : boolean; { found SOF? } - next_restart_num : int; { next restart number expected (0-7) } - discarded_bytes : uint; { # of bytes skipped looking for a marker } - end; - -{ Entropy decoding } - jpeg_entropy_decoder_ptr = ^jpeg_entropy_decoder; - jpeg_entropy_decoder = record - start_pass : procedure(cinfo : j_decompress_ptr); - decode_mcu : function(cinfo : j_decompress_ptr; - var MCU_data : array of JBLOCKROW) : boolean; - { This is here to share code between baseline and progressive decoders; } - { other modules probably should not use it } - insufficient_data : BOOLEAN; { set TRUE after emitting warning } - end; - -{ Inverse DCT (also performs dequantization) } - inverse_DCT_method_ptr = procedure(cinfo : j_decompress_ptr; - compptr : jpeg_component_info_ptr; - coef_block : JCOEFPTR; - output_buf : JSAMPARRAY; output_col : JDIMENSION); - - jpeg_inverse_dct_ptr = ^jpeg_inverse_dct; - jpeg_inverse_dct = record - start_pass : procedure(cinfo : j_decompress_ptr); - { It is useful to allow each component to have a separate IDCT method. } - inverse_DCT : Array[0..MAX_COMPONENTS-1] of inverse_DCT_method_ptr; - end; - -{ Upsampling (note that upsampler must also call color converter) } - jpeg_upsampler_ptr = ^jpeg_upsampler; - jpeg_upsampler = record - start_pass : procedure(cinfo : j_decompress_ptr); - upsample : procedure(cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - var in_row_group_ctr : JDIMENSION; { array of } - in_row_groups_avail : JDIMENSION; - output_buf : JSAMPARRAY; - var out_row_ctr : JDIMENSION; - out_rows_avail : JDIMENSION); - - need_context_rows : boolean; { TRUE if need rows above & below } - end; - -{ Colorspace conversion } - jpeg_color_deconverter_ptr = ^jpeg_color_deconverter; - jpeg_color_deconverter = record - start_pass : procedure(cinfo: j_decompress_ptr); - color_convert : procedure(cinfo : j_decompress_ptr; - input_buf : JSAMPIMAGE; - input_row : JDIMENSION; - output_buf : JSAMPARRAY; - num_rows : int); - end; - -{ Color quantization or color precision reduction } - jpeg_color_quantizer_ptr = ^jpeg_color_quantizer; - jpeg_color_quantizer = record - start_pass : procedure(cinfo : j_decompress_ptr; is_pre_scan : boolean); - color_quantize : procedure(cinfo : j_decompress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPARRAY; - num_rows : int); - - finish_pass : procedure(cinfo : j_decompress_ptr); - new_color_map : procedure(cinfo : j_decompress_ptr); - end; - - {int8array = Array[0..8-1] of int;} - int8array = Array[0..8-1] of longint; { for TP FormatStr } - - jpeg_error_mgr = record - { Error exit handler: does not return to caller } - error_exit : procedure (cinfo : j_common_ptr); - { Conditionally emit a trace or warning message } - emit_message : procedure (cinfo : j_common_ptr; msg_level : int); - { Routine that actually outputs a trace or error message } - output_message : procedure (cinfo : j_common_ptr); - { Format a message string for the most recent JPEG error or message } - format_message : procedure (cinfo : j_common_ptr; var buffer : string); - - { Reset error state variables at start of a new image } - reset_error_mgr : procedure (cinfo : j_common_ptr); - - { The message ID code and any parameters are saved here. - A message can have one string parameter or up to 8 int parameters. } - - msg_code : int; - - msg_parm : record - case byte of - 0:(i : int8array); - 1:(s : string[JMSG_STR_PARM_MAX]); - end; - - { Standard state variables for error facility } - - trace_level : int; { max msg_level that will be displayed } - - { For recoverable corrupt-data errors, we emit a warning message, - but keep going unless emit_message chooses to abort. emit_message - should count warnings in num_warnings. The surrounding application - can check for bad data by seeing if num_warnings is nonzero at the - end of processing. } - - num_warnings : long; { number of corrupt-data warnings } - - { These fields point to the table(s) of error message strings. - An application can change the table pointer to switch to a different - message list (typically, to change the language in which errors are - reported). Some applications may wish to add additional error codes - that will be handled by the JPEG library error mechanism; the second - table pointer is used for this purpose. - - First table includes all errors generated by JPEG library itself. - Error code 0 is reserved for a "no such error string" message. } - - {const char * const * jpeg_message_table; } - jpeg_message_table : ^msg_table; { Library errors } - - last_jpeg_message : J_MESSAGE_CODE; - { Table contains strings 0..last_jpeg_message } - { Second table can be added by application (see cjpeg/djpeg for example). - It contains strings numbered first_addon_message..last_addon_message. } - - {const char * const * addon_message_table; } - addon_message_table : ^msg_table; { Non-library errors } - - first_addon_message : J_MESSAGE_CODE; { code for first string in addon table } - last_addon_message : J_MESSAGE_CODE; { code for last string in addon table } - end; - - -{ Progress monitor object } - - jpeg_progress_mgr = record - progress_monitor : procedure(cinfo : j_common_ptr); - - pass_counter : long; { work units completed in this pass } - pass_limit : long; { total number of work units in this pass } - completed_passes : int; { passes completed so far } - total_passes : int; { total number of passes expected } - end; - - -{ Data destination object for compression } - jpeg_destination_mgr_ptr = ^jpeg_destination_mgr; - jpeg_destination_mgr = record - next_output_byte : JOCTETptr; { => next byte to write in buffer } - free_in_buffer : size_t; { # of byte spaces remaining in buffer } - - init_destination : procedure (cinfo : j_compress_ptr); - empty_output_buffer : function (cinfo : j_compress_ptr) : boolean; - term_destination : procedure (cinfo : j_compress_ptr); - end; - - -{ Data source object for decompression } - - jpeg_source_mgr_ptr = ^jpeg_source_mgr; - jpeg_source_mgr = record - {const JOCTET * next_input_byte;} - next_input_byte : JOCTETptr; { => next byte to read from buffer } - bytes_in_buffer : size_t; { # of bytes remaining in buffer } - - init_source : procedure (cinfo : j_decompress_ptr); - fill_input_buffer : function (cinfo : j_decompress_ptr) : boolean; - skip_input_data : procedure (cinfo : j_decompress_ptr; num_bytes : long); - resync_to_restart : function (cinfo : j_decompress_ptr; - desired : int) : boolean; - term_source : procedure (cinfo : j_decompress_ptr); - end; - - -{ Memory manager object. - Allocates "small" objects (a few K total), "large" objects (tens of K), - and "really big" objects (virtual arrays with backing store if needed). - The memory manager does not allow individual objects to be freed; rather, - each created object is assigned to a pool, and whole pools can be freed - at once. This is faster and more convenient than remembering exactly what - to free, especially where malloc()/free() are not too speedy. - NB: alloc routines never return NIL. They exit to error_exit if not - successful. } - - - jpeg_memory_mgr = record - { Method pointers } - alloc_small : function (cinfo : j_common_ptr; pool_id : int; - sizeofobject : size_t) : pointer; - alloc_large : function (cinfo : j_common_ptr; pool_id : int; - sizeofobject : size_t) : pointer; {far} - alloc_sarray : function (cinfo : j_common_ptr; pool_id : int; - samplesperrow : JDIMENSION; - numrows : JDIMENSION) : JSAMPARRAY; - - alloc_barray : function (cinfo : j_common_ptr; pool_id : int; - blocksperrow : JDIMENSION; - numrows : JDIMENSION) : JBLOCKARRAY; - - request_virt_sarray : function(cinfo : j_common_ptr; - pool_id : int; - pre_zero : boolean; - samplesperrow : JDIMENSION; - numrows : JDIMENSION; - maxaccess : JDIMENSION) : jvirt_sarray_ptr; - - request_virt_barray : function(cinfo : j_common_ptr; - pool_id : int; - pre_zero : boolean; - blocksperrow : JDIMENSION; - numrows : JDIMENSION; - maxaccess : JDIMENSION) : jvirt_barray_ptr; - - realize_virt_arrays : procedure (cinfo : j_common_ptr); - - access_virt_sarray : function (cinfo : j_common_ptr; - ptr : jvirt_sarray_ptr; - start_row : JDIMENSION; - num_rows : JDIMENSION; - writable : boolean) : JSAMPARRAY; - - access_virt_barray : function (cinfo : j_common_ptr; - ptr : jvirt_barray_ptr; - start_row : JDIMENSION; - num_rows : JDIMENSION; - writable : boolean) : JBLOCKARRAY; - - free_pool : procedure (cinfo : j_common_ptr; pool_id : int); - self_destruct : procedure (cinfo : j_common_ptr); - - { Limit on memory allocation for this JPEG object. (Note that this is - merely advisory, not a guaranteed maximum; it only affects the space - used for virtual-array buffers.) May be changed by outer application - after creating the JPEG object. } - max_memory_to_use : long; - - { Maximum allocation request accepted by alloc_large. } - max_alloc_chunk : long; - end; - -{ Routines that are to be used by both halves of the library are declared - to receive a pointer to this structure. There are no actual instances of - jpeg_common_struct, only of jpeg_compress_struct and jpeg_decompress_struct.} - jpeg_common_struct = record - { Fields common to both master struct types } - err : jpeg_error_mgr_ptr; { Error handler module } - mem : jpeg_memory_mgr_ptr; { Memory manager module } - progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none } - client_data : voidp; { Available for use by application } - is_decompressor : boolean; { so common code can tell which is which } - global_state : int; { for checking call sequence validity } - - { Additional fields follow in an actual jpeg_compress_struct or - jpeg_decompress_struct. All three structs must agree on these - initial fields! (This would be a lot cleaner in C++.) } - end; - - -{ Master record for a compression instance } - - jpeg_compress_struct = record - { Fields shared with jpeg_decompress_struct } - err : jpeg_error_mgr_ptr; { Error handler module } - mem : jpeg_memory_mgr_ptr; { Memory manager module } - progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none } - client_data : voidp; { Available for use by application } - is_decompressor : boolean; { so common code can tell which is which } - global_state : int; { for checking call sequence validity } - - { Destination for compressed data } - dest : jpeg_destination_mgr_ptr; - - { Description of source image --- these fields must be filled in by - outer application before starting compression. in_color_space must - be correct before you can even call jpeg_set_defaults(). } - - - image_width : JDIMENSION; { input image width } - image_height : JDIMENSION; { input image height } - input_components : int; { # of color components in input image } - in_color_space : J_COLOR_SPACE; { colorspace of input image } - - input_gamma : double; { image gamma of input image } - - { Compression parameters --- these fields must be set before calling - jpeg_start_compress(). We recommend calling jpeg_set_defaults() to - initialize everything to reasonable defaults, then changing anything - the application specifically wants to change. That way you won't get - burnt when new parameters are added. Also note that there are several - helper routines to simplify changing parameters. } - - data_precision : int; { bits of precision in image data } - - num_components : int; { # of color components in JPEG image } - jpeg_color_space : J_COLOR_SPACE; { colorspace of JPEG image } - - comp_info : jpeg_component_info_list_ptr; - { comp_info^[i] describes component that appears i'th in SOF } - - quant_tbl_ptrs: Array[0..NUM_QUANT_TBLS-1] of JQUANT_TBL_PTR; - { ptrs to coefficient quantization tables, or NIL if not defined } - - dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR; - ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR; - { ptrs to Huffman coding tables, or NIL if not defined } - - arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables } - arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables } - arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables } - - num_scans : int; { # of entries in scan_info array } - scan_info : jpeg_scan_info_ptr; { script for multi-scan file, or NIL } - { The default value of scan_info is NIL, which causes a single-scan - sequential JPEG file to be emitted. To create a multi-scan file, - set num_scans and scan_info to point to an array of scan definitions. } - - raw_data_in : boolean; { TRUE=caller supplies downsampled data } - arith_code : boolean; { TRUE=arithmetic coding, FALSE=Huffman } - optimize_coding : boolean; { TRUE=optimize entropy encoding parms } - CCIR601_sampling : boolean; { TRUE=first samples are cosited } - smoothing_factor : int; { 1..100, or 0 for no input smoothing } - dct_method : J_DCT_METHOD; { DCT algorithm selector } - - { The restart interval can be specified in absolute MCUs by setting - restart_interval, or in MCU rows by setting restart_in_rows - (in which case the correct restart_interval will be figured - for each scan). } - - restart_interval : uint; { MCUs per restart, or 0 for no restart } - restart_in_rows : int; { if > 0, MCU rows per restart interval } - - { Parameters controlling emission of special markers. } - - write_JFIF_header : boolean; { should a JFIF marker be written? } - JFIF_major_version : UINT8; { What to write for the JFIF version number } - JFIF_minor_version : UINT8; - { These three values are not used by the JPEG code, merely copied } - { into the JFIF APP0 marker. density_unit can be 0 for unknown, } - { 1 for dots/inch, or 2 for dots/cm. Note that the pixel aspect } - { ratio is defined by X_density/Y_density even when density_unit=0. } - density_unit : UINT8; { JFIF code for pixel size units } - X_density : UINT16; { Horizontal pixel density } - Y_density : UINT16; { Vertical pixel density } - write_Adobe_marker : boolean; { should an Adobe marker be written? } - - { State variable: index of next scanline to be written to - jpeg_write_scanlines(). Application may use this to control its - processing loop, e.g., "while (next_scanline < image_height)". } - - next_scanline : JDIMENSION; { 0 .. image_height-1 } - - { Remaining fields are known throughout compressor, but generally - should not be touched by a surrounding application. } - - { These fields are computed during compression startup } - progressive_mode : boolean; { TRUE if scan script uses progressive mode } - max_h_samp_factor : int; { largest h_samp_factor } - max_v_samp_factor : int; { largest v_samp_factor } - - total_iMCU_rows : JDIMENSION; { # of iMCU rows to be input to coef ctlr } - { The coefficient controller receives data in units of MCU rows as defined - for fully interleaved scans (whether the JPEG file is interleaved or not). - There are v_samp_factor * DCTSIZE sample rows of each component in an - "iMCU" (interleaved MCU) row. } - - { These fields are valid during any one scan. - They describe the components and MCUs actually appearing in the scan. } - - comps_in_scan : int; { # of JPEG components in this scan } - cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of jpeg_component_info_ptr; - { cur_comp_info[i]^ describes component that appears i'th in SOS } - - MCUs_per_row : JDIMENSION; { # of MCUs across the image } - MCU_rows_in_scan : JDIMENSION;{ # of MCU rows in the image } - - blocks_in_MCU : int; { # of DCT blocks per MCU } - MCU_membership : Array[0..C_MAX_BLOCKS_IN_MCU-1] of int; - { MCU_membership[i] is index in cur_comp_info of component owning } - { i'th block in an MCU } - - Ss, Se, Ah, Al : int; { progressive JPEG parameters for scan } - - { Links to compression subobjects (methods and private variables of modules) } - master : jpeg_comp_master_ptr; - main : jpeg_c_main_controller_ptr; - prep : jpeg_c_prep_controller_ptr; - coef : jpeg_c_coef_controller_ptr; - marker : jpeg_marker_writer_ptr; - cconvert : jpeg_color_converter_ptr; - downsample : jpeg_downsampler_ptr; - fdct : jpeg_forward_dct_ptr; - entropy : jpeg_entropy_encoder_ptr; - script_space : jpeg_scan_info_ptr; { workspace for jpeg_simple_progression } - script_space_size : int; - end; - - -{ Master record for a decompression instance } - - coef_bits_field = Array[0..DCTSIZE2-1] of int; - coef_bits_ptr = ^coef_bits_field; - coef_bits_ptrfield = Array[0..MAX_COMPS_IN_SCAN-1] of coef_bits_field; - coef_bits_ptrrow = ^coef_bits_ptrfield; - - range_limit_table = array[-(MAXJSAMPLE+1)..4*(MAXJSAMPLE+1) - + CENTERJSAMPLE -1] of JSAMPLE; - range_limit_table_ptr = ^range_limit_table; - - jpeg_decompress_struct = record - { Fields shared with jpeg_compress_struct } - err : jpeg_error_mgr_ptr; { Error handler module } - mem : jpeg_memory_mgr_ptr; { Memory manager module } - progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none } - client_data : voidp; { Available for use by application } - is_decompressor : boolean; { so common code can tell which is which } - global_state : int; { for checking call sequence validity } - - { Source of compressed data } - src : jpeg_source_mgr_ptr; - - { Basic description of image --- filled in by jpeg_read_header(). } - { Application may inspect these values to decide how to process image. } - - image_width : JDIMENSION; { nominal image width (from SOF marker) } - image_height : JDIMENSION; { nominal image height } - num_components : int; { # of color components in JPEG image } - jpeg_color_space : J_COLOR_SPACE; { colorspace of JPEG image } - - { Decompression processing parameters --- these fields must be set before - calling jpeg_start_decompress(). Note that jpeg_read_header() - initializes them to default values. } - - out_color_space : J_COLOR_SPACE; { colorspace for output } - - scale_num, scale_denom : uint ; { fraction by which to scale image } - - output_gamma : double; { image gamma wanted in output } - - buffered_image : boolean; { TRUE=multiple output passes } - raw_data_out : boolean; { TRUE=downsampled data wanted } - - dct_method : J_DCT_METHOD; { IDCT algorithm selector } - do_fancy_upsampling : boolean; { TRUE=apply fancy upsampling } - do_block_smoothing : boolean; { TRUE=apply interblock smoothing } - - quantize_colors : boolean; { TRUE=colormapped output wanted } - { the following are ignored if not quantize_colors: } - dither_mode : J_DITHER_MODE; { type of color dithering to use } - two_pass_quantize : boolean; { TRUE=use two-pass color quantization } - desired_number_of_colors : int; { max # colors to use in created colormap } - { these are significant only in buffered-image mode: } - enable_1pass_quant : boolean; { enable future use of 1-pass quantizer } - enable_external_quant : boolean; { enable future use of external colormap } - enable_2pass_quant : boolean; { enable future use of 2-pass quantizer } - - { Description of actual output image that will be returned to application. - These fields are computed by jpeg_start_decompress(). - You can also use jpeg_calc_output_dimensions() to determine these values - in advance of calling jpeg_start_decompress(). } - - output_width : JDIMENSION; { scaled image width } - output_height: JDIMENSION; { scaled image height } - out_color_components : int; { # of color components in out_color_space } - output_components : int; { # of color components returned } - { output_components is 1 (a colormap index) when quantizing colors; - otherwise it equals out_color_components. } - - rec_outbuf_height : int; { min recommended height of scanline buffer } - { If the buffer passed to jpeg_read_scanlines() is less than this many - rows high, space and time will be wasted due to unnecessary data - copying. Usually rec_outbuf_height will be 1 or 2, at most 4. } - - { When quantizing colors, the output colormap is described by these - fields. The application can supply a colormap by setting colormap - non-NIL before calling jpeg_start_decompress; otherwise a colormap - is created during jpeg_start_decompress or jpeg_start_output. The map - has out_color_components rows and actual_number_of_colors columns. } - - actual_number_of_colors : int; { number of entries in use } - colormap : JSAMPARRAY; { The color map as a 2-D pixel array } - - { State variables: these variables indicate the progress of decompression. - The application may examine these but must not modify them. } - - { Row index of next scanline to be read from jpeg_read_scanlines(). - Application may use this to control its processing loop, e.g., - "while (output_scanline < output_height)". } - - output_scanline : JDIMENSION; { 0 .. output_height-1 } - - { Current input scan number and number of iMCU rows completed in scan. - These indicate the progress of the decompressor input side. } - - input_scan_number : int; { Number of SOS markers seen so far } - input_iMCU_row : JDIMENSION; { Number of iMCU rows completed } - - { The "output scan number" is the notional scan being displayed by the - output side. The decompressor will not allow output scan/row number - to get ahead of input scan/row, but it can fall arbitrarily far behind.} - - output_scan_number : int; { Nominal scan number being displayed } - output_iMCU_row : int; { Number of iMCU rows read } - - { Current progression status. coef_bits[c][i] indicates the precision - with which component c's DCT coefficient i (in zigzag order) is known. - It is -1 when no data has yet been received, otherwise it is the point - transform (shift) value for the most recent scan of the coefficient - (thus, 0 at completion of the progression). - This pointer is NIL when reading a non-progressive file. } - - coef_bits : coef_bits_ptrrow; - { -1 or current Al value for each coef } - - { Internal JPEG parameters --- the application usually need not look at - these fields. Note that the decompressor output side may not use - any parameters that can change between scans. } - - { Quantization and Huffman tables are carried forward across input - datastreams when processing abbreviated JPEG datastreams. } - - quant_tbl_ptrs : Array[0..NUM_QUANT_TBLS-1] of JQUANT_TBL_PTR; - { ptrs to coefficient quantization tables, or NIL if not defined } - - dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR; - ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR; - { ptrs to Huffman coding tables, or NIL if not defined } - - { These parameters are never carried across datastreams, since they - are given in SOF/SOS markers or defined to be reset by SOI. } - - data_precision : int; { bits of precision in image data } - - comp_info : jpeg_component_info_list_ptr; - { comp_info^[i] describes component that appears i'th in SOF } - - progressive_mode : boolean; { TRUE if SOFn specifies progressive mode } - arith_code : boolean; { TRUE=arithmetic coding, FALSE=Huffman } - - arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables } - arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables } - arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables } - - restart_interval : uint; { MCUs per restart interval, or 0 for no restart } - - { These fields record data obtained from optional markers recognized by - the JPEG library. } - - saw_JFIF_marker : boolean; { TRUE iff a JFIF APP0 marker was found } - { Data copied from JFIF marker; only valid if saw_JFIF_marker is TRUE: } - JFIF_major_version : UINT8; { JFIF version number } - JFIF_minor_version : UINT8; - density_unit : UINT8; { JFIF code for pixel size units } - X_density : UINT16; { Horizontal pixel density } - Y_density : UINT16; { Vertical pixel density } - saw_Adobe_marker : boolean; { TRUE iff an Adobe APP14 marker was found } - Adobe_transform : UINT8; { Color transform code from Adobe marker } - - CCIR601_sampling : boolean; { TRUE=first samples are cosited } - - { Aside from the specific data retained from APPn markers known to the - library, the uninterpreted contents of any or all APPn and COM markers - can be saved in a list for examination by the application. } - - marker_list : jpeg_saved_marker_ptr; { Head of list of saved markers } - - { Remaining fields are known throughout decompressor, but generally - should not be touched by a surrounding application. } - - - { These fields are computed during decompression startup } - - max_h_samp_factor : int; { largest h_samp_factor } - max_v_samp_factor : int; { largest v_samp_factor } - - min_DCT_scaled_size : int; { smallest DCT_scaled_size of any component } - - total_iMCU_rows : JDIMENSION; { # of iMCU rows in image } - { The coefficient controller's input and output progress is measured in - units of "iMCU" (interleaved MCU) rows. These are the same as MCU rows - in fully interleaved JPEG scans, but are used whether the scan is - interleaved or not. We define an iMCU row as v_samp_factor DCT block - rows of each component. Therefore, the IDCT output contains - v_samp_factor*DCT_scaled_size sample rows of a component per iMCU row.} - - sample_range_limit : range_limit_table_ptr; { table for fast range-limiting } - - - { These fields are valid during any one scan. - They describe the components and MCUs actually appearing in the scan. - Note that the decompressor output side must not use these fields. } - - comps_in_scan : int; { # of JPEG components in this scan } - cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of jpeg_component_info_ptr; - { cur_comp_info[i]^ describes component that appears i'th in SOS } - - MCUs_per_row : JDIMENSION; { # of MCUs across the image } - MCU_rows_in_scan : JDIMENSION; { # of MCU rows in the image } - - blocks_in_MCU : JDIMENSION; { # of DCT blocks per MCU } - MCU_membership : Array[0..D_MAX_BLOCKS_IN_MCU-1] of int; - { MCU_membership[i] is index in cur_comp_info of component owning } - { i'th block in an MCU } - - Ss, Se, Ah, Al : int; { progressive JPEG parameters for scan } - - { This field is shared between entropy decoder and marker parser. - It is either zero or the code of a JPEG marker that has been - read from the data source, but has not yet been processed. } - - unread_marker : int; - - { Links to decompression subobjects - (methods, private variables of modules) } - - master : jpeg_decomp_master_ptr; - main : jpeg_d_main_controller_ptr; - coef : jpeg_d_coef_controller_ptr; - post : jpeg_d_post_controller_ptr; - inputctl : jpeg_input_controller_ptr; - marker : jpeg_marker_reader_ptr; - entropy : jpeg_entropy_decoder_ptr; - idct : jpeg_inverse_dct_ptr; - upsample : jpeg_upsampler_ptr; - cconvert : jpeg_color_deconverter_ptr; - cquantize : jpeg_color_quantizer_ptr; - end; - -{ Decompression startup: read start of JPEG datastream to see what's there - function jpeg_read_header (cinfo : j_decompress_ptr; - require_image : boolean) : int; - Return value is one of: } -const - JPEG_SUSPENDED = 0; { Suspended due to lack of input data } - JPEG_HEADER_OK = 1; { Found valid image datastream } - JPEG_HEADER_TABLES_ONLY = 2; { Found valid table-specs-only datastream } -{ If you pass require_image = TRUE (normal case), you need not check for - a TABLES_ONLY return code; an abbreviated file will cause an error exit. - JPEG_SUSPENDED is only possible if you use a data source module that can - give a suspension return (the stdio source module doesn't). } - - -{ function jpeg_consume_input (cinfo : j_decompress_ptr) : int; - Return value is one of: } - - JPEG_REACHED_SOS = 1; { Reached start of new scan } - JPEG_REACHED_EOI = 2; { Reached end of image } - JPEG_ROW_COMPLETED = 3; { Completed one iMCU row } - JPEG_SCAN_COMPLETED = 4; { Completed last iMCU row of a scan } - - - - -implementation - -end. +unit imjpeglib; + +{ This file defines the application interface for the JPEG library. + Most applications using the library need only include this file, + and perhaps jerror.h if they want to know the exact error codes. } + +{ Source:jpeglib.h+jpegint.h; Copyright (C) 1991-1998, Thomas G. Lane. } + + +interface + +{$I imjconfig.inc} + +{ First we include the configuration files that record how this + installation of the JPEG library is set up. jconfig.h can be + generated automatically for many systems. jmorecfg.h contains + manual configuration options that most people need not worry about. } + +uses + imjdeferr, + imjmorecfg; { seldom changed options } + +{ Version ID for the JPEG library. + Might be useful for tests like "#if JPEG_LIB_VERSION >= 60". } + + +Const + JPEG_LIB_VERSION = 62; { Version 6b } + + +{ These marker codes are exported since applications and data source modules + are likely to want to use them. } + +const + JPEG_RST0 = $D0; { RST0 marker code } + JPEG_EOI = $D9; { EOI marker code } + JPEG_APP0 = $E0; { APP0 marker code } + JPEG_COM = $FE; { COM marker code } + + +{ Various constants determining the sizes of things. + All of these are specified by the JPEG standard, so don't change them + if you want to be compatible. } + +const + DCTSIZE = 8; { The basic DCT block is 8x8 samples } + DCTSIZE2 = 64; { DCTSIZE squared; # of elements in a block } + NUM_QUANT_TBLS = 4; { Quantization tables are numbered 0..3 } + NUM_HUFF_TBLS = 4; { Huffman tables are numbered 0..3 } + NUM_ARITH_TBLS = 16; { Arith-coding tables are numbered 0..15 } + MAX_COMPS_IN_SCAN = 4; { JPEG limit on # of components in one scan } + MAX_SAMP_FACTOR = 4; { JPEG limit on sampling factors } +{ Unfortunately, some bozo at Adobe saw no reason to be bound by the standard; + the PostScript DCT filter can emit files with many more than 10 blocks/MCU. + If you happen to run across such a file, you can up D_MAX_BLOCKS_IN_MCU + to handle it. We even let you do this from the jconfig.h file. However, + we strongly discourage changing C_MAX_BLOCKS_IN_MCU; just because Adobe + sometimes emits noncompliant files doesn't mean you should too. } + C_MAX_BLOCKS_IN_MCU = 10; { compressor's limit on blocks per MCU } + D_MAX_BLOCKS_IN_MCU = 10; { decompressor's limit on blocks per MCU } + + +{ Data structures for images (arrays of samples and of DCT coefficients). + On 80x86 machines, the image arrays are too big for near pointers, + but the pointer arrays can fit in near memory. } + +type +{ for typecasting } + JSAMPLE_PTR = ^JSAMPLE; + JSAMPROW_PTR = ^JSAMPROW; + JBLOCKROW_PTR = ^JBLOCKROW; + + jTSample = 0..(MaxInt div SIZEOF(JSAMPLE))-1; + JSAMPLE_ARRAY = Array[jTSample] of JSAMPLE; {far} + JSAMPROW = ^JSAMPLE_ARRAY; { ptr to one image row of pixel samples. } + + jTRow = 0..(MaxInt div SIZEOF(JSAMPROW))-1; + JSAMPROW_ARRAY = Array[jTRow] of JSAMPROW; + JSAMPARRAY = ^JSAMPROW_ARRAY; { ptr to some rows (a 2-D sample array) } + + jTArray = 0..(MaxInt div SIZEOF(JSAMPARRAY))-1; + JSAMP_ARRAY = Array[jTArray] of JSAMPARRAY; + JSAMPIMAGE = ^JSAMP_ARRAY; { a 3-D sample array: top index is color } + + JBLOCK = Array[0..DCTSIZE2-1] of JCOEF; { one block of coefficients } + JBLOCK_PTR = ^JBLOCK; + + jTBlockRow = 0..(MaxInt div SIZEOF(JBLOCK))-1; + JBLOCK_ROWS = Array[jTBlockRow] of JBLOCK; + JBLOCKROW = ^JBLOCK_ROWS; {far} { pointer to one row of coefficient blocks } + + + jTBlockArray = 0..(MaxInt div SIZEOF(JBLOCKROW))-1; + JBLOCK_ARRAY = Array[jTBlockArray] of JBLOCKROW; + JBLOCKARRAY = ^JBLOCK_ARRAY; { a 2-D array of coefficient blocks } + + jTBlockImage = 0..(MaxInt div SIZEOF(JBLOCKARRAY))-1; + JBLOCK_IMAGE = Array[jTBlockImage] of JBLOCKARRAY; + JBLOCKIMAGE = ^JBLOCK_IMAGE; { a 3-D array of coefficient blocks } + + jTCoef = 0..(MaxInt div SIZEOF(JCOEF))-1; + JCOEF_ROW = Array[jTCoef] of JCOEF; + JCOEFPTR = ^JCOEF_ROW; {far} { useful in a couple of places } + + +type + jTByte = 0..(MaxInt div SIZEOF(byte))-1; + JByteArray = Array[jTByte] of byte; + JBytePtr = ^JByteArray; +type + byteptr = ^byte; + +{ Types for JPEG compression parameters and working tables. } + + +{ DCT coefficient quantization tables. } + +type + JQUANT_TBL_PTR = ^JQUANT_TBL; + JQUANT_TBL = record + { This array gives the coefficient quantizers in natural array order + (not the zigzag order in which they are stored in a JPEG DQT marker). + CAUTION: IJG versions prior to v6a kept this array in zigzag order. } + quantval : Array[0..DCTSIZE2-1] of UINT16; + { quantization step for each coefficient } + { This field is used only during compression. It's initialized FALSE when + the table is created, and set TRUE when it's been output to the file. + You could suppress output of a table by setting this to TRUE. + (See jpeg_suppress_tables for an example.) } + sent_table : boolean; { TRUE when table has been output } + end; + JQUANT_TBL_FIELD = Array[0..(MaxInt div SizeOf(JQUANT_TBL))-1] of JQUANT_TBL; + +{ Huffman coding tables. } + +type + JHUFF_TBL_PTR = ^JHUFF_TBL; + JHUFF_TBL = record + { These two fields directly represent the contents of a JPEG DHT marker } + bits : Array[0..17-1] of UINT8; { bits[k] = # of symbols with codes of } + { length k bits; bits[0] is unused } + huffval : Array[0..256-1] of UINT8; + { The symbols, in order of incr code length } + { This field is used only during compression. It's initialized FALSE when + the table is created, and set TRUE when it's been output to the file. + You could suppress output of a table by setting this to TRUE. + (See jpeg_suppress_tables for an example.) } + sent_table : boolean; { TRUE when table has been output } + end; + JHUFF_TBL_FIELD = Array[0..(MaxInt div SizeOf(JHUFF_TBL))-1] of JHUFF_TBL; + +{ Declarations for both compression & decompression } + +type + J_BUF_MODE = ( { Operating modes for buffer controllers } + JBUF_PASS_THRU, { Plain stripwise operation } + { Remaining modes require a full-image buffer to have been created } + JBUF_SAVE_SOURCE, { Run source subobject only, save output } + JBUF_CRANK_DEST, { Run dest subobject only, using saved data } + JBUF_SAVE_AND_PASS { Run both subobjects, save output } + ); + +{ Values of global_state field (jdapi.c has some dependencies on ordering!) } +const + CSTATE_START = 100; { after create_compress } + CSTATE_SCANNING = 101; { start_compress done, write_scanlines OK } + CSTATE_RAW_OK = 102; { start_compress done, write_raw_data OK } + CSTATE_WRCOEFS = 103; { jpeg_write_coefficients done } + DSTATE_START = 200; { after create_decompress } + DSTATE_INHEADER = 201; { reading header markers, no SOS yet } + DSTATE_READY = 202; { found SOS, ready for start_decompress } + DSTATE_PRELOAD = 203; { reading multiscan file in start_decompress} + DSTATE_PRESCAN = 204; { performing dummy pass for 2-pass quant } + DSTATE_SCANNING = 205; { start_decompress done, read_scanlines OK } + DSTATE_RAW_OK = 206; { start_decompress done, read_raw_data OK } + DSTATE_BUFIMAGE = 207; { expecting jpeg_start_output } + DSTATE_BUFPOST = 208; { looking for SOS/EOI in jpeg_finish_output } + DSTATE_RDCOEFS = 209; { reading file in jpeg_read_coefficients } + DSTATE_STOPPING = 210; { looking for EOI in jpeg_finish_decompress } + + + +{ Basic info about one component (color channel). } + +type + jpeg_component_info_ptr = ^jpeg_component_info; + jpeg_component_info = record + { These values are fixed over the whole image. } + { For compression, they must be supplied by parameter setup; } + { for decompression, they are read from the SOF marker. } + component_id : int; { identifier for this component (0..255) } + component_index : int; { its index in SOF or cinfo^.comp_info[] } + h_samp_factor : int; { horizontal sampling factor (1..4) } + v_samp_factor : int; { vertical sampling factor (1..4) } + quant_tbl_no : int; { quantization table selector (0..3) } + { These values may vary between scans. } + { For compression, they must be supplied by parameter setup; } + { for decompression, they are read from the SOS marker. } + { The decompressor output side may not use these variables. } + dc_tbl_no : int; { DC entropy table selector (0..3) } + ac_tbl_no : int; { AC entropy table selector (0..3) } + + { Remaining fields should be treated as private by applications. } + + { These values are computed during compression or decompression startup: } + { Component's size in DCT blocks. + Any dummy blocks added to complete an MCU are not counted; therefore + these values do not depend on whether a scan is interleaved or not. } + width_in_blocks : JDIMENSION; + height_in_blocks : JDIMENSION; + { Size of a DCT block in samples. Always DCTSIZE for compression. + For decompression this is the size of the output from one DCT block, + reflecting any scaling we choose to apply during the IDCT step. + Values of 1,2,4,8 are likely to be supported. Note that different + components may receive different IDCT scalings. } + + DCT_scaled_size : int; + { The downsampled dimensions are the component's actual, unpadded number + of samples at the main buffer (preprocessing/compression interface), thus + downsampled_width = ceil(image_width * Hi/Hmax) + and similarly for height. For decompression, IDCT scaling is included, so + downsampled_width = ceil(image_width * Hi/Hmax * DCT_scaled_size/DCTSIZE)} + + downsampled_width : JDIMENSION; { actual width in samples } + downsampled_height : JDIMENSION; { actual height in samples } + { This flag is used only for decompression. In cases where some of the + components will be ignored (eg grayscale output from YCbCr image), + we can skip most computations for the unused components. } + + component_needed : boolean; { do we need the value of this component? } + + { These values are computed before starting a scan of the component. } + { The decompressor output side may not use these variables. } + MCU_width : int; { number of blocks per MCU, horizontally } + MCU_height : int; { number of blocks per MCU, vertically } + MCU_blocks : int; { MCU_width * MCU_height } + MCU_sample_width : int; { MCU width in samples, MCU_width*DCT_scaled_size } + last_col_width : int; { # of non-dummy blocks across in last MCU } + last_row_height : int; { # of non-dummy blocks down in last MCU } + + { Saved quantization table for component; NIL if none yet saved. + See jdinput.c comments about the need for this information. + This field is currently used only for decompression. } + + quant_table : JQUANT_TBL_PTR; + + { Private per-component storage for DCT or IDCT subsystem. } + dct_table : pointer; + end; { record jpeg_component_info } + + jTCinfo = 0..(MaxInt div SizeOf(jpeg_component_info))-1; + jpeg_component_info_array = array[jTCinfo] of jpeg_component_info; + jpeg_component_info_list_ptr = ^jpeg_component_info_array; + + +{ The script for encoding a multiple-scan file is an array of these: } + +type + jpeg_scan_info_ptr = ^jpeg_scan_info; + jpeg_scan_info = record + comps_in_scan : int; { number of components encoded in this scan } + component_index : Array[0..MAX_COMPS_IN_SCAN-1] of int; + { their SOF/comp_info[] indexes } + Ss, Se : int; { progressive JPEG spectral selection parms } + Ah, Al : int; { progressive JPEG successive approx. parms } + end; + +{ The decompressor can save APPn and COM markers in a list of these: } + +type + jpeg_saved_marker_ptr = ^jpeg_marker_struct; + jpeg_marker_struct = record + next : jpeg_saved_marker_ptr; { next in list, or NULL } + marker : UINT8; { marker code: JPEG_COM, or JPEG_APP0+n } + original_length : uint; { # bytes of data in the file } + data_length : uint; { # bytes of data saved at data[] } + data : JOCTET_FIELD_PTR; { the data contained in the marker } + { the marker length word is not counted in data_length or original_length } + end; + +{ Known color spaces. } + +type + J_COLOR_SPACE = ( + JCS_UNKNOWN, { error/unspecified } + JCS_GRAYSCALE, { monochrome } + JCS_RGB, { red/green/blue } + JCS_YCbCr, { Y/Cb/Cr (also known as YUV) } + JCS_CMYK, { C/M/Y/K } + JCS_YCCK { Y/Cb/Cr/K } + ); + +{ DCT/IDCT algorithm options. } + +type + J_DCT_METHOD = ( + JDCT_ISLOW, { slow but accurate integer algorithm } + JDCT_IFAST, { faster, less accurate integer method } + JDCT_FLOAT { floating-point: accurate, fast on fast HW } + ); + +const + JDCT_DEFAULT = JDCT_ISLOW; + JDCT_FASTEST = JDCT_IFAST; + +{ Dithering options for decompression. } + +type + J_DITHER_MODE = ( + JDITHER_NONE, { no dithering } + JDITHER_ORDERED, { simple ordered dither } + JDITHER_FS { Floyd-Steinberg error diffusion dither } + ); + + +const + JPOOL_PERMANENT = 0; { lasts until master record is destroyed } + JPOOL_IMAGE = 1; { lasts until done with image/datastream } + JPOOL_NUMPOOLS = 2; + + +{ "Object" declarations for JPEG modules that may be supplied or called + directly by the surrounding application. + As with all objects in the JPEG library, these structs only define the + publicly visible methods and state variables of a module. Additional + private fields may exist after the public ones. } + + +{ Error handler object } + +const + JMSG_LENGTH_MAX = 200; { recommended size of format_message buffer } + JMSG_STR_PARM_MAX = 80; + +const + TEMP_NAME_LENGTH = 64; { max length of a temporary file's name } +type + TEMP_STRING = string[TEMP_NAME_LENGTH]; + +{$ifdef USE_MSDOS_MEMMGR} { DOS-specific junk } +type + XMSH = ushort; { type of extended-memory handles } + EMSH = ushort; { type of expanded-memory handles } + + handle_union = record + case byte of + 0:(file_handle : short); { DOS file handle if it's a temp file } + 1:(xms_handle : XMSH); { handle if it's a chunk of XMS } + 2:(ems_handle : EMSH); { handle if it's a chunk of EMS } + end; +{$endif} { USE_MSDOS_MEMMGR } + +type + jpeg_error_mgr_ptr = ^jpeg_error_mgr; + jpeg_memory_mgr_ptr = ^jpeg_memory_mgr; + jpeg_progress_mgr_ptr = ^jpeg_progress_mgr; + + +{$ifdef common} +{ Common fields between JPEG compression and decompression master structs. } + err : jpeg_error_mgr_ptr; { Error handler module } + mem : jpeg_memory_mgr_ptr; { Memory manager module } + progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none } + client_data : voidp; { Available for use by application } + is_decompressor : boolean; { so common code can tell which is which } + global_state : int; { for checking call sequence validity } +{$endif} + + j_common_ptr = ^jpeg_common_struct; + j_compress_ptr = ^jpeg_compress_struct; + j_decompress_ptr = ^jpeg_decompress_struct; + + {$ifdef AM_MEMORY_MANAGER} { only jmemmgr.c defines these } + +{ This structure holds whatever state is needed to access a single + backing-store object. The read/write/close method pointers are called + by jmemmgr.c to manipulate the backing-store object; all other fields + are private to the system-dependent backing store routines. } + + + backing_store_ptr = ^backing_store_info; + backing_store_info = record + { Methods for reading/writing/closing this backing-store object } + read_backing_store : procedure (cinfo : j_common_ptr; + info : backing_store_ptr; + buffer_address : pointer; {far} + file_offset : long; + byte_count : long); + write_backing_store : procedure (cinfo : j_common_ptr; + info : backing_store_ptr; + buffer_address : pointer; {far} + file_offset : long; + byte_count : long); + + close_backing_store : procedure (cinfo : j_common_ptr; + info : backing_store_ptr); + + { Private fields for system-dependent backing-store management } + {$ifdef USE_MSDOS_MEMMGR} + { For the MS-DOS manager (jmemdos.c), we need: } + handle : handle_union; { reference to backing-store storage object } + temp_name : TEMP_STRING; { name if it's a file } + {$else} + { For a typical implementation with temp files, we need: } + temp_file : file; { stdio reference to temp file } + temp_name : TEMP_STRING; { name of temp file } + {$endif} + end; + + +{ The control blocks for virtual arrays. + Note that these blocks are allocated in the "small" pool area. + System-dependent info for the associated backing store (if any) is hidden + inside the backing_store_info struct. } + + jvirt_sarray_ptr = ^jvirt_sarray_control; + jvirt_sarray_control = record + mem_buffer : JSAMPARRAY; { => the in-memory buffer } + rows_in_array : JDIMENSION; { total virtual array height } + samplesperrow : JDIMENSION; { width of array (and of memory buffer) } + maxaccess : JDIMENSION; { max rows accessed by access_virt_sarray } + rows_in_mem : JDIMENSION; { height of memory buffer } + rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer } + cur_start_row : JDIMENSION; { first logical row # in the buffer } + first_undef_row : JDIMENSION; { row # of first uninitialized row } + pre_zero : boolean; { pre-zero mode requested? } + dirty : boolean; { do current buffer contents need written? } + b_s_open : boolean; { is backing-store data valid? } + next : jvirt_sarray_ptr; { link to next virtual sarray control block } + b_s_info : backing_store_info; { System-dependent control info } + end; + + jvirt_barray_ptr = ^jvirt_barray_control; + jvirt_barray_control = record + mem_buffer : JBLOCKARRAY; { => the in-memory buffer } + rows_in_array : JDIMENSION; { total virtual array height } + blocksperrow : JDIMENSION; { width of array (and of memory buffer) } + maxaccess : JDIMENSION; { max rows accessed by access_virt_barray } + rows_in_mem : JDIMENSION; { height of memory buffer } + rowsperchunk : JDIMENSION; { allocation chunk size in mem_buffer } + cur_start_row : JDIMENSION; { first logical row # in the buffer } + first_undef_row : JDIMENSION; { row # of first uninitialized row } + pre_zero : boolean; { pre-zero mode requested? } + dirty : boolean; { do current buffer contents need written? } + b_s_open : boolean; { is backing-store data valid? } + next : jvirt_barray_ptr; { link to next virtual barray control block } + b_s_info : backing_store_info; { System-dependent control info } + end; + + {$endif} { AM_MEMORY_MANAGER } + +{ Declarations for compression modules } + +{ Master control module } + jpeg_comp_master_ptr = ^jpeg_comp_master; + jpeg_comp_master = record + prepare_for_pass : procedure(cinfo : j_compress_ptr); + pass_startup : procedure(cinfo : j_compress_ptr); + finish_pass : procedure(cinfo : j_compress_ptr); + + { State variables made visible to other modules } + call_pass_startup : Boolean; { True if pass_startup must be called } + is_last_pass : Boolean; { True during last pass } + end; + +{ Main buffer control (downsampled-data buffer) } + jpeg_c_main_controller_ptr = ^jpeg_c_main_controller; + jpeg_c_main_controller = record + start_pass : procedure(cinfo : j_compress_ptr; pass_mode : J_BUF_MODE); + process_data : procedure(cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + var in_row_ctr : JDIMENSION; + in_rows_avail : JDIMENSION); + end; + +{ Compression preprocessing (downsampling input buffer control) } + jpeg_c_prep_controller_ptr = ^jpeg_c_prep_controller; + jpeg_c_prep_controller = record + start_pass : procedure(cinfo : j_compress_ptr; pass_mode : J_BUF_MODE); + pre_process_data : procedure(cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + var in_row_ctr : JDIMENSION; + in_rows_avail : JDIMENSION; + output_buf : JSAMPIMAGE; + var out_row_group_ctr : JDIMENSION; + out_row_groups_avail : JDIMENSION); + end; + +{ Coefficient buffer control } + jpeg_c_coef_controller_ptr = ^jpeg_c_coef_controller; + jpeg_c_coef_controller = record + start_pass : procedure(cinfo : j_compress_ptr; pass_mode : J_BUF_MODE); + compress_data : function(cinfo : j_compress_ptr; + input_buf : JSAMPIMAGE) : boolean; + end; + +{ Colorspace conversion } + jpeg_color_converter_ptr = ^jpeg_color_converter; + jpeg_color_converter = record + start_pass : procedure(cinfo : j_compress_ptr); + color_convert : procedure(cinfo : j_compress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPIMAGE; + output_row : JDIMENSION; + num_rows : int); + end; + +{ Downsampling } + jpeg_downsampler_ptr = ^jpeg_downsampler; + jpeg_downsampler = record + start_pass : procedure(cinfo : j_compress_ptr); + downsample : procedure(cinfo : j_compress_ptr; + input_buf : JSAMPIMAGE; + in_row_index : JDIMENSION; + output_buf : JSAMPIMAGE; + out_row_group_index: JDIMENSION); + need_context_rows : Boolean; { TRUE if need rows above & below } + end; + +{ Forward DCT (also controls coefficient quantization) } + jpeg_forward_dct_ptr = ^jpeg_forward_dct; + jpeg_forward_dct = record + start_pass : procedure(cinfo : j_compress_ptr); + { perhaps this should be an array??? } + forward_DCT : procedure(cinfo : j_compress_ptr; + compptr : jpeg_component_info_ptr; + sample_data : JSAMPARRAY; + coef_blocks : JBLOCKROW; + start_row : JDIMENSION; + start_col : JDIMENSION; + num_blocks : JDIMENSION); + end; + +{ Entropy encoding } + + jpeg_entropy_encoder_ptr = ^jpeg_entropy_encoder; + jpeg_entropy_encoder = record + start_pass : procedure(cinfo : j_compress_ptr; gather_statistics : boolean); + encode_mcu : function(cinfo : j_compress_ptr; + const MCU_data: array of JBLOCKROW) : boolean; + finish_pass : procedure(cinfo : j_compress_ptr); + end; + +{ Marker writing } + jpeg_marker_writer_ptr = ^jpeg_marker_writer; + jpeg_marker_writer = record + write_file_header : procedure(cinfo : j_compress_ptr); + write_frame_header : procedure(cinfo : j_compress_ptr); + write_scan_header : procedure(cinfo : j_compress_ptr); + write_file_trailer : procedure(cinfo : j_compress_ptr); + write_tables_only : procedure(cinfo : j_compress_ptr); + { These routines are exported to allow insertion of extra markers } + { Probably only COM and APPn markers should be written this way } + write_marker_header : procedure (cinfo : j_compress_ptr; + marker : int; + datalen : uint); + write_marker_byte : procedure (cinfo : j_compress_ptr; val : int); + end; + +{ Declarations for decompression modules } + +{ Master control module } + jpeg_decomp_master_ptr = ^jpeg_decomp_master; + jpeg_decomp_master = record + prepare_for_output_pass : procedure( cinfo : j_decompress_ptr); + finish_output_pass : procedure(cinfo : j_decompress_ptr); + + { State variables made visible to other modules } + is_dummy_pass : Boolean; { True during 1st pass for 2-pass quant } + end; + +{ Input control module } + jpeg_input_controller_ptr = ^jpeg_input_controller; + jpeg_input_controller = record + consume_input : function (cinfo : j_decompress_ptr) : int; + reset_input_controller : procedure(cinfo : j_decompress_ptr); + start_input_pass : procedure(cinfo : j_decompress_ptr); + finish_input_pass : procedure(cinfo : j_decompress_ptr); + + { State variables made visible to other modules } + has_multiple_scans : Boolean; { True if file has multiple scans } + eoi_reached : Boolean; { True when EOI has been consumed } + end; + +{ Main buffer control (downsampled-data buffer) } + + jpeg_d_main_controller_ptr = ^jpeg_d_main_controller; + jpeg_d_main_controller = record + start_pass : procedure(cinfo : j_decompress_ptr; pass_mode : J_BUF_MODE); + process_data : procedure(cinfo : j_decompress_ptr; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); + end; + +{ Coefficient buffer control } + jvirt_barray_tbl = array[0..MAX_COMPONENTS-1] of jvirt_barray_ptr; + jvirt_barray_tbl_ptr = ^jvirt_barray_tbl; + jpeg_d_coef_controller_ptr = ^jpeg_d_coef_controller; + jpeg_d_coef_controller = record + start_input_pass : procedure(cinfo : j_decompress_ptr); + consume_data : function (cinfo : j_decompress_ptr) : int; + start_output_pass : procedure(cinfo : j_decompress_ptr); + decompress_data : function (cinfo : j_decompress_ptr; + output_buf : JSAMPIMAGE) : int; + { Pointer to array of coefficient virtual arrays, or NIL if none } + coef_arrays : jvirt_barray_tbl_ptr; + end; + +{ Decompression postprocessing (color quantization buffer control) } + jpeg_d_post_controller_ptr = ^jpeg_d_post_controller; + jpeg_d_post_controller = record + start_pass : procedure(cinfo : j_decompress_ptr; + pass_mode : J_BUF_MODE); + post_process_data : procedure(cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); + end; + + +{ Routine signature for application-supplied marker processing methods. + Need not pass marker code since it is stored in cinfo^.unread_marker. } + + jpeg_marker_parser_method = function(cinfo : j_decompress_ptr) : boolean; + +{ Marker reading & parsing } + jpeg_marker_reader_ptr = ^jpeg_marker_reader; + jpeg_marker_reader = record + reset_marker_reader : procedure(cinfo : j_decompress_ptr); + { Read markers until SOS or EOI. + Returns same codes as are defined for jpeg_consume_input: + JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. } + + read_markers : function (cinfo : j_decompress_ptr) : int; + { Read a restart marker --- exported for use by entropy decoder only } + read_restart_marker : jpeg_marker_parser_method; + + { State of marker reader --- nominally internal, but applications + supplying COM or APPn handlers might like to know the state. } + + saw_SOI : boolean; { found SOI? } + saw_SOF : boolean; { found SOF? } + next_restart_num : int; { next restart number expected (0-7) } + discarded_bytes : uint; { # of bytes skipped looking for a marker } + end; + +{ Entropy decoding } + jpeg_entropy_decoder_ptr = ^jpeg_entropy_decoder; + jpeg_entropy_decoder = record + start_pass : procedure(cinfo : j_decompress_ptr); + decode_mcu : function(cinfo : j_decompress_ptr; + var MCU_data : array of JBLOCKROW) : boolean; + { This is here to share code between baseline and progressive decoders; } + { other modules probably should not use it } + insufficient_data : BOOLEAN; { set TRUE after emitting warning } + end; + +{ Inverse DCT (also performs dequantization) } + inverse_DCT_method_ptr = procedure(cinfo : j_decompress_ptr; + compptr : jpeg_component_info_ptr; + coef_block : JCOEFPTR; + output_buf : JSAMPARRAY; output_col : JDIMENSION); + + jpeg_inverse_dct_ptr = ^jpeg_inverse_dct; + jpeg_inverse_dct = record + start_pass : procedure(cinfo : j_decompress_ptr); + { It is useful to allow each component to have a separate IDCT method. } + inverse_DCT : Array[0..MAX_COMPONENTS-1] of inverse_DCT_method_ptr; + end; + +{ Upsampling (note that upsampler must also call color converter) } + jpeg_upsampler_ptr = ^jpeg_upsampler; + jpeg_upsampler = record + start_pass : procedure(cinfo : j_decompress_ptr); + upsample : procedure(cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + var in_row_group_ctr : JDIMENSION; { array of } + in_row_groups_avail : JDIMENSION; + output_buf : JSAMPARRAY; + var out_row_ctr : JDIMENSION; + out_rows_avail : JDIMENSION); + + need_context_rows : boolean; { TRUE if need rows above & below } + end; + +{ Colorspace conversion } + jpeg_color_deconverter_ptr = ^jpeg_color_deconverter; + jpeg_color_deconverter = record + start_pass : procedure(cinfo: j_decompress_ptr); + color_convert : procedure(cinfo : j_decompress_ptr; + input_buf : JSAMPIMAGE; + input_row : JDIMENSION; + output_buf : JSAMPARRAY; + num_rows : int); + end; + +{ Color quantization or color precision reduction } + jpeg_color_quantizer_ptr = ^jpeg_color_quantizer; + jpeg_color_quantizer = record + start_pass : procedure(cinfo : j_decompress_ptr; is_pre_scan : boolean); + color_quantize : procedure(cinfo : j_decompress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPARRAY; + num_rows : int); + + finish_pass : procedure(cinfo : j_decompress_ptr); + new_color_map : procedure(cinfo : j_decompress_ptr); + end; + + {int8array = Array[0..8-1] of int;} + int8array = Array[0..8-1] of longint; { for TP FormatStr } + + jpeg_error_mgr = record + { Error exit handler: does not return to caller } + error_exit : procedure (cinfo : j_common_ptr); + { Conditionally emit a trace or warning message } + emit_message : procedure (cinfo : j_common_ptr; msg_level : int); + { Routine that actually outputs a trace or error message } + output_message : procedure (cinfo : j_common_ptr); + { Format a message string for the most recent JPEG error or message } + format_message : procedure (cinfo : j_common_ptr; var buffer : AnsiString); + + { Reset error state variables at start of a new image } + reset_error_mgr : procedure (cinfo : j_common_ptr); + + { The message ID code and any parameters are saved here. + A message can have one string parameter or up to 8 int parameters. } + + msg_code : int; + + msg_parm : record + case byte of + 0:(i : int8array); + 1:(s : string[JMSG_STR_PARM_MAX]); + end; + + { Standard state variables for error facility } + + trace_level : int; { max msg_level that will be displayed } + + { For recoverable corrupt-data errors, we emit a warning message, + but keep going unless emit_message chooses to abort. emit_message + should count warnings in num_warnings. The surrounding application + can check for bad data by seeing if num_warnings is nonzero at the + end of processing. } + + num_warnings : long; { number of corrupt-data warnings } + + { These fields point to the table(s) of error message strings. + An application can change the table pointer to switch to a different + message list (typically, to change the language in which errors are + reported). Some applications may wish to add additional error codes + that will be handled by the JPEG library error mechanism; the second + table pointer is used for this purpose. + + First table includes all errors generated by JPEG library itself. + Error code 0 is reserved for a "no such error string" message. } + + {const char * const * jpeg_message_table; } + jpeg_message_table : ^msg_table; { Library errors } + + last_jpeg_message : J_MESSAGE_CODE; + { Table contains strings 0..last_jpeg_message } + { Second table can be added by application (see cjpeg/djpeg for example). + It contains strings numbered first_addon_message..last_addon_message. } + + {const char * const * addon_message_table; } + addon_message_table : ^msg_table; { Non-library errors } + + first_addon_message : J_MESSAGE_CODE; { code for first string in addon table } + last_addon_message : J_MESSAGE_CODE; { code for last string in addon table } + end; + + +{ Progress monitor object } + + jpeg_progress_mgr = record + progress_monitor : procedure(cinfo : j_common_ptr); + + pass_counter : long; { work units completed in this pass } + pass_limit : long; { total number of work units in this pass } + completed_passes : int; { passes completed so far } + total_passes : int; { total number of passes expected } + end; + + +{ Data destination object for compression } + jpeg_destination_mgr_ptr = ^jpeg_destination_mgr; + jpeg_destination_mgr = record + next_output_byte : JOCTETptr; { => next byte to write in buffer } + free_in_buffer : size_t; { # of byte spaces remaining in buffer } + + init_destination : procedure (cinfo : j_compress_ptr); + empty_output_buffer : function (cinfo : j_compress_ptr) : boolean; + term_destination : procedure (cinfo : j_compress_ptr); + end; + + +{ Data source object for decompression } + + jpeg_source_mgr_ptr = ^jpeg_source_mgr; + jpeg_source_mgr = record + {const JOCTET * next_input_byte;} + next_input_byte : JOCTETptr; { => next byte to read from buffer } + bytes_in_buffer : size_t; { # of bytes remaining in buffer } + + init_source : procedure (cinfo : j_decompress_ptr); + fill_input_buffer : function (cinfo : j_decompress_ptr) : boolean; + skip_input_data : procedure (cinfo : j_decompress_ptr; num_bytes : long); + resync_to_restart : function (cinfo : j_decompress_ptr; + desired : int) : boolean; + term_source : procedure (cinfo : j_decompress_ptr); + end; + + +{ Memory manager object. + Allocates "small" objects (a few K total), "large" objects (tens of K), + and "really big" objects (virtual arrays with backing store if needed). + The memory manager does not allow individual objects to be freed; rather, + each created object is assigned to a pool, and whole pools can be freed + at once. This is faster and more convenient than remembering exactly what + to free, especially where malloc()/free() are not too speedy. + NB: alloc routines never return NIL. They exit to error_exit if not + successful. } + + + jpeg_memory_mgr = record + { Method pointers } + alloc_small : function (cinfo : j_common_ptr; pool_id : int; + sizeofobject : size_t) : pointer; + alloc_large : function (cinfo : j_common_ptr; pool_id : int; + sizeofobject : size_t) : pointer; {far} + alloc_sarray : function (cinfo : j_common_ptr; pool_id : int; + samplesperrow : JDIMENSION; + numrows : JDIMENSION) : JSAMPARRAY; + + alloc_barray : function (cinfo : j_common_ptr; pool_id : int; + blocksperrow : JDIMENSION; + numrows : JDIMENSION) : JBLOCKARRAY; + + request_virt_sarray : function(cinfo : j_common_ptr; + pool_id : int; + pre_zero : boolean; + samplesperrow : JDIMENSION; + numrows : JDIMENSION; + maxaccess : JDIMENSION) : jvirt_sarray_ptr; + + request_virt_barray : function(cinfo : j_common_ptr; + pool_id : int; + pre_zero : boolean; + blocksperrow : JDIMENSION; + numrows : JDIMENSION; + maxaccess : JDIMENSION) : jvirt_barray_ptr; + + realize_virt_arrays : procedure (cinfo : j_common_ptr); + + access_virt_sarray : function (cinfo : j_common_ptr; + ptr : jvirt_sarray_ptr; + start_row : JDIMENSION; + num_rows : JDIMENSION; + writable : boolean) : JSAMPARRAY; + + access_virt_barray : function (cinfo : j_common_ptr; + ptr : jvirt_barray_ptr; + start_row : JDIMENSION; + num_rows : JDIMENSION; + writable : boolean) : JBLOCKARRAY; + + free_pool : procedure (cinfo : j_common_ptr; pool_id : int); + self_destruct : procedure (cinfo : j_common_ptr); + + { Limit on memory allocation for this JPEG object. (Note that this is + merely advisory, not a guaranteed maximum; it only affects the space + used for virtual-array buffers.) May be changed by outer application + after creating the JPEG object. } + max_memory_to_use : long; + + { Maximum allocation request accepted by alloc_large. } + max_alloc_chunk : long; + end; + +{ Routines that are to be used by both halves of the library are declared + to receive a pointer to this structure. There are no actual instances of + jpeg_common_struct, only of jpeg_compress_struct and jpeg_decompress_struct.} + jpeg_common_struct = record + { Fields common to both master struct types } + err : jpeg_error_mgr_ptr; { Error handler module } + mem : jpeg_memory_mgr_ptr; { Memory manager module } + progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none } + client_data : voidp; { Available for use by application } + is_decompressor : boolean; { so common code can tell which is which } + global_state : int; { for checking call sequence validity } + + { Additional fields follow in an actual jpeg_compress_struct or + jpeg_decompress_struct. All three structs must agree on these + initial fields! (This would be a lot cleaner in C++.) } + end; + + +{ Master record for a compression instance } + + jpeg_compress_struct = record + { Fields shared with jpeg_decompress_struct } + err : jpeg_error_mgr_ptr; { Error handler module } + mem : jpeg_memory_mgr_ptr; { Memory manager module } + progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none } + client_data : voidp; { Available for use by application } + is_decompressor : boolean; { so common code can tell which is which } + global_state : int; { for checking call sequence validity } + + { Destination for compressed data } + dest : jpeg_destination_mgr_ptr; + + { Description of source image --- these fields must be filled in by + outer application before starting compression. in_color_space must + be correct before you can even call jpeg_set_defaults(). } + + + image_width : JDIMENSION; { input image width } + image_height : JDIMENSION; { input image height } + input_components : int; { # of color components in input image } + in_color_space : J_COLOR_SPACE; { colorspace of input image } + + input_gamma : double; { image gamma of input image } + + { Compression parameters --- these fields must be set before calling + jpeg_start_compress(). We recommend calling jpeg_set_defaults() to + initialize everything to reasonable defaults, then changing anything + the application specifically wants to change. That way you won't get + burnt when new parameters are added. Also note that there are several + helper routines to simplify changing parameters. } + + data_precision : int; { bits of precision in image data } + + num_components : int; { # of color components in JPEG image } + jpeg_color_space : J_COLOR_SPACE; { colorspace of JPEG image } + + comp_info : jpeg_component_info_list_ptr; + { comp_info^[i] describes component that appears i'th in SOF } + + quant_tbl_ptrs: Array[0..NUM_QUANT_TBLS-1] of JQUANT_TBL_PTR; + { ptrs to coefficient quantization tables, or NIL if not defined } + + dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR; + ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR; + { ptrs to Huffman coding tables, or NIL if not defined } + + arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables } + arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables } + arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables } + + num_scans : int; { # of entries in scan_info array } + scan_info : jpeg_scan_info_ptr; { script for multi-scan file, or NIL } + { The default value of scan_info is NIL, which causes a single-scan + sequential JPEG file to be emitted. To create a multi-scan file, + set num_scans and scan_info to point to an array of scan definitions. } + + raw_data_in : boolean; { TRUE=caller supplies downsampled data } + arith_code : boolean; { TRUE=arithmetic coding, FALSE=Huffman } + optimize_coding : boolean; { TRUE=optimize entropy encoding parms } + CCIR601_sampling : boolean; { TRUE=first samples are cosited } + smoothing_factor : int; { 1..100, or 0 for no input smoothing } + dct_method : J_DCT_METHOD; { DCT algorithm selector } + + { The restart interval can be specified in absolute MCUs by setting + restart_interval, or in MCU rows by setting restart_in_rows + (in which case the correct restart_interval will be figured + for each scan). } + + restart_interval : uint; { MCUs per restart, or 0 for no restart } + restart_in_rows : int; { if > 0, MCU rows per restart interval } + + { Parameters controlling emission of special markers. } + + write_JFIF_header : boolean; { should a JFIF marker be written? } + JFIF_major_version : UINT8; { What to write for the JFIF version number } + JFIF_minor_version : UINT8; + { These three values are not used by the JPEG code, merely copied } + { into the JFIF APP0 marker. density_unit can be 0 for unknown, } + { 1 for dots/inch, or 2 for dots/cm. Note that the pixel aspect } + { ratio is defined by X_density/Y_density even when density_unit=0. } + density_unit : UINT8; { JFIF code for pixel size units } + X_density : UINT16; { Horizontal pixel density } + Y_density : UINT16; { Vertical pixel density } + write_Adobe_marker : boolean; { should an Adobe marker be written? } + + { State variable: index of next scanline to be written to + jpeg_write_scanlines(). Application may use this to control its + processing loop, e.g., "while (next_scanline < image_height)". } + + next_scanline : JDIMENSION; { 0 .. image_height-1 } + + { Remaining fields are known throughout compressor, but generally + should not be touched by a surrounding application. } + + { These fields are computed during compression startup } + progressive_mode : boolean; { TRUE if scan script uses progressive mode } + max_h_samp_factor : int; { largest h_samp_factor } + max_v_samp_factor : int; { largest v_samp_factor } + + total_iMCU_rows : JDIMENSION; { # of iMCU rows to be input to coef ctlr } + { The coefficient controller receives data in units of MCU rows as defined + for fully interleaved scans (whether the JPEG file is interleaved or not). + There are v_samp_factor * DCTSIZE sample rows of each component in an + "iMCU" (interleaved MCU) row. } + + { These fields are valid during any one scan. + They describe the components and MCUs actually appearing in the scan. } + + comps_in_scan : int; { # of JPEG components in this scan } + cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of jpeg_component_info_ptr; + { cur_comp_info[i]^ describes component that appears i'th in SOS } + + MCUs_per_row : JDIMENSION; { # of MCUs across the image } + MCU_rows_in_scan : JDIMENSION;{ # of MCU rows in the image } + + blocks_in_MCU : int; { # of DCT blocks per MCU } + MCU_membership : Array[0..C_MAX_BLOCKS_IN_MCU-1] of int; + { MCU_membership[i] is index in cur_comp_info of component owning } + { i'th block in an MCU } + + Ss, Se, Ah, Al : int; { progressive JPEG parameters for scan } + + { Links to compression subobjects (methods and private variables of modules) } + master : jpeg_comp_master_ptr; + main : jpeg_c_main_controller_ptr; + prep : jpeg_c_prep_controller_ptr; + coef : jpeg_c_coef_controller_ptr; + marker : jpeg_marker_writer_ptr; + cconvert : jpeg_color_converter_ptr; + downsample : jpeg_downsampler_ptr; + fdct : jpeg_forward_dct_ptr; + entropy : jpeg_entropy_encoder_ptr; + script_space : jpeg_scan_info_ptr; { workspace for jpeg_simple_progression } + script_space_size : int; + end; + + +{ Master record for a decompression instance } + + coef_bits_field = Array[0..DCTSIZE2-1] of int; + coef_bits_ptr = ^coef_bits_field; + coef_bits_ptrfield = Array[0..MAX_COMPS_IN_SCAN-1] of coef_bits_field; + coef_bits_ptrrow = ^coef_bits_ptrfield; + + range_limit_table = array[-(MAXJSAMPLE+1)..4*(MAXJSAMPLE+1) + + CENTERJSAMPLE -1] of JSAMPLE; + range_limit_table_ptr = ^range_limit_table; + + jpeg_decompress_struct = record + { Fields shared with jpeg_compress_struct } + err : jpeg_error_mgr_ptr; { Error handler module } + mem : jpeg_memory_mgr_ptr; { Memory manager module } + progress : jpeg_progress_mgr_ptr; { Progress monitor, or NIL if none } + client_data : voidp; { Available for use by application } + is_decompressor : boolean; { so common code can tell which is which } + global_state : int; { for checking call sequence validity } + + { Source of compressed data } + src : jpeg_source_mgr_ptr; + + { Basic description of image --- filled in by jpeg_read_header(). } + { Application may inspect these values to decide how to process image. } + + image_width : JDIMENSION; { nominal image width (from SOF marker) } + image_height : JDIMENSION; { nominal image height } + num_components : int; { # of color components in JPEG image } + jpeg_color_space : J_COLOR_SPACE; { colorspace of JPEG image } + + { Decompression processing parameters --- these fields must be set before + calling jpeg_start_decompress(). Note that jpeg_read_header() + initializes them to default values. } + + out_color_space : J_COLOR_SPACE; { colorspace for output } + + scale_num, scale_denom : uint ; { fraction by which to scale image } + + output_gamma : double; { image gamma wanted in output } + + buffered_image : boolean; { TRUE=multiple output passes } + raw_data_out : boolean; { TRUE=downsampled data wanted } + + dct_method : J_DCT_METHOD; { IDCT algorithm selector } + do_fancy_upsampling : boolean; { TRUE=apply fancy upsampling } + do_block_smoothing : boolean; { TRUE=apply interblock smoothing } + + quantize_colors : boolean; { TRUE=colormapped output wanted } + { the following are ignored if not quantize_colors: } + dither_mode : J_DITHER_MODE; { type of color dithering to use } + two_pass_quantize : boolean; { TRUE=use two-pass color quantization } + desired_number_of_colors : int; { max # colors to use in created colormap } + { these are significant only in buffered-image mode: } + enable_1pass_quant : boolean; { enable future use of 1-pass quantizer } + enable_external_quant : boolean; { enable future use of external colormap } + enable_2pass_quant : boolean; { enable future use of 2-pass quantizer } + + { Description of actual output image that will be returned to application. + These fields are computed by jpeg_start_decompress(). + You can also use jpeg_calc_output_dimensions() to determine these values + in advance of calling jpeg_start_decompress(). } + + output_width : JDIMENSION; { scaled image width } + output_height: JDIMENSION; { scaled image height } + out_color_components : int; { # of color components in out_color_space } + output_components : int; { # of color components returned } + { output_components is 1 (a colormap index) when quantizing colors; + otherwise it equals out_color_components. } + + rec_outbuf_height : int; { min recommended height of scanline buffer } + { If the buffer passed to jpeg_read_scanlines() is less than this many + rows high, space and time will be wasted due to unnecessary data + copying. Usually rec_outbuf_height will be 1 or 2, at most 4. } + + { When quantizing colors, the output colormap is described by these + fields. The application can supply a colormap by setting colormap + non-NIL before calling jpeg_start_decompress; otherwise a colormap + is created during jpeg_start_decompress or jpeg_start_output. The map + has out_color_components rows and actual_number_of_colors columns. } + + actual_number_of_colors : int; { number of entries in use } + colormap : JSAMPARRAY; { The color map as a 2-D pixel array } + + { State variables: these variables indicate the progress of decompression. + The application may examine these but must not modify them. } + + { Row index of next scanline to be read from jpeg_read_scanlines(). + Application may use this to control its processing loop, e.g., + "while (output_scanline < output_height)". } + + output_scanline : JDIMENSION; { 0 .. output_height-1 } + + { Current input scan number and number of iMCU rows completed in scan. + These indicate the progress of the decompressor input side. } + + input_scan_number : int; { Number of SOS markers seen so far } + input_iMCU_row : JDIMENSION; { Number of iMCU rows completed } + + { The "output scan number" is the notional scan being displayed by the + output side. The decompressor will not allow output scan/row number + to get ahead of input scan/row, but it can fall arbitrarily far behind.} + + output_scan_number : int; { Nominal scan number being displayed } + output_iMCU_row : int; { Number of iMCU rows read } + + { Current progression status. coef_bits[c][i] indicates the precision + with which component c's DCT coefficient i (in zigzag order) is known. + It is -1 when no data has yet been received, otherwise it is the point + transform (shift) value for the most recent scan of the coefficient + (thus, 0 at completion of the progression). + This pointer is NIL when reading a non-progressive file. } + + coef_bits : coef_bits_ptrrow; + { -1 or current Al value for each coef } + + { Internal JPEG parameters --- the application usually need not look at + these fields. Note that the decompressor output side may not use + any parameters that can change between scans. } + + { Quantization and Huffman tables are carried forward across input + datastreams when processing abbreviated JPEG datastreams. } + + quant_tbl_ptrs : Array[0..NUM_QUANT_TBLS-1] of JQUANT_TBL_PTR; + { ptrs to coefficient quantization tables, or NIL if not defined } + + dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR; + ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of JHUFF_TBL_PTR; + { ptrs to Huffman coding tables, or NIL if not defined } + + { These parameters are never carried across datastreams, since they + are given in SOF/SOS markers or defined to be reset by SOI. } + + data_precision : int; { bits of precision in image data } + + comp_info : jpeg_component_info_list_ptr; + { comp_info^[i] describes component that appears i'th in SOF } + + progressive_mode : boolean; { TRUE if SOFn specifies progressive mode } + arith_code : boolean; { TRUE=arithmetic coding, FALSE=Huffman } + + arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables } + arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables } + arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables } + + restart_interval : uint; { MCUs per restart interval, or 0 for no restart } + + { These fields record data obtained from optional markers recognized by + the JPEG library. } + + saw_JFIF_marker : boolean; { TRUE iff a JFIF APP0 marker was found } + { Data copied from JFIF marker; only valid if saw_JFIF_marker is TRUE: } + JFIF_major_version : UINT8; { JFIF version number } + JFIF_minor_version : UINT8; + density_unit : UINT8; { JFIF code for pixel size units } + X_density : UINT16; { Horizontal pixel density } + Y_density : UINT16; { Vertical pixel density } + saw_Adobe_marker : boolean; { TRUE iff an Adobe APP14 marker was found } + Adobe_transform : UINT8; { Color transform code from Adobe marker } + + CCIR601_sampling : boolean; { TRUE=first samples are cosited } + + { Aside from the specific data retained from APPn markers known to the + library, the uninterpreted contents of any or all APPn and COM markers + can be saved in a list for examination by the application. } + + marker_list : jpeg_saved_marker_ptr; { Head of list of saved markers } + + { Remaining fields are known throughout decompressor, but generally + should not be touched by a surrounding application. } + + + { These fields are computed during decompression startup } + + max_h_samp_factor : int; { largest h_samp_factor } + max_v_samp_factor : int; { largest v_samp_factor } + + min_DCT_scaled_size : int; { smallest DCT_scaled_size of any component } + + total_iMCU_rows : JDIMENSION; { # of iMCU rows in image } + { The coefficient controller's input and output progress is measured in + units of "iMCU" (interleaved MCU) rows. These are the same as MCU rows + in fully interleaved JPEG scans, but are used whether the scan is + interleaved or not. We define an iMCU row as v_samp_factor DCT block + rows of each component. Therefore, the IDCT output contains + v_samp_factor*DCT_scaled_size sample rows of a component per iMCU row.} + + sample_range_limit : range_limit_table_ptr; { table for fast range-limiting } + + + { These fields are valid during any one scan. + They describe the components and MCUs actually appearing in the scan. + Note that the decompressor output side must not use these fields. } + + comps_in_scan : int; { # of JPEG components in this scan } + cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of jpeg_component_info_ptr; + { cur_comp_info[i]^ describes component that appears i'th in SOS } + + MCUs_per_row : JDIMENSION; { # of MCUs across the image } + MCU_rows_in_scan : JDIMENSION; { # of MCU rows in the image } + + blocks_in_MCU : JDIMENSION; { # of DCT blocks per MCU } + MCU_membership : Array[0..D_MAX_BLOCKS_IN_MCU-1] of int; + { MCU_membership[i] is index in cur_comp_info of component owning } + { i'th block in an MCU } + + Ss, Se, Ah, Al : int; { progressive JPEG parameters for scan } + + { This field is shared between entropy decoder and marker parser. + It is either zero or the code of a JPEG marker that has been + read from the data source, but has not yet been processed. } + + unread_marker : int; + + { Links to decompression subobjects + (methods, private variables of modules) } + + master : jpeg_decomp_master_ptr; + main : jpeg_d_main_controller_ptr; + coef : jpeg_d_coef_controller_ptr; + post : jpeg_d_post_controller_ptr; + inputctl : jpeg_input_controller_ptr; + marker : jpeg_marker_reader_ptr; + entropy : jpeg_entropy_decoder_ptr; + idct : jpeg_inverse_dct_ptr; + upsample : jpeg_upsampler_ptr; + cconvert : jpeg_color_deconverter_ptr; + cquantize : jpeg_color_quantizer_ptr; + end; + +{ Decompression startup: read start of JPEG datastream to see what's there + function jpeg_read_header (cinfo : j_decompress_ptr; + require_image : boolean) : int; + Return value is one of: } +const + JPEG_SUSPENDED = 0; { Suspended due to lack of input data } + JPEG_HEADER_OK = 1; { Found valid image datastream } + JPEG_HEADER_TABLES_ONLY = 2; { Found valid table-specs-only datastream } +{ If you pass require_image = TRUE (normal case), you need not check for + a TABLES_ONLY return code; an abbreviated file will cause an error exit. + JPEG_SUSPENDED is only possible if you use a data source module that can + give a suspension return (the stdio source module doesn't). } + + +{ function jpeg_consume_input (cinfo : j_decompress_ptr) : int; + Return value is one of: } + + JPEG_REACHED_SOS = 1; { Reached start of new scan } + JPEG_REACHED_EOI = 2; { Reached end of image } + JPEG_ROW_COMPLETED = 3; { Completed one iMCU row } + JPEG_SCAN_COMPLETED = 4; { Completed last iMCU row of a scan } + + + + +implementation + +end. diff --git a/Imaging/JpegLib/imjquant1.pas b/Imaging/JpegLib/imjquant1.pas index f15afa0..c935166 100644 --- a/Imaging/JpegLib/imjquant1.pas +++ b/Imaging/JpegLib/imjquant1.pas @@ -1,1009 +1,1009 @@ -unit imjquant1; - -{ This file contains 1-pass color quantization (color mapping) routines. - These routines provide mapping to a fixed color map using equally spaced - color values. Optional Floyd-Steinberg or ordered dithering is available. } - -{ Original: jquant1.c; Copyright (C) 1991-1996, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjpeglib; - -{GLOBAL} -procedure jinit_1pass_quantizer (cinfo : j_decompress_ptr); - -implementation - -uses - imjmorecfg, - imjdeferr, - imjerror, - imjutils; - -{ The main purpose of 1-pass quantization is to provide a fast, if not very - high quality, colormapped output capability. A 2-pass quantizer usually - gives better visual quality; however, for quantized grayscale output this - quantizer is perfectly adequate. Dithering is highly recommended with this - quantizer, though you can turn it off if you really want to. - - In 1-pass quantization the colormap must be chosen in advance of seeing the - image. We use a map consisting of all combinations of Ncolors[i] color - values for the i'th component. The Ncolors[] values are chosen so that - their product, the total number of colors, is no more than that requested. - (In most cases, the product will be somewhat less.) - - Since the colormap is orthogonal, the representative value for each color - component can be determined without considering the other components; - then these indexes can be combined into a colormap index by a standard - N-dimensional-array-subscript calculation. Most of the arithmetic involved - can be precalculated and stored in the lookup table colorindex[]. - colorindex[i][j] maps pixel value j in component i to the nearest - representative value (grid plane) for that component; this index is - multiplied by the array stride for component i, so that the - index of the colormap entry closest to a given pixel value is just - sum( colorindex[component-number][pixel-component-value] ) - Aside from being fast, this scheme allows for variable spacing between - representative values with no additional lookup cost. - - If gamma correction has been applied in color conversion, it might be wise - to adjust the color grid spacing so that the representative colors are - equidistant in linear space. At this writing, gamma correction is not - implemented by jdcolor, so nothing is done here. } - - -{ Declarations for ordered dithering. - - We use a standard 16x16 ordered dither array. The basic concept of ordered - dithering is described in many references, for instance Dale Schumacher's - chapter II.2 of Graphics Gems II (James Arvo, ed. Academic Press, 1991). - In place of Schumacher's comparisons against a "threshold" value, we add a - "dither" value to the input pixel and then round the result to the nearest - output value. The dither value is equivalent to (0.5 - threshold) times - the distance between output values. For ordered dithering, we assume that - the output colors are equally spaced; if not, results will probably be - worse, since the dither may be too much or too little at a given point. - - The normal calculation would be to form pixel value + dither, range-limit - this to 0..MAXJSAMPLE, and then index into the colorindex table as usual. - We can skip the separate range-limiting step by extending the colorindex - table in both directions. } - - -const - ODITHER_SIZE = 16; { dimension of dither matrix } -{ NB: if ODITHER_SIZE is not a power of 2, ODITHER_MASK uses will break } - ODITHER_CELLS = (ODITHER_SIZE*ODITHER_SIZE); { # cells in matrix } - ODITHER_MASK = (ODITHER_SIZE-1); { mask for wrapping around counters } - -type - ODITHER_vector = Array[0..ODITHER_SIZE-1] of int; - ODITHER_MATRIX = Array[0..ODITHER_SIZE-1] of ODITHER_vector; - {ODITHER_MATRIX_PTR = ^array[0..ODITHER_SIZE-1] of int;} - ODITHER_MATRIX_PTR = ^ODITHER_MATRIX; - -const - base_dither_matrix : Array[0..ODITHER_SIZE-1,0..ODITHER_SIZE-1] of UINT8 - = ( - { Bayer's order-4 dither array. Generated by the code given in - Stephen Hawley's article "Ordered Dithering" in Graphics Gems I. - The values in this array must range from 0 to ODITHER_CELLS-1. } - - ( 0,192, 48,240, 12,204, 60,252, 3,195, 51,243, 15,207, 63,255 ), - ( 128, 64,176,112,140, 76,188,124,131, 67,179,115,143, 79,191,127 ), - ( 32,224, 16,208, 44,236, 28,220, 35,227, 19,211, 47,239, 31,223 ), - ( 160, 96,144, 80,172,108,156, 92,163, 99,147, 83,175,111,159, 95 ), - ( 8,200, 56,248, 4,196, 52,244, 11,203, 59,251, 7,199, 55,247 ), - ( 136, 72,184,120,132, 68,180,116,139, 75,187,123,135, 71,183,119 ), - ( 40,232, 24,216, 36,228, 20,212, 43,235, 27,219, 39,231, 23,215 ), - ( 168,104,152, 88,164,100,148, 84,171,107,155, 91,167,103,151, 87 ), - ( 2,194, 50,242, 14,206, 62,254, 1,193, 49,241, 13,205, 61,253 ), - ( 130, 66,178,114,142, 78,190,126,129, 65,177,113,141, 77,189,125 ), - ( 34,226, 18,210, 46,238, 30,222, 33,225, 17,209, 45,237, 29,221 ), - ( 162, 98,146, 82,174,110,158, 94,161, 97,145, 81,173,109,157, 93 ), - ( 10,202, 58,250, 6,198, 54,246, 9,201, 57,249, 5,197, 53,245 ), - ( 138, 74,186,122,134, 70,182,118,137, 73,185,121,133, 69,181,117 ), - ( 42,234, 26,218, 38,230, 22,214, 41,233, 25,217, 37,229, 21,213 ), - ( 170,106,154, 90,166,102,150, 86,169,105,153, 89,165,101,149, 85 ) - ); - - -{ Declarations for Floyd-Steinberg dithering. - - Errors are accumulated into the array fserrors[], at a resolution of - 1/16th of a pixel count. The error at a given pixel is propagated - to its not-yet-processed neighbors using the standard F-S fractions, - ... (here) 7/16 - 3/16 5/16 1/16 - We work left-to-right on even rows, right-to-left on odd rows. - - We can get away with a single array (holding one row's worth of errors) - by using it to store the current row's errors at pixel columns not yet - processed, but the next row's errors at columns already processed. We - need only a few extra variables to hold the errors immediately around the - current column. (If we are lucky, those variables are in registers, but - even if not, they're probably cheaper to access than array elements are.) - - The fserrors[] array is indexed [component#][position]. - We provide (#columns + 2) entries per component; the extra entry at each - end saves us from special-casing the first and last pixels. - - Note: on a wide image, we might not have enough room in a PC's near data - segment to hold the error array; so it is allocated with alloc_large. } - -{$ifdef BITS_IN_JSAMPLE_IS_8} -type - FSERROR = INT16; { 16 bits should be enough } - LOCFSERROR = int; { use 'int' for calculation temps } -{$else} -type - FSERROR = INT32; { may need more than 16 bits } - LOCFSERROR = INT32; { be sure calculation temps are big enough } -{$endif} - -type - jFSError = 0..(MaxInt div SIZEOF(FSERROR))-1; - FS_ERROR_FIELD = array[jFSError] of FSERROR; - FS_ERROR_FIELD_PTR = ^FS_ERROR_FIELD;{far} - { pointer to error array (in FAR storage!) } - FSERRORPTR = ^FSERROR; - - -{ Private subobject } - -const - MAX_Q_COMPS = 4; { max components I can handle } - -type - my_cquantize_ptr = ^my_cquantizer; - my_cquantizer = record - pub : jpeg_color_quantizer; { public fields } - - { Initially allocated colormap is saved here } - sv_colormap : JSAMPARRAY; { The color map as a 2-D pixel array } - sv_actual : int; { number of entries in use } - - colorindex : JSAMPARRAY; { Precomputed mapping for speed } - { colorindex[i][j] = index of color closest to pixel value j in component i, - premultiplied as described above. Since colormap indexes must fit into - JSAMPLEs, the entries of this array will too. } - - is_padded : boolean; { is the colorindex padded for odither? } - - Ncolors : array[0..MAX_Q_COMPS-1] of int; - { # of values alloced to each component } - - { Variables for ordered dithering } - row_index : int; { cur row's vertical index in dither matrix } - odither : array[0..MAX_Q_COMPS-1] of ODITHER_MATRIX_PTR; - { one dither array per component } - { Variables for Floyd-Steinberg dithering } - fserrors : array[0..MAX_Q_COMPS-1] of FS_ERROR_FIELD_PTR; - { accumulated errors } - on_odd_row : boolean; { flag to remember which row we are on } - end; - - -{ Policy-making subroutines for create_colormap and create_colorindex. - These routines determine the colormap to be used. The rest of the module - only assumes that the colormap is orthogonal. - - * select_ncolors decides how to divvy up the available colors - among the components. - * output_value defines the set of representative values for a component. - * largest_input_value defines the mapping from input values to - representative values for a component. - Note that the latter two routines may impose different policies for - different components, though this is not currently done. } - - - -{LOCAL} -function select_ncolors (cinfo : j_decompress_ptr; - var Ncolors : array of int) : int; -{ Determine allocation of desired colors to components, } -{ and fill in Ncolors[] array to indicate choice. } -{ Return value is total number of colors (product of Ncolors[] values). } -var - nc : int; - max_colors : int; - total_colors, iroot, i, j : int; - changed : boolean; - temp : long; -const - RGB_order:array[0..2] of int = (RGB_GREEN, RGB_RED, RGB_BLUE); -begin - nc := cinfo^.out_color_components; { number of color components } - max_colors := cinfo^.desired_number_of_colors; - - { We can allocate at least the nc'th root of max_colors per component. } - { Compute floor(nc'th root of max_colors). } - iroot := 1; - repeat - Inc(iroot); - temp := iroot; { set temp = iroot ** nc } - for i := 1 to pred(nc) do - temp := temp * iroot; - until (temp > long(max_colors)); { repeat till iroot exceeds root } - Dec(iroot); { now iroot = floor(root) } - - { Must have at least 2 color values per component } - if (iroot < 2) then - ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_FEW_COLORS, int(temp)); - - { Initialize to iroot color values for each component } - total_colors := 1; - for i := 0 to pred(nc) do - begin - Ncolors[i] := iroot; - total_colors := total_colors * iroot; - end; - - { We may be able to increment the count for one or more components without - exceeding max_colors, though we know not all can be incremented. - Sometimes, the first component can be incremented more than once! - (Example: for 16 colors, we start at 2*2*2, go to 3*2*2, then 4*2*2.) - In RGB colorspace, try to increment G first, then R, then B. } - - repeat - changed := FALSE; - for i := 0 to pred(nc) do - begin - if cinfo^.out_color_space = JCS_RGB then - j := RGB_order[i] - else - j := i; - { calculate new total_colors if Ncolors[j] is incremented } - temp := total_colors div Ncolors[j]; - temp := temp * (Ncolors[j]+1); { done in long arith to avoid oflo } - if (temp > long(max_colors)) then - break; { won't fit, done with this pass } - Inc(Ncolors[j]); { OK, apply the increment } - total_colors := int(temp); - changed := TRUE; - end; - until not changed; - - select_ncolors := total_colors; -end; - - -{LOCAL} -function output_value (cinfo : j_decompress_ptr; - ci : int; j : int; maxj : int) : int; -{ Return j'th output value, where j will range from 0 to maxj } -{ The output values must fall in 0..MAXJSAMPLE in increasing order } -begin - { We always provide values 0 and MAXJSAMPLE for each component; - any additional values are equally spaced between these limits. - (Forcing the upper and lower values to the limits ensures that - dithering can't produce a color outside the selected gamut.) } - - output_value := int (( INT32(j) * MAXJSAMPLE + maxj div 2) div maxj); -end; - - -{LOCAL} -function largest_input_value (cinfo : j_decompress_ptr; - ci : int; j : int; maxj : int) : int; -{ Return largest input value that should map to j'th output value } -{ Must have largest(j=0) >= 0, and largest(j=maxj) >= MAXJSAMPLE } -begin - { Breakpoints are halfway between values returned by output_value } - largest_input_value := int (( INT32(2*j + 1) * MAXJSAMPLE + - maxj) div (2*maxj)); -end; - - -{ Create the colormap. } - -{LOCAL} -procedure create_colormap (cinfo : j_decompress_ptr); -var - cquantize : my_cquantize_ptr; - colormap : JSAMPARRAY; { Created colormap } - - total_colors : int; { Number of distinct output colors } - i,j,k, nci, blksize, blkdist, ptr, val : int; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - - { Select number of colors for each component } - total_colors := select_ncolors(cinfo, cquantize^.Ncolors); - - { Report selected color counts } - {$IFDEF DEBUG} - if (cinfo^.out_color_components = 3) then - TRACEMS4(j_common_ptr(cinfo), 1, JTRC_QUANT_3_NCOLORS, - total_colors, cquantize^.Ncolors[0], - cquantize^.Ncolors[1], cquantize^.Ncolors[2]) - else - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_QUANT_NCOLORS, total_colors); - {$ENDIF} - - { Allocate and fill in the colormap. } - { The colors are ordered in the map in standard row-major order, } - { i.e. rightmost (highest-indexed) color changes most rapidly. } - - colormap := cinfo^.mem^.alloc_sarray( - j_common_ptr(cinfo), JPOOL_IMAGE, - JDIMENSION(total_colors), JDIMENSION(cinfo^.out_color_components)); - - { blksize is number of adjacent repeated entries for a component } - { blkdist is distance between groups of identical entries for a component } - blkdist := total_colors; - - for i := 0 to pred(cinfo^.out_color_components) do - begin - { fill in colormap entries for i'th color component } - nci := cquantize^.Ncolors[i]; { # of distinct values for this color } - blksize := blkdist div nci; - for j := 0 to pred(nci) do - begin - { Compute j'th output value (out of nci) for component } - val := output_value(cinfo, i, j, nci-1); - { Fill in all colormap entries that have this value of this component } - ptr := j * blksize; - while (ptr < total_colors) do - begin - { fill in blksize entries beginning at ptr } - for k := 0 to pred(blksize) do - colormap^[i]^[ptr+k] := JSAMPLE(val); - - Inc(ptr, blkdist); - end; - end; - blkdist := blksize; { blksize of this color is blkdist of next } - end; - - { Save the colormap in private storage, - where it will survive color quantization mode changes. } - - cquantize^.sv_colormap := colormap; - cquantize^.sv_actual := total_colors; -end; - -{ Create the color index table. } - -{LOCAL} -procedure create_colorindex (cinfo : j_decompress_ptr); -var - cquantize : my_cquantize_ptr; - indexptr, - help_indexptr : JSAMPROW; { for negative offsets } - i,j,k, nci, blksize, val, pad : int; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - { For ordered dither, we pad the color index tables by MAXJSAMPLE in - each direction (input index values can be -MAXJSAMPLE .. 2*MAXJSAMPLE). - This is not necessary in the other dithering modes. However, we - flag whether it was done in case user changes dithering mode. } - - if (cinfo^.dither_mode = JDITHER_ORDERED) then - begin - pad := MAXJSAMPLE*2; - cquantize^.is_padded := TRUE; - end - else - begin - pad := 0; - cquantize^.is_padded := FALSE; - end; - - cquantize^.colorindex := cinfo^.mem^.alloc_sarray - (j_common_ptr(cinfo), JPOOL_IMAGE, - JDIMENSION(MAXJSAMPLE+1 + pad), - JDIMENSION(cinfo^.out_color_components)); - - { blksize is number of adjacent repeated entries for a component } - blksize := cquantize^.sv_actual; - - for i := 0 to pred(cinfo^.out_color_components) do - begin - { fill in colorindex entries for i'th color component } - nci := cquantize^.Ncolors[i]; { # of distinct values for this color } - blksize := blksize div nci; - - { adjust colorindex pointers to provide padding at negative indexes. } - if (pad <> 0) then - Inc(JSAMPLE_PTR(cquantize^.colorindex^[i]), MAXJSAMPLE); - - { in loop, val = index of current output value, } - { and k = largest j that maps to current val } - indexptr := cquantize^.colorindex^[i]; - val := 0; - k := largest_input_value(cinfo, i, 0, nci-1); - for j := 0 to MAXJSAMPLE do - begin - while (j > k) do { advance val if past boundary } - begin - Inc(val); - k := largest_input_value(cinfo, i, val, nci-1); - end; - { premultiply so that no multiplication needed in main processing } - indexptr^[j] := JSAMPLE (val * blksize); - end; - { Pad at both ends if necessary } - if (pad <> 0) then - begin - help_indexptr := indexptr; - { adjust the help pointer to avoid negative offsets } - Dec(JSAMPLE_PTR(help_indexptr), MAXJSAMPLE); - - for j := 1 to MAXJSAMPLE do - begin - {indexptr^[-j] := indexptr^[0];} - help_indexptr^[MAXJSAMPLE-j] := indexptr^[0]; - indexptr^[MAXJSAMPLE+j] := indexptr^[MAXJSAMPLE]; - end; - end; - end; -end; - - -{ Create an ordered-dither array for a component having ncolors - distinct output values. } - -{LOCAL} -function make_odither_array (cinfo : j_decompress_ptr; - ncolors : int) : ODITHER_MATRIX_PTR; -var - odither : ODITHER_MATRIX_PTR; - j, k : int; - num, den : INT32; -begin - odither := ODITHER_MATRIX_PTR ( - cinfo^.mem^.alloc_small(j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(ODITHER_MATRIX))); - { The inter-value distance for this color is MAXJSAMPLE/(ncolors-1). - Hence the dither value for the matrix cell with fill order f - (f=0..N-1) should be (N-1-2*f)/(2*N) * MAXJSAMPLE/(ncolors-1). - On 16-bit-int machine, be careful to avoid overflow. } - - den := 2 * ODITHER_CELLS * ( INT32(ncolors - 1)); - for j := 0 to pred(ODITHER_SIZE) do - begin - for k := 0 to pred(ODITHER_SIZE) do - begin - num := ( INT32(ODITHER_CELLS-1 - 2*( int(base_dither_matrix[j][k])))) - * MAXJSAMPLE; - { Ensure round towards zero despite C's lack of consistency - about rounding negative values in integer division... } - - if num<0 then - odither^[j][k] := int (-((-num) div den)) - else - odither^[j][k] := int (num div den); - end; - end; - make_odither_array := odither; -end; - - -{ Create the ordered-dither tables. - Components having the same number of representative colors may - share a dither table. } - -{LOCAL} -procedure create_odither_tables (cinfo : j_decompress_ptr); -var - cquantize : my_cquantize_ptr; - odither : ODITHER_MATRIX_PTR; - i, j, nci : int; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - - for i := 0 to pred(cinfo^.out_color_components) do - begin - nci := cquantize^.Ncolors[i]; { # of distinct values for this color } - odither := NIL; { search for matching prior component } - for j := 0 to pred(i) do - begin - if (nci = cquantize^.Ncolors[j]) then - begin - odither := cquantize^.odither[j]; - break; - end; - end; - if (odither = NIL) then { need a new table? } - odither := make_odither_array(cinfo, nci); - cquantize^.odither[i] := odither; - end; -end; - - -{ Map some rows of pixels to the output colormapped representation. } - -{METHODDEF} -procedure color_quantize (cinfo : j_decompress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPARRAY; - num_rows : int); -{ General case, no dithering } -var - cquantize : my_cquantize_ptr; - colorindex : JSAMPARRAY; - pixcode, ci : int; {register} - ptrin, ptrout : JSAMPLE_PTR; {register} - row : int; - col : JDIMENSION; - width : JDIMENSION; - nc : int; {register} -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - colorindex := cquantize^.colorindex; - width := cinfo^.output_width; - nc := cinfo^.out_color_components; - - for row := 0 to pred(num_rows) do - begin - ptrin := JSAMPLE_PTR(input_buf^[row]); - ptrout := JSAMPLE_PTR(output_buf^[row]); - for col := pred(width) downto 0 do - begin - pixcode := 0; - for ci := 0 to pred(nc) do - begin - Inc(pixcode, GETJSAMPLE(colorindex^[ci]^[GETJSAMPLE(ptrin^)]) ); - Inc(ptrin); - end; - ptrout^ := JSAMPLE (pixcode); - Inc(ptrout); - end; - end; -end; - - -{METHODDEF} -procedure color_quantize3 (cinfo : j_decompress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPARRAY; - num_rows : int); -{ Fast path for out_color_components=3, no dithering } -var - cquantize : my_cquantize_ptr; - pixcode : int; {register} - ptrin, ptrout : JSAMPLE_PTR; {register} - colorindex0 : JSAMPROW; - colorindex1 : JSAMPROW; - colorindex2 : JSAMPROW; - row : int; - col : JDIMENSION; - width : JDIMENSION; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - colorindex0 := (cquantize^.colorindex)^[0]; - colorindex1 := (cquantize^.colorindex)^[1]; - colorindex2 := (cquantize^.colorindex)^[2]; - width := cinfo^.output_width; - - for row := 0 to pred(num_rows) do - begin - ptrin := JSAMPLE_PTR(input_buf^[row]); - ptrout := JSAMPLE_PTR(output_buf^[row]); - for col := pred(width) downto 0 do - begin - pixcode := GETJSAMPLE((colorindex0)^[GETJSAMPLE(ptrin^)]); - Inc(ptrin); - Inc( pixcode, GETJSAMPLE((colorindex1)^[GETJSAMPLE(ptrin^)]) ); - Inc(ptrin); - Inc( pixcode, GETJSAMPLE((colorindex2)^[GETJSAMPLE(ptrin^)]) ); - Inc(ptrin); - ptrout^ := JSAMPLE (pixcode); - Inc(ptrout); - end; - end; -end; - - -{METHODDEF} -procedure quantize_ord_dither (cinfo : j_decompress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPARRAY; - num_rows : int); -{ General case, with ordered dithering } -var - cquantize : my_cquantize_ptr; - input_ptr, {register} - output_ptr : JSAMPLE_PTR; {register} - colorindex_ci : JSAMPROW; - dither : ^ODITHER_vector; { points to active row of dither matrix } - row_index, col_index : int; { current indexes into dither matrix } - nc : int; - ci : int; - row : int; - col : JDIMENSION; - width : JDIMENSION; -var - pad_offset : int; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - nc := cinfo^.out_color_components; - width := cinfo^.output_width; - - { Nomssi: work around negative offset } - if my_cquantize_ptr (cinfo^.cquantize)^.is_padded then - pad_offset := MAXJSAMPLE - else - pad_offset := 0; - - for row := 0 to pred(num_rows) do - begin - { Initialize output values to 0 so can process components separately } - jzero_far( {far} pointer(output_buf^[row]), - size_t(width * SIZEOF(JSAMPLE))); - row_index := cquantize^.row_index; - for ci := 0 to pred(nc) do - begin - input_ptr := JSAMPLE_PTR(@ input_buf^[row]^[ci]); - output_ptr := JSAMPLE_PTR(output_buf^[row]); - colorindex_ci := cquantize^.colorindex^[ci]; - { Nomssi } - Dec(JSAMPLE_PTR(colorindex_ci), pad_offset); - - dither := @(cquantize^.odither[ci]^[row_index]); - col_index := 0; - - for col := pred(width) downto 0 do - begin - { Form pixel value + dither, range-limit to 0..MAXJSAMPLE, - select output value, accumulate into output code for this pixel. - Range-limiting need not be done explicitly, as we have extended - the colorindex table to produce the right answers for out-of-range - inputs. The maximum dither is +- MAXJSAMPLE; this sets the - required amount of padding. } - - Inc(output_ptr^, - colorindex_ci^[GETJSAMPLE(input_ptr^)+ pad_offset + - dither^[col_index]]); - Inc(output_ptr); - Inc(input_ptr, nc); - col_index := (col_index + 1) and ODITHER_MASK; - end; - end; - { Advance row index for next row } - row_index := (row_index + 1) and ODITHER_MASK; - cquantize^.row_index := row_index; - end; -end; - -{METHODDEF} -procedure quantize3_ord_dither (cinfo : j_decompress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPARRAY; - num_rows : int); -{ Fast path for out_color_components=3, with ordered dithering } -var - cquantize : my_cquantize_ptr; - pixcode : int; {register} - input_ptr : JSAMPLE_PTR; {register} - output_ptr : JSAMPLE_PTR; {register} - colorindex0 : JSAMPROW; - colorindex1 : JSAMPROW; - colorindex2 : JSAMPROW; - dither0 : ^ODITHER_vector; { points to active row of dither matrix } - dither1 : ^ODITHER_vector; - dither2 : ^ODITHER_vector; - row_index, col_index : int; { current indexes into dither matrix } - row : int; - col : JDIMENSION; - width : JDIMENSION; -var - pad_offset : int; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - colorindex0 := (cquantize^.colorindex)^[0]; - colorindex1 := (cquantize^.colorindex)^[1]; - colorindex2 := (cquantize^.colorindex)^[2]; - width := cinfo^.output_width; - - { Nomssi: work around negative offset } - if my_cquantize_ptr (cinfo^.cquantize)^.is_padded then - pad_offset := MAXJSAMPLE - else - pad_offset := 0; - - Dec(JSAMPLE_PTR(colorindex0), pad_offset); - Dec(JSAMPLE_PTR(colorindex1), pad_offset); - Dec(JSAMPLE_PTR(colorindex2), pad_offset); - - for row := 0 to pred(num_rows) do - begin - row_index := cquantize^.row_index; - input_ptr := JSAMPLE_PTR(input_buf^[row]); - output_ptr := JSAMPLE_PTR(output_buf^[row]); - dither0 := @(cquantize^.odither[0]^[row_index]); - dither1 := @(cquantize^.odither[1]^[row_index]); - dither2 := @(cquantize^.odither[2]^[row_index]); - col_index := 0; - - - for col := pred(width) downto 0 do - begin - pixcode := GETJSAMPLE(colorindex0^[GETJSAMPLE(input_ptr^) + pad_offset - + dither0^[col_index]]); - Inc(input_ptr); - Inc(pixcode, GETJSAMPLE(colorindex1^[GETJSAMPLE(input_ptr^) + pad_offset - + dither1^[col_index]])); - Inc(input_ptr); - Inc(pixcode, GETJSAMPLE(colorindex2^[GETJSAMPLE(input_ptr^) + pad_offset - + dither2^[col_index]])); - Inc(input_ptr); - output_ptr^ := JSAMPLE (pixcode); - Inc(output_ptr); - col_index := (col_index + 1) and ODITHER_MASK; - end; - row_index := (row_index + 1) and ODITHER_MASK; - cquantize^.row_index := row_index; - end; -end; - - -{METHODDEF} -procedure quantize_fs_dither (cinfo : j_decompress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPARRAY; - num_rows : int); -{ General case, with Floyd-Steinberg dithering } -var - cquantize : my_cquantize_ptr; - cur : LOCFSERROR; {register} { current error or pixel value } - belowerr : LOCFSERROR; { error for pixel below cur } - bpreverr : LOCFSERROR; { error for below/prev col } - bnexterr : LOCFSERROR; { error for below/next col } - delta : LOCFSERROR; - prev_errorptr, - errorptr : FSERRORPTR; {register} { => fserrors[] at column before current } - input_ptr, {register} - output_ptr : JSAMPLE_PTR; {register} - colorindex_ci : JSAMPROW; - colormap_ci : JSAMPROW; - pixcode : int; - nc : int; - dir : int; { 1 for left-to-right, -1 for right-to-left } - dirnc : int; { dir * nc } - ci : int; - row : int; - col : JDIMENSION; - width : JDIMENSION; - range_limit : range_limit_table_ptr; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - nc := cinfo^.out_color_components; - width := cinfo^.output_width; - range_limit := cinfo^.sample_range_limit; - - for row := 0 to pred(num_rows) do - begin - { Initialize output values to 0 so can process components separately } - jzero_far( (output_buf)^[row], - size_t(width * SIZEOF(JSAMPLE))); - for ci := 0 to pred(nc) do - begin - input_ptr := JSAMPLE_PTR(@ input_buf^[row]^[ci]); - output_ptr := JSAMPLE_PTR(output_buf^[row]); - errorptr := FSERRORPTR(cquantize^.fserrors[ci]); { => entry before first column } - if (cquantize^.on_odd_row) then - begin - { work right to left in this row } - Inc(input_ptr, (width-1) * JDIMENSION(nc)); { so point to rightmost pixel } - Inc(output_ptr, width-1); - dir := -1; - dirnc := -nc; - Inc(errorptr, (width+1)); { => entry after last column } - end - else - begin - { work left to right in this row } - dir := 1; - dirnc := nc; - {errorptr := cquantize^.fserrors[ci];} - end; - - colorindex_ci := cquantize^.colorindex^[ci]; - - colormap_ci := (cquantize^.sv_colormap)^[ci]; - { Preset error values: no error propagated to first pixel from left } - cur := 0; - { and no error propagated to row below yet } - belowerr := 0; - bpreverr := 0; - - for col := pred(width) downto 0 do - begin - prev_errorptr := errorptr; - Inc(errorptr, dir); { advance errorptr to current column } - - { cur holds the error propagated from the previous pixel on the - current line. Add the error propagated from the previous line - to form the complete error correction term for this pixel, and - round the error term (which is expressed * 16) to an integer. - RIGHT_SHIFT rounds towards minus infinity, so adding 8 is correct - for either sign of the error value. - Note: errorptr points to *previous* column's array entry. } - - cur := (cur + errorptr^ + 8) div 16; - - { Form pixel value + error, and range-limit to 0..MAXJSAMPLE. - The maximum error is +- MAXJSAMPLE; this sets the required size - of the range_limit array. } - - Inc( cur, GETJSAMPLE(input_ptr^)); - cur := GETJSAMPLE(range_limit^[cur]); - { Select output value, accumulate into output code for this pixel } - pixcode := GETJSAMPLE(colorindex_ci^[cur]); - Inc(output_ptr^, JSAMPLE (pixcode)); - { Compute actual representation error at this pixel } - { Note: we can do this even though we don't have the final } - { pixel code, because the colormap is orthogonal. } - Dec(cur, GETJSAMPLE(colormap_ci^[pixcode])); - { Compute error fractions to be propagated to adjacent pixels. - Add these into the running sums, and simultaneously shift the - next-line error sums left by 1 column. } - - bnexterr := cur; - delta := cur * 2; - Inc(cur, delta); { form error * 3 } - prev_errorptr^ := FSERROR (bpreverr + cur); - Inc(cur, delta); { form error * 5 } - bpreverr := belowerr + cur; - belowerr := bnexterr; - Inc(cur, delta); { form error * 7 } - { At this point cur contains the 7/16 error value to be propagated - to the next pixel on the current line, and all the errors for the - next line have been shifted over. We are therefore ready to move on. } - - Inc(input_ptr, dirnc); { advance input ptr to next column } - Inc(output_ptr, dir); { advance output ptr to next column } - - end; - { Post-loop cleanup: we must unload the final error value into the - final fserrors[] entry. Note we need not unload belowerr because - it is for the dummy column before or after the actual array. } - - errorptr^ := FSERROR (bpreverr); { unload prev err into array } - { Nomssi : ?? } - end; - cquantize^.on_odd_row := not cquantize^.on_odd_row; - end; -end; - - -{ Allocate workspace for Floyd-Steinberg errors. } - -{LOCAL} -procedure alloc_fs_workspace (cinfo : j_decompress_ptr); -var - cquantize : my_cquantize_ptr; - arraysize : size_t; - i : int; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - arraysize := size_t ((cinfo^.output_width + 2) * SIZEOF(FSERROR)); - for i := 0 to pred(cinfo^.out_color_components) do - begin - cquantize^.fserrors[i] := FS_ERROR_FIELD_PTR( - cinfo^.mem^.alloc_large(j_common_ptr(cinfo), JPOOL_IMAGE, arraysize)); - end; -end; - - -{ Initialize for one-pass color quantization. } - -{METHODDEF} -procedure start_pass_1_quant (cinfo : j_decompress_ptr; - is_pre_scan : boolean); -var - cquantize : my_cquantize_ptr; - arraysize : size_t; - i : int; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - { Install my colormap. } - cinfo^.colormap := cquantize^.sv_colormap; - cinfo^.actual_number_of_colors := cquantize^.sv_actual; - - { Initialize for desired dithering mode. } - case (cinfo^.dither_mode) of - JDITHER_NONE: - if (cinfo^.out_color_components = 3) then - cquantize^.pub.color_quantize := color_quantize3 - else - cquantize^.pub.color_quantize := color_quantize; - JDITHER_ORDERED: - begin - if (cinfo^.out_color_components = 3) then - cquantize^.pub.color_quantize := quantize3_ord_dither - else - cquantize^.pub.color_quantize := quantize_ord_dither; - cquantize^.row_index := 0; { initialize state for ordered dither } - { If user changed to ordered dither from another mode, - we must recreate the color index table with padding. - This will cost extra space, but probably isn't very likely. } - - if (not cquantize^.is_padded) then - create_colorindex(cinfo); - { Create ordered-dither tables if we didn't already. } - if (cquantize^.odither[0] = NIL) then - create_odither_tables(cinfo); - end; - JDITHER_FS: - begin - cquantize^.pub.color_quantize := quantize_fs_dither; - cquantize^.on_odd_row := FALSE; { initialize state for F-S dither } - { Allocate Floyd-Steinberg workspace if didn't already. } - if (cquantize^.fserrors[0] = NIL) then - alloc_fs_workspace(cinfo); - { Initialize the propagated errors to zero. } - arraysize := size_t ((cinfo^.output_width + 2) * SIZEOF(FSERROR)); - for i := 0 to pred(cinfo^.out_color_components) do - jzero_far({far} pointer( cquantize^.fserrors[i] ), arraysize); - end; - else - ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); - end; -end; - - -{ Finish up at the end of the pass. } - -{METHODDEF} -procedure finish_pass_1_quant (cinfo : j_decompress_ptr); -begin - { no work in 1-pass case } -end; - - -{ Switch to a new external colormap between output passes. - Shouldn't get to this module! } - -{METHODDEF} -procedure new_color_map_1_quant (cinfo : j_decompress_ptr); -begin - ERREXIT(j_common_ptr(cinfo), JERR_MODE_CHANGE); -end; - - -{ Module initialization routine for 1-pass color quantization. } - -{GLOBAL} -procedure jinit_1pass_quantizer (cinfo : j_decompress_ptr); -var - cquantize : my_cquantize_ptr; -begin - cquantize := my_cquantize_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_cquantizer))); - cinfo^.cquantize := jpeg_color_quantizer_ptr(cquantize); - cquantize^.pub.start_pass := start_pass_1_quant; - cquantize^.pub.finish_pass := finish_pass_1_quant; - cquantize^.pub.new_color_map := new_color_map_1_quant; - cquantize^.fserrors[0] := NIL; { Flag FS workspace not allocated } - cquantize^.odither[0] := NIL; { Also flag odither arrays not allocated } - - { Make sure my internal arrays won't overflow } - if (cinfo^.out_color_components > MAX_Q_COMPS) then - ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_COMPONENTS, MAX_Q_COMPS); - { Make sure colormap indexes can be represented by JSAMPLEs } - if (cinfo^.desired_number_of_colors > (MAXJSAMPLE+1)) then - ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_MANY_COLORS, MAXJSAMPLE+1); - - { Create the colormap and color index table. } - create_colormap(cinfo); - create_colorindex(cinfo); - - { Allocate Floyd-Steinberg workspace now if requested. - We do this now since it is FAR storage and may affect the memory - manager's space calculations. If the user changes to FS dither - mode in a later pass, we will allocate the space then, and will - possibly overrun the max_memory_to_use setting. } - - if (cinfo^.dither_mode = JDITHER_FS) then - alloc_fs_workspace(cinfo); -end; - - -end. +unit imjquant1; + +{ This file contains 1-pass color quantization (color mapping) routines. + These routines provide mapping to a fixed color map using equally spaced + color values. Optional Floyd-Steinberg or ordered dithering is available. } + +{ Original: jquant1.c; Copyright (C) 1991-1996, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjpeglib; + +{GLOBAL} +procedure jinit_1pass_quantizer (cinfo : j_decompress_ptr); + +implementation + +uses + imjmorecfg, + imjdeferr, + imjerror, + imjutils; + +{ The main purpose of 1-pass quantization is to provide a fast, if not very + high quality, colormapped output capability. A 2-pass quantizer usually + gives better visual quality; however, for quantized grayscale output this + quantizer is perfectly adequate. Dithering is highly recommended with this + quantizer, though you can turn it off if you really want to. + + In 1-pass quantization the colormap must be chosen in advance of seeing the + image. We use a map consisting of all combinations of Ncolors[i] color + values for the i'th component. The Ncolors[] values are chosen so that + their product, the total number of colors, is no more than that requested. + (In most cases, the product will be somewhat less.) + + Since the colormap is orthogonal, the representative value for each color + component can be determined without considering the other components; + then these indexes can be combined into a colormap index by a standard + N-dimensional-array-subscript calculation. Most of the arithmetic involved + can be precalculated and stored in the lookup table colorindex[]. + colorindex[i][j] maps pixel value j in component i to the nearest + representative value (grid plane) for that component; this index is + multiplied by the array stride for component i, so that the + index of the colormap entry closest to a given pixel value is just + sum( colorindex[component-number][pixel-component-value] ) + Aside from being fast, this scheme allows for variable spacing between + representative values with no additional lookup cost. + + If gamma correction has been applied in color conversion, it might be wise + to adjust the color grid spacing so that the representative colors are + equidistant in linear space. At this writing, gamma correction is not + implemented by jdcolor, so nothing is done here. } + + +{ Declarations for ordered dithering. + + We use a standard 16x16 ordered dither array. The basic concept of ordered + dithering is described in many references, for instance Dale Schumacher's + chapter II.2 of Graphics Gems II (James Arvo, ed. Academic Press, 1991). + In place of Schumacher's comparisons against a "threshold" value, we add a + "dither" value to the input pixel and then round the result to the nearest + output value. The dither value is equivalent to (0.5 - threshold) times + the distance between output values. For ordered dithering, we assume that + the output colors are equally spaced; if not, results will probably be + worse, since the dither may be too much or too little at a given point. + + The normal calculation would be to form pixel value + dither, range-limit + this to 0..MAXJSAMPLE, and then index into the colorindex table as usual. + We can skip the separate range-limiting step by extending the colorindex + table in both directions. } + + +const + ODITHER_SIZE = 16; { dimension of dither matrix } +{ NB: if ODITHER_SIZE is not a power of 2, ODITHER_MASK uses will break } + ODITHER_CELLS = (ODITHER_SIZE*ODITHER_SIZE); { # cells in matrix } + ODITHER_MASK = (ODITHER_SIZE-1); { mask for wrapping around counters } + +type + ODITHER_vector = Array[0..ODITHER_SIZE-1] of int; + ODITHER_MATRIX = Array[0..ODITHER_SIZE-1] of ODITHER_vector; + {ODITHER_MATRIX_PTR = ^array[0..ODITHER_SIZE-1] of int;} + ODITHER_MATRIX_PTR = ^ODITHER_MATRIX; + +const + base_dither_matrix : Array[0..ODITHER_SIZE-1,0..ODITHER_SIZE-1] of UINT8 + = ( + { Bayer's order-4 dither array. Generated by the code given in + Stephen Hawley's article "Ordered Dithering" in Graphics Gems I. + The values in this array must range from 0 to ODITHER_CELLS-1. } + + ( 0,192, 48,240, 12,204, 60,252, 3,195, 51,243, 15,207, 63,255 ), + ( 128, 64,176,112,140, 76,188,124,131, 67,179,115,143, 79,191,127 ), + ( 32,224, 16,208, 44,236, 28,220, 35,227, 19,211, 47,239, 31,223 ), + ( 160, 96,144, 80,172,108,156, 92,163, 99,147, 83,175,111,159, 95 ), + ( 8,200, 56,248, 4,196, 52,244, 11,203, 59,251, 7,199, 55,247 ), + ( 136, 72,184,120,132, 68,180,116,139, 75,187,123,135, 71,183,119 ), + ( 40,232, 24,216, 36,228, 20,212, 43,235, 27,219, 39,231, 23,215 ), + ( 168,104,152, 88,164,100,148, 84,171,107,155, 91,167,103,151, 87 ), + ( 2,194, 50,242, 14,206, 62,254, 1,193, 49,241, 13,205, 61,253 ), + ( 130, 66,178,114,142, 78,190,126,129, 65,177,113,141, 77,189,125 ), + ( 34,226, 18,210, 46,238, 30,222, 33,225, 17,209, 45,237, 29,221 ), + ( 162, 98,146, 82,174,110,158, 94,161, 97,145, 81,173,109,157, 93 ), + ( 10,202, 58,250, 6,198, 54,246, 9,201, 57,249, 5,197, 53,245 ), + ( 138, 74,186,122,134, 70,182,118,137, 73,185,121,133, 69,181,117 ), + ( 42,234, 26,218, 38,230, 22,214, 41,233, 25,217, 37,229, 21,213 ), + ( 170,106,154, 90,166,102,150, 86,169,105,153, 89,165,101,149, 85 ) + ); + + +{ Declarations for Floyd-Steinberg dithering. + + Errors are accumulated into the array fserrors[], at a resolution of + 1/16th of a pixel count. The error at a given pixel is propagated + to its not-yet-processed neighbors using the standard F-S fractions, + ... (here) 7/16 + 3/16 5/16 1/16 + We work left-to-right on even rows, right-to-left on odd rows. + + We can get away with a single array (holding one row's worth of errors) + by using it to store the current row's errors at pixel columns not yet + processed, but the next row's errors at columns already processed. We + need only a few extra variables to hold the errors immediately around the + current column. (If we are lucky, those variables are in registers, but + even if not, they're probably cheaper to access than array elements are.) + + The fserrors[] array is indexed [component#][position]. + We provide (#columns + 2) entries per component; the extra entry at each + end saves us from special-casing the first and last pixels. + + Note: on a wide image, we might not have enough room in a PC's near data + segment to hold the error array; so it is allocated with alloc_large. } + +{$ifdef BITS_IN_JSAMPLE_IS_8} +type + FSERROR = INT16; { 16 bits should be enough } + LOCFSERROR = int; { use 'int' for calculation temps } +{$else} +type + FSERROR = INT32; { may need more than 16 bits } + LOCFSERROR = INT32; { be sure calculation temps are big enough } +{$endif} + +type + jFSError = 0..(MaxInt div SIZEOF(FSERROR))-1; + FS_ERROR_FIELD = array[jFSError] of FSERROR; + FS_ERROR_FIELD_PTR = ^FS_ERROR_FIELD;{far} + { pointer to error array (in FAR storage!) } + FSERRORPTR = ^FSERROR; + + +{ Private subobject } + +const + MAX_Q_COMPS = 4; { max components I can handle } + +type + my_cquantize_ptr = ^my_cquantizer; + my_cquantizer = record + pub : jpeg_color_quantizer; { public fields } + + { Initially allocated colormap is saved here } + sv_colormap : JSAMPARRAY; { The color map as a 2-D pixel array } + sv_actual : int; { number of entries in use } + + colorindex : JSAMPARRAY; { Precomputed mapping for speed } + { colorindex[i][j] = index of color closest to pixel value j in component i, + premultiplied as described above. Since colormap indexes must fit into + JSAMPLEs, the entries of this array will too. } + + is_padded : boolean; { is the colorindex padded for odither? } + + Ncolors : array[0..MAX_Q_COMPS-1] of int; + { # of values alloced to each component } + + { Variables for ordered dithering } + row_index : int; { cur row's vertical index in dither matrix } + odither : array[0..MAX_Q_COMPS-1] of ODITHER_MATRIX_PTR; + { one dither array per component } + { Variables for Floyd-Steinberg dithering } + fserrors : array[0..MAX_Q_COMPS-1] of FS_ERROR_FIELD_PTR; + { accumulated errors } + on_odd_row : boolean; { flag to remember which row we are on } + end; + + +{ Policy-making subroutines for create_colormap and create_colorindex. + These routines determine the colormap to be used. The rest of the module + only assumes that the colormap is orthogonal. + + * select_ncolors decides how to divvy up the available colors + among the components. + * output_value defines the set of representative values for a component. + * largest_input_value defines the mapping from input values to + representative values for a component. + Note that the latter two routines may impose different policies for + different components, though this is not currently done. } + + + +{LOCAL} +function select_ncolors (cinfo : j_decompress_ptr; + var Ncolors : array of int) : int; +{ Determine allocation of desired colors to components, } +{ and fill in Ncolors[] array to indicate choice. } +{ Return value is total number of colors (product of Ncolors[] values). } +var + nc : int; + max_colors : int; + total_colors, iroot, i, j : int; + changed : boolean; + temp : long; +const + RGB_order:array[0..2] of int = (RGB_GREEN, RGB_RED, RGB_BLUE); +begin + nc := cinfo^.out_color_components; { number of color components } + max_colors := cinfo^.desired_number_of_colors; + + { We can allocate at least the nc'th root of max_colors per component. } + { Compute floor(nc'th root of max_colors). } + iroot := 1; + repeat + Inc(iroot); + temp := iroot; { set temp = iroot ** nc } + for i := 1 to pred(nc) do + temp := temp * iroot; + until (temp > long(max_colors)); { repeat till iroot exceeds root } + Dec(iroot); { now iroot = floor(root) } + + { Must have at least 2 color values per component } + if (iroot < 2) then + ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_FEW_COLORS, int(temp)); + + { Initialize to iroot color values for each component } + total_colors := 1; + for i := 0 to pred(nc) do + begin + Ncolors[i] := iroot; + total_colors := total_colors * iroot; + end; + + { We may be able to increment the count for one or more components without + exceeding max_colors, though we know not all can be incremented. + Sometimes, the first component can be incremented more than once! + (Example: for 16 colors, we start at 2*2*2, go to 3*2*2, then 4*2*2.) + In RGB colorspace, try to increment G first, then R, then B. } + + repeat + changed := FALSE; + for i := 0 to pred(nc) do + begin + if cinfo^.out_color_space = JCS_RGB then + j := RGB_order[i] + else + j := i; + { calculate new total_colors if Ncolors[j] is incremented } + temp := total_colors div Ncolors[j]; + temp := temp * (Ncolors[j]+1); { done in long arith to avoid oflo } + if (temp > long(max_colors)) then + break; { won't fit, done with this pass } + Inc(Ncolors[j]); { OK, apply the increment } + total_colors := int(temp); + changed := TRUE; + end; + until not changed; + + select_ncolors := total_colors; +end; + + +{LOCAL} +function output_value (cinfo : j_decompress_ptr; + ci : int; j : int; maxj : int) : int; +{ Return j'th output value, where j will range from 0 to maxj } +{ The output values must fall in 0..MAXJSAMPLE in increasing order } +begin + { We always provide values 0 and MAXJSAMPLE for each component; + any additional values are equally spaced between these limits. + (Forcing the upper and lower values to the limits ensures that + dithering can't produce a color outside the selected gamut.) } + + output_value := int (( INT32(j) * MAXJSAMPLE + maxj div 2) div maxj); +end; + + +{LOCAL} +function largest_input_value (cinfo : j_decompress_ptr; + ci : int; j : int; maxj : int) : int; +{ Return largest input value that should map to j'th output value } +{ Must have largest(j=0) >= 0, and largest(j=maxj) >= MAXJSAMPLE } +begin + { Breakpoints are halfway between values returned by output_value } + largest_input_value := int (( INT32(2*j + 1) * MAXJSAMPLE + + maxj) div (2*maxj)); +end; + + +{ Create the colormap. } + +{LOCAL} +procedure create_colormap (cinfo : j_decompress_ptr); +var + cquantize : my_cquantize_ptr; + colormap : JSAMPARRAY; { Created colormap } + + total_colors : int; { Number of distinct output colors } + i,j,k, nci, blksize, blkdist, ptr, val : int; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + + { Select number of colors for each component } + total_colors := select_ncolors(cinfo, cquantize^.Ncolors); + + { Report selected color counts } + {$IFDEF DEBUG} + if (cinfo^.out_color_components = 3) then + TRACEMS4(j_common_ptr(cinfo), 1, JTRC_QUANT_3_NCOLORS, + total_colors, cquantize^.Ncolors[0], + cquantize^.Ncolors[1], cquantize^.Ncolors[2]) + else + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_QUANT_NCOLORS, total_colors); + {$ENDIF} + + { Allocate and fill in the colormap. } + { The colors are ordered in the map in standard row-major order, } + { i.e. rightmost (highest-indexed) color changes most rapidly. } + + colormap := cinfo^.mem^.alloc_sarray( + j_common_ptr(cinfo), JPOOL_IMAGE, + JDIMENSION(total_colors), JDIMENSION(cinfo^.out_color_components)); + + { blksize is number of adjacent repeated entries for a component } + { blkdist is distance between groups of identical entries for a component } + blkdist := total_colors; + + for i := 0 to pred(cinfo^.out_color_components) do + begin + { fill in colormap entries for i'th color component } + nci := cquantize^.Ncolors[i]; { # of distinct values for this color } + blksize := blkdist div nci; + for j := 0 to pred(nci) do + begin + { Compute j'th output value (out of nci) for component } + val := output_value(cinfo, i, j, nci-1); + { Fill in all colormap entries that have this value of this component } + ptr := j * blksize; + while (ptr < total_colors) do + begin + { fill in blksize entries beginning at ptr } + for k := 0 to pred(blksize) do + colormap^[i]^[ptr+k] := JSAMPLE(val); + + Inc(ptr, blkdist); + end; + end; + blkdist := blksize; { blksize of this color is blkdist of next } + end; + + { Save the colormap in private storage, + where it will survive color quantization mode changes. } + + cquantize^.sv_colormap := colormap; + cquantize^.sv_actual := total_colors; +end; + +{ Create the color index table. } + +{LOCAL} +procedure create_colorindex (cinfo : j_decompress_ptr); +var + cquantize : my_cquantize_ptr; + indexptr, + help_indexptr : JSAMPROW; { for negative offsets } + i,j,k, nci, blksize, val, pad : int; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + { For ordered dither, we pad the color index tables by MAXJSAMPLE in + each direction (input index values can be -MAXJSAMPLE .. 2*MAXJSAMPLE). + This is not necessary in the other dithering modes. However, we + flag whether it was done in case user changes dithering mode. } + + if (cinfo^.dither_mode = JDITHER_ORDERED) then + begin + pad := MAXJSAMPLE*2; + cquantize^.is_padded := TRUE; + end + else + begin + pad := 0; + cquantize^.is_padded := FALSE; + end; + + cquantize^.colorindex := cinfo^.mem^.alloc_sarray + (j_common_ptr(cinfo), JPOOL_IMAGE, + JDIMENSION(MAXJSAMPLE+1 + pad), + JDIMENSION(cinfo^.out_color_components)); + + { blksize is number of adjacent repeated entries for a component } + blksize := cquantize^.sv_actual; + + for i := 0 to pred(cinfo^.out_color_components) do + begin + { fill in colorindex entries for i'th color component } + nci := cquantize^.Ncolors[i]; { # of distinct values for this color } + blksize := blksize div nci; + + { adjust colorindex pointers to provide padding at negative indexes. } + if (pad <> 0) then + Inc(JSAMPLE_PTR(cquantize^.colorindex^[i]), MAXJSAMPLE); + + { in loop, val = index of current output value, } + { and k = largest j that maps to current val } + indexptr := cquantize^.colorindex^[i]; + val := 0; + k := largest_input_value(cinfo, i, 0, nci-1); + for j := 0 to MAXJSAMPLE do + begin + while (j > k) do { advance val if past boundary } + begin + Inc(val); + k := largest_input_value(cinfo, i, val, nci-1); + end; + { premultiply so that no multiplication needed in main processing } + indexptr^[j] := JSAMPLE (val * blksize); + end; + { Pad at both ends if necessary } + if (pad <> 0) then + begin + help_indexptr := indexptr; + { adjust the help pointer to avoid negative offsets } + Dec(JSAMPLE_PTR(help_indexptr), MAXJSAMPLE); + + for j := 1 to MAXJSAMPLE do + begin + {indexptr^[-j] := indexptr^[0];} + help_indexptr^[MAXJSAMPLE-j] := indexptr^[0]; + indexptr^[MAXJSAMPLE+j] := indexptr^[MAXJSAMPLE]; + end; + end; + end; +end; + + +{ Create an ordered-dither array for a component having ncolors + distinct output values. } + +{LOCAL} +function make_odither_array (cinfo : j_decompress_ptr; + ncolors : int) : ODITHER_MATRIX_PTR; +var + odither : ODITHER_MATRIX_PTR; + j, k : int; + num, den : INT32; +begin + odither := ODITHER_MATRIX_PTR ( + cinfo^.mem^.alloc_small(j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(ODITHER_MATRIX))); + { The inter-value distance for this color is MAXJSAMPLE/(ncolors-1). + Hence the dither value for the matrix cell with fill order f + (f=0..N-1) should be (N-1-2*f)/(2*N) * MAXJSAMPLE/(ncolors-1). + On 16-bit-int machine, be careful to avoid overflow. } + + den := 2 * ODITHER_CELLS * ( INT32(ncolors - 1)); + for j := 0 to pred(ODITHER_SIZE) do + begin + for k := 0 to pred(ODITHER_SIZE) do + begin + num := ( INT32(ODITHER_CELLS-1 - 2*( int(base_dither_matrix[j][k])))) + * MAXJSAMPLE; + { Ensure round towards zero despite C's lack of consistency + about rounding negative values in integer division... } + + if num<0 then + odither^[j][k] := int (-((-num) div den)) + else + odither^[j][k] := int (num div den); + end; + end; + make_odither_array := odither; +end; + + +{ Create the ordered-dither tables. + Components having the same number of representative colors may + share a dither table. } + +{LOCAL} +procedure create_odither_tables (cinfo : j_decompress_ptr); +var + cquantize : my_cquantize_ptr; + odither : ODITHER_MATRIX_PTR; + i, j, nci : int; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + + for i := 0 to pred(cinfo^.out_color_components) do + begin + nci := cquantize^.Ncolors[i]; { # of distinct values for this color } + odither := NIL; { search for matching prior component } + for j := 0 to pred(i) do + begin + if (nci = cquantize^.Ncolors[j]) then + begin + odither := cquantize^.odither[j]; + break; + end; + end; + if (odither = NIL) then { need a new table? } + odither := make_odither_array(cinfo, nci); + cquantize^.odither[i] := odither; + end; +end; + + +{ Map some rows of pixels to the output colormapped representation. } + +{METHODDEF} +procedure color_quantize (cinfo : j_decompress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPARRAY; + num_rows : int); +{ General case, no dithering } +var + cquantize : my_cquantize_ptr; + colorindex : JSAMPARRAY; + pixcode, ci : int; {register} + ptrin, ptrout : JSAMPLE_PTR; {register} + row : int; + col : JDIMENSION; + width : JDIMENSION; + nc : int; {register} +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + colorindex := cquantize^.colorindex; + width := cinfo^.output_width; + nc := cinfo^.out_color_components; + + for row := 0 to pred(num_rows) do + begin + ptrin := JSAMPLE_PTR(input_buf^[row]); + ptrout := JSAMPLE_PTR(output_buf^[row]); + for col := pred(width) downto 0 do + begin + pixcode := 0; + for ci := 0 to pred(nc) do + begin + Inc(pixcode, GETJSAMPLE(colorindex^[ci]^[GETJSAMPLE(ptrin^)]) ); + Inc(ptrin); + end; + ptrout^ := JSAMPLE (pixcode); + Inc(ptrout); + end; + end; +end; + + +{METHODDEF} +procedure color_quantize3 (cinfo : j_decompress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPARRAY; + num_rows : int); +{ Fast path for out_color_components=3, no dithering } +var + cquantize : my_cquantize_ptr; + pixcode : int; {register} + ptrin, ptrout : JSAMPLE_PTR; {register} + colorindex0 : JSAMPROW; + colorindex1 : JSAMPROW; + colorindex2 : JSAMPROW; + row : int; + col : JDIMENSION; + width : JDIMENSION; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + colorindex0 := (cquantize^.colorindex)^[0]; + colorindex1 := (cquantize^.colorindex)^[1]; + colorindex2 := (cquantize^.colorindex)^[2]; + width := cinfo^.output_width; + + for row := 0 to pred(num_rows) do + begin + ptrin := JSAMPLE_PTR(input_buf^[row]); + ptrout := JSAMPLE_PTR(output_buf^[row]); + for col := pred(width) downto 0 do + begin + pixcode := GETJSAMPLE((colorindex0)^[GETJSAMPLE(ptrin^)]); + Inc(ptrin); + Inc( pixcode, GETJSAMPLE((colorindex1)^[GETJSAMPLE(ptrin^)]) ); + Inc(ptrin); + Inc( pixcode, GETJSAMPLE((colorindex2)^[GETJSAMPLE(ptrin^)]) ); + Inc(ptrin); + ptrout^ := JSAMPLE (pixcode); + Inc(ptrout); + end; + end; +end; + + +{METHODDEF} +procedure quantize_ord_dither (cinfo : j_decompress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPARRAY; + num_rows : int); +{ General case, with ordered dithering } +var + cquantize : my_cquantize_ptr; + input_ptr, {register} + output_ptr : JSAMPLE_PTR; {register} + colorindex_ci : JSAMPROW; + dither : ^ODITHER_vector; { points to active row of dither matrix } + row_index, col_index : int; { current indexes into dither matrix } + nc : int; + ci : int; + row : int; + col : JDIMENSION; + width : JDIMENSION; +var + pad_offset : int; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + nc := cinfo^.out_color_components; + width := cinfo^.output_width; + + { Nomssi: work around negative offset } + if my_cquantize_ptr (cinfo^.cquantize)^.is_padded then + pad_offset := MAXJSAMPLE + else + pad_offset := 0; + + for row := 0 to pred(num_rows) do + begin + { Initialize output values to 0 so can process components separately } + jzero_far( {far} pointer(output_buf^[row]), + size_t(width * SIZEOF(JSAMPLE))); + row_index := cquantize^.row_index; + for ci := 0 to pred(nc) do + begin + input_ptr := JSAMPLE_PTR(@ input_buf^[row]^[ci]); + output_ptr := JSAMPLE_PTR(output_buf^[row]); + colorindex_ci := cquantize^.colorindex^[ci]; + { Nomssi } + Dec(JSAMPLE_PTR(colorindex_ci), pad_offset); + + dither := @(cquantize^.odither[ci]^[row_index]); + col_index := 0; + + for col := pred(width) downto 0 do + begin + { Form pixel value + dither, range-limit to 0..MAXJSAMPLE, + select output value, accumulate into output code for this pixel. + Range-limiting need not be done explicitly, as we have extended + the colorindex table to produce the right answers for out-of-range + inputs. The maximum dither is +- MAXJSAMPLE; this sets the + required amount of padding. } + + Inc(output_ptr^, + colorindex_ci^[GETJSAMPLE(input_ptr^)+ pad_offset + + dither^[col_index]]); + Inc(output_ptr); + Inc(input_ptr, nc); + col_index := (col_index + 1) and ODITHER_MASK; + end; + end; + { Advance row index for next row } + row_index := (row_index + 1) and ODITHER_MASK; + cquantize^.row_index := row_index; + end; +end; + +{METHODDEF} +procedure quantize3_ord_dither (cinfo : j_decompress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPARRAY; + num_rows : int); +{ Fast path for out_color_components=3, with ordered dithering } +var + cquantize : my_cquantize_ptr; + pixcode : int; {register} + input_ptr : JSAMPLE_PTR; {register} + output_ptr : JSAMPLE_PTR; {register} + colorindex0 : JSAMPROW; + colorindex1 : JSAMPROW; + colorindex2 : JSAMPROW; + dither0 : ^ODITHER_vector; { points to active row of dither matrix } + dither1 : ^ODITHER_vector; + dither2 : ^ODITHER_vector; + row_index, col_index : int; { current indexes into dither matrix } + row : int; + col : JDIMENSION; + width : JDIMENSION; +var + pad_offset : int; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + colorindex0 := (cquantize^.colorindex)^[0]; + colorindex1 := (cquantize^.colorindex)^[1]; + colorindex2 := (cquantize^.colorindex)^[2]; + width := cinfo^.output_width; + + { Nomssi: work around negative offset } + if my_cquantize_ptr (cinfo^.cquantize)^.is_padded then + pad_offset := MAXJSAMPLE + else + pad_offset := 0; + + Dec(JSAMPLE_PTR(colorindex0), pad_offset); + Dec(JSAMPLE_PTR(colorindex1), pad_offset); + Dec(JSAMPLE_PTR(colorindex2), pad_offset); + + for row := 0 to pred(num_rows) do + begin + row_index := cquantize^.row_index; + input_ptr := JSAMPLE_PTR(input_buf^[row]); + output_ptr := JSAMPLE_PTR(output_buf^[row]); + dither0 := @(cquantize^.odither[0]^[row_index]); + dither1 := @(cquantize^.odither[1]^[row_index]); + dither2 := @(cquantize^.odither[2]^[row_index]); + col_index := 0; + + + for col := pred(width) downto 0 do + begin + pixcode := GETJSAMPLE(colorindex0^[GETJSAMPLE(input_ptr^) + pad_offset + + dither0^[col_index]]); + Inc(input_ptr); + Inc(pixcode, GETJSAMPLE(colorindex1^[GETJSAMPLE(input_ptr^) + pad_offset + + dither1^[col_index]])); + Inc(input_ptr); + Inc(pixcode, GETJSAMPLE(colorindex2^[GETJSAMPLE(input_ptr^) + pad_offset + + dither2^[col_index]])); + Inc(input_ptr); + output_ptr^ := JSAMPLE (pixcode); + Inc(output_ptr); + col_index := (col_index + 1) and ODITHER_MASK; + end; + row_index := (row_index + 1) and ODITHER_MASK; + cquantize^.row_index := row_index; + end; +end; + + +{METHODDEF} +procedure quantize_fs_dither (cinfo : j_decompress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPARRAY; + num_rows : int); +{ General case, with Floyd-Steinberg dithering } +var + cquantize : my_cquantize_ptr; + cur : LOCFSERROR; {register} { current error or pixel value } + belowerr : LOCFSERROR; { error for pixel below cur } + bpreverr : LOCFSERROR; { error for below/prev col } + bnexterr : LOCFSERROR; { error for below/next col } + delta : LOCFSERROR; + prev_errorptr, + errorptr : FSERRORPTR; {register} { => fserrors[] at column before current } + input_ptr, {register} + output_ptr : JSAMPLE_PTR; {register} + colorindex_ci : JSAMPROW; + colormap_ci : JSAMPROW; + pixcode : int; + nc : int; + dir : int; { 1 for left-to-right, -1 for right-to-left } + dirnc : int; { dir * nc } + ci : int; + row : int; + col : JDIMENSION; + width : JDIMENSION; + range_limit : range_limit_table_ptr; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + nc := cinfo^.out_color_components; + width := cinfo^.output_width; + range_limit := cinfo^.sample_range_limit; + + for row := 0 to pred(num_rows) do + begin + { Initialize output values to 0 so can process components separately } + jzero_far( (output_buf)^[row], + size_t(width * SIZEOF(JSAMPLE))); + for ci := 0 to pred(nc) do + begin + input_ptr := JSAMPLE_PTR(@ input_buf^[row]^[ci]); + output_ptr := JSAMPLE_PTR(output_buf^[row]); + errorptr := FSERRORPTR(cquantize^.fserrors[ci]); { => entry before first column } + if (cquantize^.on_odd_row) then + begin + { work right to left in this row } + Inc(input_ptr, (width-1) * JDIMENSION(nc)); { so point to rightmost pixel } + Inc(output_ptr, width-1); + dir := -1; + dirnc := -nc; + Inc(errorptr, (width+1)); { => entry after last column } + end + else + begin + { work left to right in this row } + dir := 1; + dirnc := nc; + {errorptr := cquantize^.fserrors[ci];} + end; + + colorindex_ci := cquantize^.colorindex^[ci]; + + colormap_ci := (cquantize^.sv_colormap)^[ci]; + { Preset error values: no error propagated to first pixel from left } + cur := 0; + { and no error propagated to row below yet } + belowerr := 0; + bpreverr := 0; + + for col := pred(width) downto 0 do + begin + prev_errorptr := errorptr; + Inc(errorptr, dir); { advance errorptr to current column } + + { cur holds the error propagated from the previous pixel on the + current line. Add the error propagated from the previous line + to form the complete error correction term for this pixel, and + round the error term (which is expressed * 16) to an integer. + RIGHT_SHIFT rounds towards minus infinity, so adding 8 is correct + for either sign of the error value. + Note: errorptr points to *previous* column's array entry. } + + cur := (cur + errorptr^ + 8) div 16; + + { Form pixel value + error, and range-limit to 0..MAXJSAMPLE. + The maximum error is +- MAXJSAMPLE; this sets the required size + of the range_limit array. } + + Inc( cur, GETJSAMPLE(input_ptr^)); + cur := GETJSAMPLE(range_limit^[cur]); + { Select output value, accumulate into output code for this pixel } + pixcode := GETJSAMPLE(colorindex_ci^[cur]); + Inc(output_ptr^, JSAMPLE (pixcode)); + { Compute actual representation error at this pixel } + { Note: we can do this even though we don't have the final } + { pixel code, because the colormap is orthogonal. } + Dec(cur, GETJSAMPLE(colormap_ci^[pixcode])); + { Compute error fractions to be propagated to adjacent pixels. + Add these into the running sums, and simultaneously shift the + next-line error sums left by 1 column. } + + bnexterr := cur; + delta := cur * 2; + Inc(cur, delta); { form error * 3 } + prev_errorptr^ := FSERROR (bpreverr + cur); + Inc(cur, delta); { form error * 5 } + bpreverr := belowerr + cur; + belowerr := bnexterr; + Inc(cur, delta); { form error * 7 } + { At this point cur contains the 7/16 error value to be propagated + to the next pixel on the current line, and all the errors for the + next line have been shifted over. We are therefore ready to move on. } + + Inc(input_ptr, dirnc); { advance input ptr to next column } + Inc(output_ptr, dir); { advance output ptr to next column } + + end; + { Post-loop cleanup: we must unload the final error value into the + final fserrors[] entry. Note we need not unload belowerr because + it is for the dummy column before or after the actual array. } + + errorptr^ := FSERROR (bpreverr); { unload prev err into array } + { Nomssi : ?? } + end; + cquantize^.on_odd_row := not cquantize^.on_odd_row; + end; +end; + + +{ Allocate workspace for Floyd-Steinberg errors. } + +{LOCAL} +procedure alloc_fs_workspace (cinfo : j_decompress_ptr); +var + cquantize : my_cquantize_ptr; + arraysize : size_t; + i : int; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + arraysize := size_t ((cinfo^.output_width + 2) * SIZEOF(FSERROR)); + for i := 0 to pred(cinfo^.out_color_components) do + begin + cquantize^.fserrors[i] := FS_ERROR_FIELD_PTR( + cinfo^.mem^.alloc_large(j_common_ptr(cinfo), JPOOL_IMAGE, arraysize)); + end; +end; + + +{ Initialize for one-pass color quantization. } + +{METHODDEF} +procedure start_pass_1_quant (cinfo : j_decompress_ptr; + is_pre_scan : boolean); +var + cquantize : my_cquantize_ptr; + arraysize : size_t; + i : int; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + { Install my colormap. } + cinfo^.colormap := cquantize^.sv_colormap; + cinfo^.actual_number_of_colors := cquantize^.sv_actual; + + { Initialize for desired dithering mode. } + case (cinfo^.dither_mode) of + JDITHER_NONE: + if (cinfo^.out_color_components = 3) then + cquantize^.pub.color_quantize := color_quantize3 + else + cquantize^.pub.color_quantize := color_quantize; + JDITHER_ORDERED: + begin + if (cinfo^.out_color_components = 3) then + cquantize^.pub.color_quantize := quantize3_ord_dither + else + cquantize^.pub.color_quantize := quantize_ord_dither; + cquantize^.row_index := 0; { initialize state for ordered dither } + { If user changed to ordered dither from another mode, + we must recreate the color index table with padding. + This will cost extra space, but probably isn't very likely. } + + if (not cquantize^.is_padded) then + create_colorindex(cinfo); + { Create ordered-dither tables if we didn't already. } + if (cquantize^.odither[0] = NIL) then + create_odither_tables(cinfo); + end; + JDITHER_FS: + begin + cquantize^.pub.color_quantize := quantize_fs_dither; + cquantize^.on_odd_row := FALSE; { initialize state for F-S dither } + { Allocate Floyd-Steinberg workspace if didn't already. } + if (cquantize^.fserrors[0] = NIL) then + alloc_fs_workspace(cinfo); + { Initialize the propagated errors to zero. } + arraysize := size_t ((cinfo^.output_width + 2) * SIZEOF(FSERROR)); + for i := 0 to pred(cinfo^.out_color_components) do + jzero_far({far} pointer( cquantize^.fserrors[i] ), arraysize); + end; + else + ERREXIT(j_common_ptr(cinfo), JERR_NOT_COMPILED); + end; +end; + + +{ Finish up at the end of the pass. } + +{METHODDEF} +procedure finish_pass_1_quant (cinfo : j_decompress_ptr); +begin + { no work in 1-pass case } +end; + + +{ Switch to a new external colormap between output passes. + Shouldn't get to this module! } + +{METHODDEF} +procedure new_color_map_1_quant (cinfo : j_decompress_ptr); +begin + ERREXIT(j_common_ptr(cinfo), JERR_MODE_CHANGE); +end; + + +{ Module initialization routine for 1-pass color quantization. } + +{GLOBAL} +procedure jinit_1pass_quantizer (cinfo : j_decompress_ptr); +var + cquantize : my_cquantize_ptr; +begin + cquantize := my_cquantize_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_cquantizer))); + cinfo^.cquantize := jpeg_color_quantizer_ptr(cquantize); + cquantize^.pub.start_pass := start_pass_1_quant; + cquantize^.pub.finish_pass := finish_pass_1_quant; + cquantize^.pub.new_color_map := new_color_map_1_quant; + cquantize^.fserrors[0] := NIL; { Flag FS workspace not allocated } + cquantize^.odither[0] := NIL; { Also flag odither arrays not allocated } + + { Make sure my internal arrays won't overflow } + if (cinfo^.out_color_components > MAX_Q_COMPS) then + ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_COMPONENTS, MAX_Q_COMPS); + { Make sure colormap indexes can be represented by JSAMPLEs } + if (cinfo^.desired_number_of_colors > (MAXJSAMPLE+1)) then + ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_MANY_COLORS, MAXJSAMPLE+1); + + { Create the colormap and color index table. } + create_colormap(cinfo); + create_colorindex(cinfo); + + { Allocate Floyd-Steinberg workspace now if requested. + We do this now since it is FAR storage and may affect the memory + manager's space calculations. If the user changes to FS dither + mode in a later pass, we will allocate the space then, and will + possibly overrun the max_memory_to_use setting. } + + if (cinfo^.dither_mode = JDITHER_FS) then + alloc_fs_workspace(cinfo); +end; + + +end. diff --git a/Imaging/JpegLib/imjquant2.pas b/Imaging/JpegLib/imjquant2.pas index a1e7a44..21cc232 100644 --- a/Imaging/JpegLib/imjquant2.pas +++ b/Imaging/JpegLib/imjquant2.pas @@ -1,1551 +1,1551 @@ -unit imjquant2; - - -{ This file contains 2-pass color quantization (color mapping) routines. - These routines provide selection of a custom color map for an image, - followed by mapping of the image to that color map, with optional - Floyd-Steinberg dithering. - It is also possible to use just the second pass to map to an arbitrary - externally-given color map. - - Note: ordered dithering is not supported, since there isn't any fast - way to compute intercolor distances; it's unclear that ordered dither's - fundamental assumptions even hold with an irregularly spaced color map. } - -{ Original: jquant2.c; Copyright (C) 1991-1996, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjdeferr, - imjerror, - imjutils, - imjpeglib; - -{ Module initialization routine for 2-pass color quantization. } - - -{GLOBAL} -procedure jinit_2pass_quantizer (cinfo : j_decompress_ptr); - -implementation - -{ This module implements the well-known Heckbert paradigm for color - quantization. Most of the ideas used here can be traced back to - Heckbert's seminal paper - Heckbert, Paul. "Color Image Quantization for Frame Buffer Display", - Proc. SIGGRAPH '82, Computer Graphics v.16 #3 (July 1982), pp 297-304. - - In the first pass over the image, we accumulate a histogram showing the - usage count of each possible color. To keep the histogram to a reasonable - size, we reduce the precision of the input; typical practice is to retain - 5 or 6 bits per color, so that 8 or 4 different input values are counted - in the same histogram cell. - - Next, the color-selection step begins with a box representing the whole - color space, and repeatedly splits the "largest" remaining box until we - have as many boxes as desired colors. Then the mean color in each - remaining box becomes one of the possible output colors. - - The second pass over the image maps each input pixel to the closest output - color (optionally after applying a Floyd-Steinberg dithering correction). - This mapping is logically trivial, but making it go fast enough requires - considerable care. - - Heckbert-style quantizers vary a good deal in their policies for choosing - the "largest" box and deciding where to cut it. The particular policies - used here have proved out well in experimental comparisons, but better ones - may yet be found. - - In earlier versions of the IJG code, this module quantized in YCbCr color - space, processing the raw upsampled data without a color conversion step. - This allowed the color conversion math to be done only once per colormap - entry, not once per pixel. However, that optimization precluded other - useful optimizations (such as merging color conversion with upsampling) - and it also interfered with desired capabilities such as quantizing to an - externally-supplied colormap. We have therefore abandoned that approach. - The present code works in the post-conversion color space, typically RGB. - - To improve the visual quality of the results, we actually work in scaled - RGB space, giving G distances more weight than R, and R in turn more than - B. To do everything in integer math, we must use integer scale factors. - The 2/3/1 scale factors used here correspond loosely to the relative - weights of the colors in the NTSC grayscale equation. - If you want to use this code to quantize a non-RGB color space, you'll - probably need to change these scale factors. } - -const - R_SCALE = 2; { scale R distances by this much } - G_SCALE = 3; { scale G distances by this much } - B_SCALE = 1; { and B by this much } - -{ Relabel R/G/B as components 0/1/2, respecting the RGB ordering defined - in jmorecfg.h. As the code stands, it will do the right thing for R,G,B - and B,G,R orders. If you define some other weird order in jmorecfg.h, - you'll get compile errors until you extend this logic. In that case - you'll probably want to tweak the histogram sizes too. } - -{$ifdef RGB_RED_IS_0} -const - C0_SCALE = R_SCALE; - C1_SCALE = G_SCALE; - C2_SCALE = B_SCALE; -{$else} -const - C0_SCALE = B_SCALE; - C1_SCALE = G_SCALE; - C2_SCALE = R_SCALE; -{$endif} - - -{ First we have the histogram data structure and routines for creating it. - - The number of bits of precision can be adjusted by changing these symbols. - We recommend keeping 6 bits for G and 5 each for R and B. - If you have plenty of memory and cycles, 6 bits all around gives marginally - better results; if you are short of memory, 5 bits all around will save - some space but degrade the results. - To maintain a fully accurate histogram, we'd need to allocate a "long" - (preferably unsigned long) for each cell. In practice this is overkill; - we can get by with 16 bits per cell. Few of the cell counts will overflow, - and clamping those that do overflow to the maximum value will give close- - enough results. This reduces the recommended histogram size from 256Kb - to 128Kb, which is a useful savings on PC-class machines. - (In the second pass the histogram space is re-used for pixel mapping data; - in that capacity, each cell must be able to store zero to the number of - desired colors. 16 bits/cell is plenty for that too.) - Since the JPEG code is intended to run in small memory model on 80x86 - machines, we can't just allocate the histogram in one chunk. Instead - of a true 3-D array, we use a row of pointers to 2-D arrays. Each - pointer corresponds to a C0 value (typically 2^5 = 32 pointers) and - each 2-D array has 2^6*2^5 = 2048 or 2^6*2^6 = 4096 entries. Note that - on 80x86 machines, the pointer row is in near memory but the actual - arrays are in far memory (same arrangement as we use for image arrays). } - - -const - MAXNUMCOLORS = (MAXJSAMPLE+1); { maximum size of colormap } - -{ These will do the right thing for either R,G,B or B,G,R color order, - but you may not like the results for other color orders. } - -const - HIST_C0_BITS = 5; { bits of precision in R/B histogram } - HIST_C1_BITS = 6; { bits of precision in G histogram } - HIST_C2_BITS = 5; { bits of precision in B/R histogram } - -{ Number of elements along histogram axes. } -const - HIST_C0_ELEMS = (1 shl HIST_C0_BITS); - HIST_C1_ELEMS = (1 shl HIST_C1_BITS); - HIST_C2_ELEMS = (1 shl HIST_C2_BITS); - -{ These are the amounts to shift an input value to get a histogram index. } -const - C0_SHIFT = (BITS_IN_JSAMPLE-HIST_C0_BITS); - C1_SHIFT = (BITS_IN_JSAMPLE-HIST_C1_BITS); - C2_SHIFT = (BITS_IN_JSAMPLE-HIST_C2_BITS); - - -type { Nomssi } - RGBptr = ^RGBtype; - RGBtype = packed record - r,g,b : JSAMPLE; - end; -type - histcell = UINT16; { histogram cell; prefer an unsigned type } - -type - histptr = ^histcell {FAR}; { for pointers to histogram cells } - -type - hist1d = array[0..HIST_C2_ELEMS-1] of histcell; { typedefs for the array } - {hist1d_ptr = ^hist1d;} - hist1d_field = array[0..HIST_C1_ELEMS-1] of hist1d; - { type for the 2nd-level pointers } - hist2d = ^hist1d_field; - hist2d_field = array[0..HIST_C0_ELEMS-1] of hist2d; - hist3d = ^hist2d_field; { type for top-level pointer } - - -{ Declarations for Floyd-Steinberg dithering. - - Errors are accumulated into the array fserrors[], at a resolution of - 1/16th of a pixel count. The error at a given pixel is propagated - to its not-yet-processed neighbors using the standard F-S fractions, - ... (here) 7/16 - 3/16 5/16 1/16 - We work left-to-right on even rows, right-to-left on odd rows. - - We can get away with a single array (holding one row's worth of errors) - by using it to store the current row's errors at pixel columns not yet - processed, but the next row's errors at columns already processed. We - need only a few extra variables to hold the errors immediately around the - current column. (If we are lucky, those variables are in registers, but - even if not, they're probably cheaper to access than array elements are.) - - The fserrors[] array has (#columns + 2) entries; the extra entry at - each end saves us from special-casing the first and last pixels. - Each entry is three values long, one value for each color component. - - Note: on a wide image, we might not have enough room in a PC's near data - segment to hold the error array; so it is allocated with alloc_large. } - - -{$ifdef BITS_IN_JSAMPLE_IS_8} -type - FSERROR = INT16; { 16 bits should be enough } - LOCFSERROR = int; { use 'int' for calculation temps } -{$else} -type - FSERROR = INT32; { may need more than 16 bits } - LOCFSERROR = INT32; { be sure calculation temps are big enough } -{$endif} -type { Nomssi } - RGB_FSERROR_PTR = ^RGB_FSERROR; - RGB_FSERROR = packed record - r,g,b : FSERROR; - end; - LOCRGB_FSERROR = packed record - r,g,b : LOCFSERROR; - end; - -type - FSERROR_PTR = ^FSERROR; - jFSError = 0..(MaxInt div SIZEOF(RGB_FSERROR))-1; - FS_ERROR_FIELD = array[jFSError] of RGB_FSERROR; - FS_ERROR_FIELD_PTR = ^FS_ERROR_FIELD;{far} - { pointer to error array (in FAR storage!) } - -type - error_limit_array = array[-MAXJSAMPLE..MAXJSAMPLE] of int; - { table for clamping the applied error } - error_limit_ptr = ^error_limit_array; - -{ Private subobject } -type - my_cquantize_ptr = ^my_cquantizer; - my_cquantizer = record - pub : jpeg_color_quantizer; { public fields } - - { Space for the eventually created colormap is stashed here } - sv_colormap : JSAMPARRAY; { colormap allocated at init time } - desired : int; { desired # of colors = size of colormap } - - { Variables for accumulating image statistics } - histogram : hist3d; { pointer to the histogram } - - needs_zeroed : boolean; { TRUE if next pass must zero histogram } - - { Variables for Floyd-Steinberg dithering } - fserrors : FS_ERROR_FIELD_PTR; { accumulated errors } - on_odd_row : boolean; { flag to remember which row we are on } - error_limiter : error_limit_ptr; { table for clamping the applied error } - end; - - - -{ Prescan some rows of pixels. - In this module the prescan simply updates the histogram, which has been - initialized to zeroes by start_pass. - An output_buf parameter is required by the method signature, but no data - is actually output (in fact the buffer controller is probably passing a - NIL pointer). } - -{METHODDEF} -procedure prescan_quantize (cinfo : j_decompress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPARRAY; - num_rows : int); -var - cquantize : my_cquantize_ptr; - {register} ptr : RGBptr; - {register} histp : histptr; - {register} histogram : hist3d; - row : int; - col : JDIMENSION; - width : JDIMENSION; -begin - cquantize := my_cquantize_ptr(cinfo^.cquantize); - histogram := cquantize^.histogram; - width := cinfo^.output_width; - - for row := 0 to pred(num_rows) do - begin - ptr := RGBptr(input_buf^[row]); - for col := pred(width) downto 0 do - begin - { get pixel value and index into the histogram } - histp := @(histogram^[GETJSAMPLE(ptr^.r) shr C0_SHIFT]^ - [GETJSAMPLE(ptr^.g) shr C1_SHIFT] - [GETJSAMPLE(ptr^.b) shr C2_SHIFT]); - { increment, check for overflow and undo increment if so. } - Inc(histp^); - if (histp^ <= 0) then - Dec(histp^); - Inc(ptr); - end; - end; -end; - -{ Next we have the really interesting routines: selection of a colormap - given the completed histogram. - These routines work with a list of "boxes", each representing a rectangular - subset of the input color space (to histogram precision). } - -type - box = record - { The bounds of the box (inclusive); expressed as histogram indexes } - c0min, c0max : int; - c1min, c1max : int; - c2min, c2max : int; - { The volume (actually 2-norm) of the box } - volume : INT32; - { The number of nonzero histogram cells within this box } - colorcount : long; - end; - -type - jBoxList = 0..(MaxInt div SizeOf(box))-1; - box_field = array[jBoxlist] of box; - boxlistptr = ^box_field; - boxptr = ^box; - -{LOCAL} -function find_biggest_color_pop (boxlist : boxlistptr; numboxes : int) : boxptr; -{ Find the splittable box with the largest color population } -{ Returns NIL if no splittable boxes remain } -var - boxp : boxptr ; {register} - i : int; {register} - maxc : long; {register} - which : boxptr; -begin - which := NIL; - boxp := @(boxlist^[0]); - maxc := 0; - for i := 0 to pred(numboxes) do - begin - if (boxp^.colorcount > maxc) and (boxp^.volume > 0) then - begin - which := boxp; - maxc := boxp^.colorcount; - end; - Inc(boxp); - end; - find_biggest_color_pop := which; -end; - - -{LOCAL} -function find_biggest_volume (boxlist : boxlistptr; numboxes : int) : boxptr; -{ Find the splittable box with the largest (scaled) volume } -{ Returns NULL if no splittable boxes remain } -var - {register} boxp : boxptr; - {register} i : int; - {register} maxv : INT32; - which : boxptr; -begin - maxv := 0; - which := NIL; - boxp := @(boxlist^[0]); - for i := 0 to pred(numboxes) do - begin - if (boxp^.volume > maxv) then - begin - which := boxp; - maxv := boxp^.volume; - end; - Inc(boxp); - end; - find_biggest_volume := which; -end; - - -{LOCAL} -procedure update_box (cinfo : j_decompress_ptr; var boxp : box); -label - have_c0min, have_c0max, - have_c1min, have_c1max, - have_c2min, have_c2max; -{ Shrink the min/max bounds of a box to enclose only nonzero elements, } -{ and recompute its volume and population } -var - cquantize : my_cquantize_ptr; - histogram : hist3d; - histp : histptr; - c0,c1,c2 : int; - c0min,c0max,c1min,c1max,c2min,c2max : int; - dist0,dist1,dist2 : INT32; - ccount : long; -begin - cquantize := my_cquantize_ptr(cinfo^.cquantize); - histogram := cquantize^.histogram; - - c0min := boxp.c0min; c0max := boxp.c0max; - c1min := boxp.c1min; c1max := boxp.c1max; - c2min := boxp.c2min; c2max := boxp.c2max; - - if (c0max > c0min) then - for c0 := c0min to c0max do - for c1 := c1min to c1max do - begin - histp := @(histogram^[c0]^[c1][c2min]); - for c2 := c2min to c2max do - begin - if (histp^ <> 0) then - begin - c0min := c0; - boxp.c0min := c0min; - goto have_c0min; - end; - Inc(histp); - end; - end; - have_c0min: - if (c0max > c0min) then - for c0 := c0max downto c0min do - for c1 := c1min to c1max do - begin - histp := @(histogram^[c0]^[c1][c2min]); - for c2 := c2min to c2max do - begin - if ( histp^ <> 0) then - begin - c0max := c0; - boxp.c0max := c0; - goto have_c0max; - end; - Inc(histp); - end; - end; - have_c0max: - if (c1max > c1min) then - for c1 := c1min to c1max do - for c0 := c0min to c0max do - begin - histp := @(histogram^[c0]^[c1][c2min]); - for c2 := c2min to c2max do - begin - if (histp^ <> 0) then - begin - c1min := c1; - boxp.c1min := c1; - goto have_c1min; - end; - Inc(histp); - end; - end; - have_c1min: - if (c1max > c1min) then - for c1 := c1max downto c1min do - for c0 := c0min to c0max do - begin - histp := @(histogram^[c0]^[c1][c2min]); - for c2 := c2min to c2max do - begin - if (histp^ <> 0) then - begin - c1max := c1; - boxp.c1max := c1; - goto have_c1max; - end; - Inc(histp); - end; - end; - have_c1max: - if (c2max > c2min) then - for c2 := c2min to c2max do - for c0 := c0min to c0max do - begin - histp := @(histogram^[c0]^[c1min][c2]); - for c1 := c1min to c1max do - begin - if (histp^ <> 0) then - begin - c2min := c2; - boxp.c2min := c2min; - goto have_c2min; - end; - Inc(histp, HIST_C2_ELEMS); - end; - end; - have_c2min: - if (c2max > c2min) then - for c2 := c2max downto c2min do - for c0 := c0min to c0max do - begin - histp := @(histogram^[c0]^[c1min][c2]); - for c1 := c1min to c1max do - begin - if (histp^ <> 0) then - begin - c2max := c2; - boxp.c2max := c2max; - goto have_c2max; - end; - Inc(histp, HIST_C2_ELEMS); - end; - end; - have_c2max: - - { Update box volume. - We use 2-norm rather than real volume here; this biases the method - against making long narrow boxes, and it has the side benefit that - a box is splittable iff norm > 0. - Since the differences are expressed in histogram-cell units, - we have to shift back to JSAMPLE units to get consistent distances; - after which, we scale according to the selected distance scale factors.} - - dist0 := ((c0max - c0min) shl C0_SHIFT) * C0_SCALE; - dist1 := ((c1max - c1min) shl C1_SHIFT) * C1_SCALE; - dist2 := ((c2max - c2min) shl C2_SHIFT) * C2_SCALE; - boxp.volume := dist0*dist0 + dist1*dist1 + dist2*dist2; - - { Now scan remaining volume of box and compute population } - ccount := 0; - for c0 := c0min to c0max do - for c1 := c1min to c1max do - begin - histp := @(histogram^[c0]^[c1][c2min]); - for c2 := c2min to c2max do - begin - if (histp^ <> 0) then - Inc(ccount); - Inc(histp); - end; - end; - boxp.colorcount := ccount; -end; - - -{LOCAL} -function median_cut (cinfo : j_decompress_ptr; boxlist : boxlistptr; - numboxes : int; desired_colors : int) : int; -{ Repeatedly select and split the largest box until we have enough boxes } -var - n,lb : int; - c0,c1,c2,cmax : int; - {register} b1,b2 : boxptr; -begin - while (numboxes < desired_colors) do - begin - { Select box to split. - Current algorithm: by population for first half, then by volume. } - - if (numboxes*2 <= desired_colors) then - b1 := find_biggest_color_pop(boxlist, numboxes) - else - b1 := find_biggest_volume(boxlist, numboxes); - - if (b1 = NIL) then { no splittable boxes left! } - break; - b2 := @(boxlist^[numboxes]); { where new box will go } - { Copy the color bounds to the new box. } - b2^.c0max := b1^.c0max; b2^.c1max := b1^.c1max; b2^.c2max := b1^.c2max; - b2^.c0min := b1^.c0min; b2^.c1min := b1^.c1min; b2^.c2min := b1^.c2min; - { Choose which axis to split the box on. - Current algorithm: longest scaled axis. - See notes in update_box about scaling distances. } - - c0 := ((b1^.c0max - b1^.c0min) shl C0_SHIFT) * C0_SCALE; - c1 := ((b1^.c1max - b1^.c1min) shl C1_SHIFT) * C1_SCALE; - c2 := ((b1^.c2max - b1^.c2min) shl C2_SHIFT) * C2_SCALE; - { We want to break any ties in favor of green, then red, blue last. - This code does the right thing for R,G,B or B,G,R color orders only. } - -{$ifdef RGB_RED_IS_0} - cmax := c1; n := 1; - if (c0 > cmax) then - begin - cmax := c0; - n := 0; - end; - if (c2 > cmax) then - n := 2; -{$else} - cmax := c1; - n := 1; - if (c2 > cmax) then - begin - cmax := c2; - n := 2; - end; - if (c0 > cmax) then - n := 0; -{$endif} - { Choose split point along selected axis, and update box bounds. - Current algorithm: split at halfway point. - (Since the box has been shrunk to minimum volume, - any split will produce two nonempty subboxes.) - Note that lb value is max for lower box, so must be < old max. } - - case n of - 0:begin - lb := (b1^.c0max + b1^.c0min) div 2; - b1^.c0max := lb; - b2^.c0min := lb+1; - end; - 1:begin - lb := (b1^.c1max + b1^.c1min) div 2; - b1^.c1max := lb; - b2^.c1min := lb+1; - end; - 2:begin - lb := (b1^.c2max + b1^.c2min) div 2; - b1^.c2max := lb; - b2^.c2min := lb+1; - end; - end; - { Update stats for boxes } - update_box(cinfo, b1^); - update_box(cinfo, b2^); - Inc(numboxes); - end; - median_cut := numboxes; -end; - - -{LOCAL} -procedure compute_color (cinfo : j_decompress_ptr; - const boxp : box; icolor : int); -{ Compute representative color for a box, put it in colormap[icolor] } -var - { Current algorithm: mean weighted by pixels (not colors) } - { Note it is important to get the rounding correct! } - cquantize : my_cquantize_ptr; - histogram : hist3d; - histp : histptr; - c0,c1,c2 : int; - c0min,c0max,c1min,c1max,c2min,c2max : int; - count : long; - total : long; - c0total : long; - c1total : long; - c2total : long; -begin - cquantize := my_cquantize_ptr(cinfo^.cquantize); - histogram := cquantize^.histogram; - total := 0; - c0total := 0; - c1total := 0; - c2total := 0; - - c0min := boxp.c0min; c0max := boxp.c0max; - c1min := boxp.c1min; c1max := boxp.c1max; - c2min := boxp.c2min; c2max := boxp.c2max; - - for c0 := c0min to c0max do - for c1 := c1min to c1max do - begin - histp := @(histogram^[c0]^[c1][c2min]); - for c2 := c2min to c2max do - begin - count := histp^; - Inc(histp); - if (count <> 0) then - begin - Inc(total, count); - Inc(c0total, ((c0 shl C0_SHIFT) + ((1 shl C0_SHIFT) shr 1)) * count); - Inc(c1total, ((c1 shl C1_SHIFT) + ((1 shl C1_SHIFT) shr 1)) * count); - Inc(c2total, ((c2 shl C2_SHIFT) + ((1 shl C2_SHIFT) shr 1)) * count); - end; - end; - end; - - cinfo^.colormap^[0]^[icolor] := JSAMPLE ((c0total + (total shr 1)) div total); - cinfo^.colormap^[1]^[icolor] := JSAMPLE ((c1total + (total shr 1)) div total); - cinfo^.colormap^[2]^[icolor] := JSAMPLE ((c2total + (total shr 1)) div total); -end; - - -{LOCAL} -procedure select_colors (cinfo : j_decompress_ptr; desired_colors : int); -{ Master routine for color selection } -var - boxlist : boxlistptr; - numboxes : int; - i : int; -begin - { Allocate workspace for box list } - boxlist := boxlistptr(cinfo^.mem^.alloc_small( - j_common_ptr(cinfo), JPOOL_IMAGE, desired_colors * SIZEOF(box))); - { Initialize one box containing whole space } - numboxes := 1; - boxlist^[0].c0min := 0; - boxlist^[0].c0max := MAXJSAMPLE shr C0_SHIFT; - boxlist^[0].c1min := 0; - boxlist^[0].c1max := MAXJSAMPLE shr C1_SHIFT; - boxlist^[0].c2min := 0; - boxlist^[0].c2max := MAXJSAMPLE shr C2_SHIFT; - { Shrink it to actually-used volume and set its statistics } - update_box(cinfo, boxlist^[0]); - { Perform median-cut to produce final box list } - numboxes := median_cut(cinfo, boxlist, numboxes, desired_colors); - { Compute the representative color for each box, fill colormap } - for i := 0 to pred(numboxes) do - compute_color(cinfo, boxlist^[i], i); - cinfo^.actual_number_of_colors := numboxes; - {$IFDEF DEBUG} - TRACEMS1(j_common_ptr(cinfo), 1, JTRC_QUANT_SELECTED, numboxes); - {$ENDIF} -end; - - -{ These routines are concerned with the time-critical task of mapping input - colors to the nearest color in the selected colormap. - - We re-use the histogram space as an "inverse color map", essentially a - cache for the results of nearest-color searches. All colors within a - histogram cell will be mapped to the same colormap entry, namely the one - closest to the cell's center. This may not be quite the closest entry to - the actual input color, but it's almost as good. A zero in the cache - indicates we haven't found the nearest color for that cell yet; the array - is cleared to zeroes before starting the mapping pass. When we find the - nearest color for a cell, its colormap index plus one is recorded in the - cache for future use. The pass2 scanning routines call fill_inverse_cmap - when they need to use an unfilled entry in the cache. - - Our method of efficiently finding nearest colors is based on the "locally - sorted search" idea described by Heckbert and on the incremental distance - calculation described by Spencer W. Thomas in chapter III.1 of Graphics - Gems II (James Arvo, ed. Academic Press, 1991). Thomas points out that - the distances from a given colormap entry to each cell of the histogram can - be computed quickly using an incremental method: the differences between - distances to adjacent cells themselves differ by a constant. This allows a - fairly fast implementation of the "brute force" approach of computing the - distance from every colormap entry to every histogram cell. Unfortunately, - it needs a work array to hold the best-distance-so-far for each histogram - cell (because the inner loop has to be over cells, not colormap entries). - The work array elements have to be INT32s, so the work array would need - 256Kb at our recommended precision. This is not feasible in DOS machines. - - To get around these problems, we apply Thomas' method to compute the - nearest colors for only the cells within a small subbox of the histogram. - The work array need be only as big as the subbox, so the memory usage - problem is solved. Furthermore, we need not fill subboxes that are never - referenced in pass2; many images use only part of the color gamut, so a - fair amount of work is saved. An additional advantage of this - approach is that we can apply Heckbert's locality criterion to quickly - eliminate colormap entries that are far away from the subbox; typically - three-fourths of the colormap entries are rejected by Heckbert's criterion, - and we need not compute their distances to individual cells in the subbox. - The speed of this approach is heavily influenced by the subbox size: too - small means too much overhead, too big loses because Heckbert's criterion - can't eliminate as many colormap entries. Empirically the best subbox - size seems to be about 1/512th of the histogram (1/8th in each direction). - - Thomas' article also describes a refined method which is asymptotically - faster than the brute-force method, but it is also far more complex and - cannot efficiently be applied to small subboxes. It is therefore not - useful for programs intended to be portable to DOS machines. On machines - with plenty of memory, filling the whole histogram in one shot with Thomas' - refined method might be faster than the present code --- but then again, - it might not be any faster, and it's certainly more complicated. } - - - -{ log2(histogram cells in update box) for each axis; this can be adjusted } -const - BOX_C0_LOG = (HIST_C0_BITS-3); - BOX_C1_LOG = (HIST_C1_BITS-3); - BOX_C2_LOG = (HIST_C2_BITS-3); - - BOX_C0_ELEMS = (1 shl BOX_C0_LOG); { # of hist cells in update box } - BOX_C1_ELEMS = (1 shl BOX_C1_LOG); - BOX_C2_ELEMS = (1 shl BOX_C2_LOG); - - BOX_C0_SHIFT = (C0_SHIFT + BOX_C0_LOG); - BOX_C1_SHIFT = (C1_SHIFT + BOX_C1_LOG); - BOX_C2_SHIFT = (C2_SHIFT + BOX_C2_LOG); - - -{ The next three routines implement inverse colormap filling. They could - all be folded into one big routine, but splitting them up this way saves - some stack space (the mindist[] and bestdist[] arrays need not coexist) - and may allow some compilers to produce better code by registerizing more - inner-loop variables. } - -{LOCAL} -function find_nearby_colors (cinfo : j_decompress_ptr; - minc0 : int; minc1 : int; minc2 : int; - var colorlist : array of JSAMPLE) : int; -{ Locate the colormap entries close enough to an update box to be candidates - for the nearest entry to some cell(s) in the update box. The update box - is specified by the center coordinates of its first cell. The number of - candidate colormap entries is returned, and their colormap indexes are - placed in colorlist[]. - This routine uses Heckbert's "locally sorted search" criterion to select - the colors that need further consideration. } - -var - numcolors : int; - maxc0, maxc1, maxc2 : int; - centerc0, centerc1, centerc2 : int; - i, x, ncolors : int; - minmaxdist, min_dist, max_dist, tdist : INT32; - mindist : array[0..MAXNUMCOLORS-1] of INT32; - { min distance to colormap entry i } -begin - numcolors := cinfo^.actual_number_of_colors; - - { Compute true coordinates of update box's upper corner and center. - Actually we compute the coordinates of the center of the upper-corner - histogram cell, which are the upper bounds of the volume we care about. - Note that since ">>" rounds down, the "center" values may be closer to - min than to max; hence comparisons to them must be "<=", not "<". } - - maxc0 := minc0 + ((1 shl BOX_C0_SHIFT) - (1 shl C0_SHIFT)); - centerc0 := (minc0 + maxc0) shr 1; - maxc1 := minc1 + ((1 shl BOX_C1_SHIFT) - (1 shl C1_SHIFT)); - centerc1 := (minc1 + maxc1) shr 1; - maxc2 := minc2 + ((1 shl BOX_C2_SHIFT) - (1 shl C2_SHIFT)); - centerc2 := (minc2 + maxc2) shr 1; - - { For each color in colormap, find: - 1. its minimum squared-distance to any point in the update box - (zero if color is within update box); - 2. its maximum squared-distance to any point in the update box. - Both of these can be found by considering only the corners of the box. - We save the minimum distance for each color in mindist[]; - only the smallest maximum distance is of interest. } - - minmaxdist := long($7FFFFFFF); - - for i := 0 to pred(numcolors) do - begin - { We compute the squared-c0-distance term, then add in the other two. } - x := GETJSAMPLE(cinfo^.colormap^[0]^[i]); - if (x < minc0) then - begin - tdist := (x - minc0) * C0_SCALE; - min_dist := tdist*tdist; - tdist := (x - maxc0) * C0_SCALE; - max_dist := tdist*tdist; - end - else - if (x > maxc0) then - begin - tdist := (x - maxc0) * C0_SCALE; - min_dist := tdist*tdist; - tdist := (x - minc0) * C0_SCALE; - max_dist := tdist*tdist; - end - else - begin - { within cell range so no contribution to min_dist } - min_dist := 0; - if (x <= centerc0) then - begin - tdist := (x - maxc0) * C0_SCALE; - max_dist := tdist*tdist; - end - else - begin - tdist := (x - minc0) * C0_SCALE; - max_dist := tdist*tdist; - end; - end; - - x := GETJSAMPLE(cinfo^.colormap^[1]^[i]); - if (x < minc1) then - begin - tdist := (x - minc1) * C1_SCALE; - Inc(min_dist, tdist*tdist); - tdist := (x - maxc1) * C1_SCALE; - Inc(max_dist, tdist*tdist); - end - else - if (x > maxc1) then - begin - tdist := (x - maxc1) * C1_SCALE; - Inc(min_dist, tdist*tdist); - tdist := (x - minc1) * C1_SCALE; - Inc(max_dist, tdist*tdist); - end - else - begin - { within cell range so no contribution to min_dist } - if (x <= centerc1) then - begin - tdist := (x - maxc1) * C1_SCALE; - Inc(max_dist, tdist*tdist); - end - else - begin - tdist := (x - minc1) * C1_SCALE; - Inc(max_dist, tdist*tdist); - end - end; - - x := GETJSAMPLE(cinfo^.colormap^[2]^[i]); - if (x < minc2) then - begin - tdist := (x - minc2) * C2_SCALE; - Inc(min_dist, tdist*tdist); - tdist := (x - maxc2) * C2_SCALE; - Inc(max_dist, tdist*tdist); - end - else - if (x > maxc2) then - begin - tdist := (x - maxc2) * C2_SCALE; - Inc(min_dist, tdist*tdist); - tdist := (x - minc2) * C2_SCALE; - Inc(max_dist, tdist*tdist); - end - else - begin - { within cell range so no contribution to min_dist } - if (x <= centerc2) then - begin - tdist := (x - maxc2) * C2_SCALE; - Inc(max_dist, tdist*tdist); - end - else - begin - tdist := (x - minc2) * C2_SCALE; - Inc(max_dist, tdist*tdist); - end; - end; - - mindist[i] := min_dist; { save away the results } - if (max_dist < minmaxdist) then - minmaxdist := max_dist; - end; - - { Now we know that no cell in the update box is more than minmaxdist - away from some colormap entry. Therefore, only colors that are - within minmaxdist of some part of the box need be considered. } - - ncolors := 0; - for i := 0 to pred(numcolors) do - begin - if (mindist[i] <= minmaxdist) then - begin - colorlist[ncolors] := JSAMPLE(i); - Inc(ncolors); - end; - end; - find_nearby_colors := ncolors; -end; - - -{LOCAL} -procedure find_best_colors (cinfo : j_decompress_ptr; - minc0 : int; minc1 : int; minc2 : int; - numcolors : int; - var colorlist : array of JSAMPLE; - var bestcolor : array of JSAMPLE); -{ Find the closest colormap entry for each cell in the update box, - given the list of candidate colors prepared by find_nearby_colors. - Return the indexes of the closest entries in the bestcolor[] array. - This routine uses Thomas' incremental distance calculation method to - find the distance from a colormap entry to successive cells in the box. } -const - { Nominal steps between cell centers ("x" in Thomas article) } - STEP_C0 = ((1 shl C0_SHIFT) * C0_SCALE); - STEP_C1 = ((1 shl C1_SHIFT) * C1_SCALE); - STEP_C2 = ((1 shl C2_SHIFT) * C2_SCALE); -var - ic0, ic1, ic2 : int; - i, icolor : int; - {register} bptr : INT32PTR; { pointer into bestdist[] array } - cptr : JSAMPLE_PTR; { pointer into bestcolor[] array } - dist0, dist1 : INT32; { initial distance values } - {register} dist2 : INT32; { current distance in inner loop } - xx0, xx1 : INT32; { distance increments } - {register} xx2 : INT32; - inc0, inc1, inc2 : INT32; { initial values for increments } - { This array holds the distance to the nearest-so-far color for each cell } - bestdist : array[0..BOX_C0_ELEMS * BOX_C1_ELEMS * BOX_C2_ELEMS-1] of INT32; -begin - { Initialize best-distance for each cell of the update box } - for i := BOX_C0_ELEMS*BOX_C1_ELEMS*BOX_C2_ELEMS-1 downto 0 do - bestdist[i] := $7FFFFFFF; - - { For each color selected by find_nearby_colors, - compute its distance to the center of each cell in the box. - If that's less than best-so-far, update best distance and color number. } - - - - for i := 0 to pred(numcolors) do - begin - icolor := GETJSAMPLE(colorlist[i]); - { Compute (square of) distance from minc0/c1/c2 to this color } - inc0 := (minc0 - GETJSAMPLE(cinfo^.colormap^[0]^[icolor])) * C0_SCALE; - dist0 := inc0*inc0; - inc1 := (minc1 - GETJSAMPLE(cinfo^.colormap^[1]^[icolor])) * C1_SCALE; - Inc(dist0, inc1*inc1); - inc2 := (minc2 - GETJSAMPLE(cinfo^.colormap^[2]^[icolor])) * C2_SCALE; - Inc(dist0, inc2*inc2); - { Form the initial difference increments } - inc0 := inc0 * (2 * STEP_C0) + STEP_C0 * STEP_C0; - inc1 := inc1 * (2 * STEP_C1) + STEP_C1 * STEP_C1; - inc2 := inc2 * (2 * STEP_C2) + STEP_C2 * STEP_C2; - { Now loop over all cells in box, updating distance per Thomas method } - bptr := @bestdist[0]; - cptr := @bestcolor[0]; - xx0 := inc0; - for ic0 := BOX_C0_ELEMS-1 downto 0 do - begin - dist1 := dist0; - xx1 := inc1; - for ic1 := BOX_C1_ELEMS-1 downto 0 do - begin - dist2 := dist1; - xx2 := inc2; - for ic2 := BOX_C2_ELEMS-1 downto 0 do - begin - if (dist2 < bptr^) then - begin - bptr^ := dist2; - cptr^ := JSAMPLE (icolor); - end; - Inc(dist2, xx2); - Inc(xx2, 2 * STEP_C2 * STEP_C2); - Inc(bptr); - Inc(cptr); - end; - Inc(dist1, xx1); - Inc(xx1, 2 * STEP_C1 * STEP_C1); - end; - Inc(dist0, xx0); - Inc(xx0, 2 * STEP_C0 * STEP_C0); - end; - end; -end; - - -{LOCAL} -procedure fill_inverse_cmap (cinfo : j_decompress_ptr; - c0 : int; c1 : int; c2 : int); -{ Fill the inverse-colormap entries in the update box that contains } -{ histogram cell c0/c1/c2. (Only that one cell MUST be filled, but } -{ we can fill as many others as we wish.) } -var - cquantize : my_cquantize_ptr; - histogram : hist3d; - minc0, minc1, minc2 : int; { lower left corner of update box } - ic0, ic1, ic2 : int; - {register} cptr : JSAMPLE_PTR; { pointer into bestcolor[] array } - {register} cachep : histptr; { pointer into main cache array } - { This array lists the candidate colormap indexes. } - colorlist : array[0..MAXNUMCOLORS-1] of JSAMPLE; - numcolors : int; { number of candidate colors } - { This array holds the actually closest colormap index for each cell. } - bestcolor : array[0..BOX_C0_ELEMS * BOX_C1_ELEMS * BOX_C2_ELEMS-1] of JSAMPLE; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - histogram := cquantize^.histogram; - - { Convert cell coordinates to update box ID } - c0 := c0 shr BOX_C0_LOG; - c1 := c1 shr BOX_C1_LOG; - c2 := c2 shr BOX_C2_LOG; - - { Compute true coordinates of update box's origin corner. - Actually we compute the coordinates of the center of the corner - histogram cell, which are the lower bounds of the volume we care about.} - - minc0 := (c0 shl BOX_C0_SHIFT) + ((1 shl C0_SHIFT) shr 1); - minc1 := (c1 shl BOX_C1_SHIFT) + ((1 shl C1_SHIFT) shr 1); - minc2 := (c2 shl BOX_C2_SHIFT) + ((1 shl C2_SHIFT) shr 1); - - { Determine which colormap entries are close enough to be candidates - for the nearest entry to some cell in the update box. } - - numcolors := find_nearby_colors(cinfo, minc0, minc1, minc2, colorlist); - - { Determine the actually nearest colors. } - find_best_colors(cinfo, minc0, minc1, minc2, numcolors, colorlist, - bestcolor); - - { Save the best color numbers (plus 1) in the main cache array } - c0 := c0 shl BOX_C0_LOG; { convert ID back to base cell indexes } - c1 := c1 shl BOX_C1_LOG; - c2 := c2 shl BOX_C2_LOG; - cptr := @(bestcolor[0]); - for ic0 := 0 to pred(BOX_C0_ELEMS) do - for ic1 := 0 to pred(BOX_C1_ELEMS) do - begin - cachep := @(histogram^[c0+ic0]^[c1+ic1][c2]); - for ic2 := 0 to pred(BOX_C2_ELEMS) do - begin - cachep^ := histcell (GETJSAMPLE(cptr^) + 1); - Inc(cachep); - Inc(cptr); - end; - end; -end; - - -{ Map some rows of pixels to the output colormapped representation. } - -{METHODDEF} -procedure pass2_no_dither (cinfo : j_decompress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPARRAY; - num_rows : int); -{ This version performs no dithering } -var - cquantize : my_cquantize_ptr; - histogram : hist3d; - {register} inptr : RGBptr; - outptr : JSAMPLE_PTR; - {register} cachep : histptr; - {register} c0, c1, c2 : int; - row : int; - col : JDIMENSION; - width : JDIMENSION; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - histogram := cquantize^.histogram; - width := cinfo^.output_width; - - for row := 0 to pred(num_rows) do - begin - inptr := RGBptr(input_buf^[row]); - outptr := JSAMPLE_PTR(output_buf^[row]); - for col := pred(width) downto 0 do - begin - { get pixel value and index into the cache } - c0 := GETJSAMPLE(inptr^.r) shr C0_SHIFT; - c1 := GETJSAMPLE(inptr^.g) shr C1_SHIFT; - c2 := GETJSAMPLE(inptr^.b) shr C2_SHIFT; - Inc(inptr); - cachep := @(histogram^[c0]^[c1][c2]); - { If we have not seen this color before, find nearest colormap entry } - { and update the cache } - if (cachep^ = 0) then - fill_inverse_cmap(cinfo, c0,c1,c2); - { Now emit the colormap index for this cell } - outptr^ := JSAMPLE (cachep^ - 1); - Inc(outptr); - end; - end; -end; - - -{METHODDEF} -procedure pass2_fs_dither (cinfo : j_decompress_ptr; - input_buf : JSAMPARRAY; - output_buf : JSAMPARRAY; - num_rows : int); -{ This version performs Floyd-Steinberg dithering } -var - cquantize : my_cquantize_ptr; - histogram : hist3d; - {register} cur : LOCRGB_FSERROR; { current error or pixel value } - belowerr : LOCRGB_FSERROR; { error for pixel below cur } - bpreverr : LOCRGB_FSERROR; { error for below/prev col } - prev_errorptr, - {register} errorptr : RGB_FSERROR_PTR; { => fserrors[] at column before current } - inptr : RGBptr; { => current input pixel } - outptr : JSAMPLE_PTR; { => current output pixel } - cachep : histptr; - dir : int; { +1 or -1 depending on direction } - row : int; - col : JDIMENSION; - width : JDIMENSION; - range_limit : range_limit_table_ptr; - error_limit : error_limit_ptr; - colormap0 : JSAMPROW; - colormap1 : JSAMPROW; - colormap2 : JSAMPROW; - {register} pixcode : int; - {register} bnexterr, delta : LOCFSERROR; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - histogram := cquantize^.histogram; - width := cinfo^.output_width; - range_limit := cinfo^.sample_range_limit; - error_limit := cquantize^.error_limiter; - colormap0 := cinfo^.colormap^[0]; - colormap1 := cinfo^.colormap^[1]; - colormap2 := cinfo^.colormap^[2]; - - for row := 0 to pred(num_rows) do - begin - inptr := RGBptr(input_buf^[row]); - outptr := JSAMPLE_PTR(output_buf^[row]); - errorptr := RGB_FSERROR_PTR(cquantize^.fserrors); { => entry before first real column } - if (cquantize^.on_odd_row) then - begin - { work right to left in this row } - Inc(inptr, (width-1)); { so point to rightmost pixel } - Inc(outptr, width-1); - dir := -1; - Inc(errorptr, (width+1)); { => entry after last column } - cquantize^.on_odd_row := FALSE; { flip for next time } - end - else - begin - { work left to right in this row } - dir := 1; - cquantize^.on_odd_row := TRUE; { flip for next time } - end; - - { Preset error values: no error propagated to first pixel from left } - cur.r := 0; - cur.g := 0; - cur.b := 0; - { and no error propagated to row below yet } - belowerr.r := 0; - belowerr.g := 0; - belowerr.b := 0; - bpreverr.r := 0; - bpreverr.g := 0; - bpreverr.b := 0; - - for col := pred(width) downto 0 do - begin - prev_errorptr := errorptr; - Inc(errorptr, dir); { advance errorptr to current column } - - { curN holds the error propagated from the previous pixel on the - current line. Add the error propagated from the previous line - to form the complete error correction term for this pixel, and - round the error term (which is expressed * 16) to an integer. - RIGHT_SHIFT rounds towards minus infinity, so adding 8 is correct - for either sign of the error value. - Note: prev_errorptr points to *previous* column's array entry. } - - { Nomssi Note: Borland Pascal SHR is unsigned } - cur.r := (cur.r + errorptr^.r + 8) div 16; - cur.g := (cur.g + errorptr^.g + 8) div 16; - cur.b := (cur.b + errorptr^.b + 8) div 16; - { Limit the error using transfer function set by init_error_limit. - See comments with init_error_limit for rationale. } - - cur.r := error_limit^[cur.r]; - cur.g := error_limit^[cur.g]; - cur.b := error_limit^[cur.b]; - { Form pixel value + error, and range-limit to 0..MAXJSAMPLE. - The maximum error is +- MAXJSAMPLE (or less with error limiting); - this sets the required size of the range_limit array. } - - Inc(cur.r, GETJSAMPLE(inptr^.r)); - Inc(cur.g, GETJSAMPLE(inptr^.g)); - Inc(cur.b, GETJSAMPLE(inptr^.b)); - - cur.r := GETJSAMPLE(range_limit^[cur.r]); - cur.g := GETJSAMPLE(range_limit^[cur.g]); - cur.b := GETJSAMPLE(range_limit^[cur.b]); - { Index into the cache with adjusted pixel value } - cachep := @(histogram^[cur.r shr C0_SHIFT]^ - [cur.g shr C1_SHIFT][cur.b shr C2_SHIFT]); - { If we have not seen this color before, find nearest colormap } - { entry and update the cache } - if (cachep^ = 0) then - fill_inverse_cmap(cinfo, cur.r shr C0_SHIFT, - cur.g shr C1_SHIFT, - cur.b shr C2_SHIFT); - { Now emit the colormap index for this cell } - - pixcode := cachep^ - 1; - outptr^ := JSAMPLE (pixcode); - - { Compute representation error for this pixel } - Dec(cur.r, GETJSAMPLE(colormap0^[pixcode])); - Dec(cur.g, GETJSAMPLE(colormap1^[pixcode])); - Dec(cur.b, GETJSAMPLE(colormap2^[pixcode])); - - { Compute error fractions to be propagated to adjacent pixels. - Add these into the running sums, and simultaneously shift the - next-line error sums left by 1 column. } - - bnexterr := cur.r; { Process component 0 } - delta := cur.r * 2; - Inc(cur.r, delta); { form error * 3 } - prev_errorptr^.r := FSERROR (bpreverr.r + cur.r); - Inc(cur.r, delta); { form error * 5 } - bpreverr.r := belowerr.r + cur.r; - belowerr.r := bnexterr; - Inc(cur.r, delta); { form error * 7 } - bnexterr := cur.g; { Process component 1 } - delta := cur.g * 2; - Inc(cur.g, delta); { form error * 3 } - prev_errorptr^.g := FSERROR (bpreverr.g + cur.g); - Inc(cur.g, delta); { form error * 5 } - bpreverr.g := belowerr.g + cur.g; - belowerr.g := bnexterr; - Inc(cur.g, delta); { form error * 7 } - bnexterr := cur.b; { Process component 2 } - delta := cur.b * 2; - Inc(cur.b, delta); { form error * 3 } - prev_errorptr^.b := FSERROR (bpreverr.b + cur.b); - Inc(cur.b, delta); { form error * 5 } - bpreverr.b := belowerr.b + cur.b; - belowerr.b := bnexterr; - Inc(cur.b, delta); { form error * 7 } - - { At this point curN contains the 7/16 error value to be propagated - to the next pixel on the current line, and all the errors for the - next line have been shifted over. We are therefore ready to move on.} - - Inc(inptr, dir); { Advance pixel pointers to next column } - Inc(outptr, dir); - end; - { Post-loop cleanup: we must unload the final error values into the - final fserrors[] entry. Note we need not unload belowerrN because - it is for the dummy column before or after the actual array. } - - errorptr^.r := FSERROR (bpreverr.r); { unload prev errs into array } - errorptr^.g := FSERROR (bpreverr.g); - errorptr^.b := FSERROR (bpreverr.b); - end; -end; - - -{ Initialize the error-limiting transfer function (lookup table). - The raw F-S error computation can potentially compute error values of up to - +- MAXJSAMPLE. But we want the maximum correction applied to a pixel to be - much less, otherwise obviously wrong pixels will be created. (Typical - effects include weird fringes at color-area boundaries, isolated bright - pixels in a dark area, etc.) The standard advice for avoiding this problem - is to ensure that the "corners" of the color cube are allocated as output - colors; then repeated errors in the same direction cannot cause cascading - error buildup. However, that only prevents the error from getting - completely out of hand; Aaron Giles reports that error limiting improves - the results even with corner colors allocated. - A simple clamping of the error values to about +- MAXJSAMPLE/8 works pretty - well, but the smoother transfer function used below is even better. Thanks - to Aaron Giles for this idea. } - -{LOCAL} -procedure init_error_limit (cinfo : j_decompress_ptr); -const - STEPSIZE = ((MAXJSAMPLE+1) div 16); -{ Allocate and fill in the error_limiter table } -var - cquantize : my_cquantize_ptr; - table : error_limit_ptr; - inp, out : int; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - table := error_limit_ptr (cinfo^.mem^.alloc_small - (j_common_ptr (cinfo), JPOOL_IMAGE, (MAXJSAMPLE*2+1) * SIZEOF(int))); - { not needed: Inc(table, MAXJSAMPLE); - so can index -MAXJSAMPLE .. +MAXJSAMPLE } - cquantize^.error_limiter := table; - { Map errors 1:1 up to +- MAXJSAMPLE/16 } - out := 0; - for inp := 0 to pred(STEPSIZE) do - begin - table^[inp] := out; - table^[-inp] := -out; - Inc(out); - end; - { Map errors 1:2 up to +- 3*MAXJSAMPLE/16 } - inp := STEPSIZE; { Nomssi: avoid problems with Delphi2 optimizer } - while (inp < STEPSIZE*3) do - begin - table^[inp] := out; - table^[-inp] := -out; - Inc(inp); - if Odd(inp) then - Inc(out); - end; - { Clamp the rest to final out value (which is (MAXJSAMPLE+1)/8) } - inp := STEPSIZE*3; { Nomssi: avoid problems with Delphi 2 optimizer } - while inp <= MAXJSAMPLE do - begin - table^[inp] := out; - table^[-inp] := -out; - Inc(inp); - end; -end; - -{ Finish up at the end of each pass. } - -{METHODDEF} -procedure finish_pass1 (cinfo : j_decompress_ptr); -var - cquantize : my_cquantize_ptr; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - - { Select the representative colors and fill in cinfo^.colormap } - cinfo^.colormap := cquantize^.sv_colormap; - select_colors(cinfo, cquantize^.desired); - { Force next pass to zero the color index table } - cquantize^.needs_zeroed := TRUE; -end; - - -{METHODDEF} -procedure finish_pass2 (cinfo : j_decompress_ptr); -begin - { no work } -end; - - -{ Initialize for each processing pass. } - -{METHODDEF} -procedure start_pass_2_quant (cinfo : j_decompress_ptr; - is_pre_scan : boolean); -var - cquantize : my_cquantize_ptr; - histogram : hist3d; - i : int; -var - arraysize : size_t; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - histogram := cquantize^.histogram; - { Only F-S dithering or no dithering is supported. } - { If user asks for ordered dither, give him F-S. } - if (cinfo^.dither_mode <> JDITHER_NONE) then - cinfo^.dither_mode := JDITHER_FS; - - if (is_pre_scan) then - begin - { Set up method pointers } - cquantize^.pub.color_quantize := prescan_quantize; - cquantize^.pub.finish_pass := finish_pass1; - cquantize^.needs_zeroed := TRUE; { Always zero histogram } - end - else - begin - { Set up method pointers } - if (cinfo^.dither_mode = JDITHER_FS) then - cquantize^.pub.color_quantize := pass2_fs_dither - else - cquantize^.pub.color_quantize := pass2_no_dither; - cquantize^.pub.finish_pass := finish_pass2; - - { Make sure color count is acceptable } - i := cinfo^.actual_number_of_colors; - if (i < 1) then - ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_FEW_COLORS, 1); - if (i > MAXNUMCOLORS) then - ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_MANY_COLORS, MAXNUMCOLORS); - - if (cinfo^.dither_mode = JDITHER_FS) then - begin - arraysize := size_t ((cinfo^.output_width + 2) * - (3 * SIZEOF(FSERROR))); - { Allocate Floyd-Steinberg workspace if we didn't already. } - if (cquantize^.fserrors = NIL) then - cquantize^.fserrors := FS_ERROR_FIELD_PTR (cinfo^.mem^.alloc_large - (j_common_ptr(cinfo), JPOOL_IMAGE, arraysize)); - { Initialize the propagated errors to zero. } - jzero_far(cquantize^.fserrors, arraysize); - { Make the error-limit table if we didn't already. } - if (cquantize^.error_limiter = NIL) then - init_error_limit(cinfo); - cquantize^.on_odd_row := FALSE; - end; - - end; - { Zero the histogram or inverse color map, if necessary } - if (cquantize^.needs_zeroed) then - begin - for i := 0 to pred(HIST_C0_ELEMS) do - begin - jzero_far( histogram^[i], - HIST_C1_ELEMS*HIST_C2_ELEMS * SIZEOF(histcell)); - end; - cquantize^.needs_zeroed := FALSE; - end; -end; - - -{ Switch to a new external colormap between output passes. } - -{METHODDEF} -procedure new_color_map_2_quant (cinfo : j_decompress_ptr); -var - cquantize : my_cquantize_ptr; -begin - cquantize := my_cquantize_ptr (cinfo^.cquantize); - - { Reset the inverse color map } - cquantize^.needs_zeroed := TRUE; -end; - - -{ Module initialization routine for 2-pass color quantization. } - - -{GLOBAL} -procedure jinit_2pass_quantizer (cinfo : j_decompress_ptr); -var - cquantize : my_cquantize_ptr; - i : int; -var - desired : int; -begin - cquantize := my_cquantize_ptr( - cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, - SIZEOF(my_cquantizer))); - cinfo^.cquantize := jpeg_color_quantizer_ptr(cquantize); - cquantize^.pub.start_pass := start_pass_2_quant; - cquantize^.pub.new_color_map := new_color_map_2_quant; - cquantize^.fserrors := NIL; { flag optional arrays not allocated } - cquantize^.error_limiter := NIL; - - { Make sure jdmaster didn't give me a case I can't handle } - if (cinfo^.out_color_components <> 3) then - ERREXIT(j_common_ptr(cinfo), JERR_NOTIMPL); - - { Allocate the histogram/inverse colormap storage } - cquantize^.histogram := hist3d (cinfo^.mem^.alloc_small - (j_common_ptr (cinfo), JPOOL_IMAGE, HIST_C0_ELEMS * SIZEOF(hist2d))); - for i := 0 to pred(HIST_C0_ELEMS) do - begin - cquantize^.histogram^[i] := hist2d (cinfo^.mem^.alloc_large - (j_common_ptr (cinfo), JPOOL_IMAGE, - HIST_C1_ELEMS*HIST_C2_ELEMS * SIZEOF(histcell))); - end; - cquantize^.needs_zeroed := TRUE; { histogram is garbage now } - - { Allocate storage for the completed colormap, if required. - We do this now since it is FAR storage and may affect - the memory manager's space calculations. } - - if (cinfo^.enable_2pass_quant) then - begin - { Make sure color count is acceptable } - desired := cinfo^.desired_number_of_colors; - { Lower bound on # of colors ... somewhat arbitrary as long as > 0 } - if (desired < 8) then - ERREXIT1(j_common_ptr (cinfo), JERR_QUANT_FEW_COLORS, 8); - { Make sure colormap indexes can be represented by JSAMPLEs } - if (desired > MAXNUMCOLORS) then - ERREXIT1(j_common_ptr (cinfo), JERR_QUANT_MANY_COLORS, MAXNUMCOLORS); - cquantize^.sv_colormap := cinfo^.mem^.alloc_sarray - (j_common_ptr (cinfo),JPOOL_IMAGE, JDIMENSION(desired), JDIMENSION(3)); - cquantize^.desired := desired; - end - else - cquantize^.sv_colormap := NIL; - - { Only F-S dithering or no dithering is supported. } - { If user asks for ordered dither, give him F-S. } - if (cinfo^.dither_mode <> JDITHER_NONE) then - cinfo^.dither_mode := JDITHER_FS; - - { Allocate Floyd-Steinberg workspace if necessary. - This isn't really needed until pass 2, but again it is FAR storage. - Although we will cope with a later change in dither_mode, - we do not promise to honor max_memory_to_use if dither_mode changes. } - - if (cinfo^.dither_mode = JDITHER_FS) then - begin - cquantize^.fserrors := FS_ERROR_FIELD_PTR (cinfo^.mem^.alloc_large - (j_common_ptr(cinfo), JPOOL_IMAGE, - size_t ((cinfo^.output_width + 2) * (3 * SIZEOF(FSERROR))) ) ); - { Might as well create the error-limiting table too. } - init_error_limit(cinfo); - end; -end; -{ QUANT_2PASS_SUPPORTED } -end. +unit imjquant2; + + +{ This file contains 2-pass color quantization (color mapping) routines. + These routines provide selection of a custom color map for an image, + followed by mapping of the image to that color map, with optional + Floyd-Steinberg dithering. + It is also possible to use just the second pass to map to an arbitrary + externally-given color map. + + Note: ordered dithering is not supported, since there isn't any fast + way to compute intercolor distances; it's unclear that ordered dither's + fundamental assumptions even hold with an irregularly spaced color map. } + +{ Original: jquant2.c; Copyright (C) 1991-1996, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjdeferr, + imjerror, + imjutils, + imjpeglib; + +{ Module initialization routine for 2-pass color quantization. } + + +{GLOBAL} +procedure jinit_2pass_quantizer (cinfo : j_decompress_ptr); + +implementation + +{ This module implements the well-known Heckbert paradigm for color + quantization. Most of the ideas used here can be traced back to + Heckbert's seminal paper + Heckbert, Paul. "Color Image Quantization for Frame Buffer Display", + Proc. SIGGRAPH '82, Computer Graphics v.16 #3 (July 1982), pp 297-304. + + In the first pass over the image, we accumulate a histogram showing the + usage count of each possible color. To keep the histogram to a reasonable + size, we reduce the precision of the input; typical practice is to retain + 5 or 6 bits per color, so that 8 or 4 different input values are counted + in the same histogram cell. + + Next, the color-selection step begins with a box representing the whole + color space, and repeatedly splits the "largest" remaining box until we + have as many boxes as desired colors. Then the mean color in each + remaining box becomes one of the possible output colors. + + The second pass over the image maps each input pixel to the closest output + color (optionally after applying a Floyd-Steinberg dithering correction). + This mapping is logically trivial, but making it go fast enough requires + considerable care. + + Heckbert-style quantizers vary a good deal in their policies for choosing + the "largest" box and deciding where to cut it. The particular policies + used here have proved out well in experimental comparisons, but better ones + may yet be found. + + In earlier versions of the IJG code, this module quantized in YCbCr color + space, processing the raw upsampled data without a color conversion step. + This allowed the color conversion math to be done only once per colormap + entry, not once per pixel. However, that optimization precluded other + useful optimizations (such as merging color conversion with upsampling) + and it also interfered with desired capabilities such as quantizing to an + externally-supplied colormap. We have therefore abandoned that approach. + The present code works in the post-conversion color space, typically RGB. + + To improve the visual quality of the results, we actually work in scaled + RGB space, giving G distances more weight than R, and R in turn more than + B. To do everything in integer math, we must use integer scale factors. + The 2/3/1 scale factors used here correspond loosely to the relative + weights of the colors in the NTSC grayscale equation. + If you want to use this code to quantize a non-RGB color space, you'll + probably need to change these scale factors. } + +const + R_SCALE = 2; { scale R distances by this much } + G_SCALE = 3; { scale G distances by this much } + B_SCALE = 1; { and B by this much } + +{ Relabel R/G/B as components 0/1/2, respecting the RGB ordering defined + in jmorecfg.h. As the code stands, it will do the right thing for R,G,B + and B,G,R orders. If you define some other weird order in jmorecfg.h, + you'll get compile errors until you extend this logic. In that case + you'll probably want to tweak the histogram sizes too. } + +{$ifdef RGB_RED_IS_0} +const + C0_SCALE = R_SCALE; + C1_SCALE = G_SCALE; + C2_SCALE = B_SCALE; +{$else} +const + C0_SCALE = B_SCALE; + C1_SCALE = G_SCALE; + C2_SCALE = R_SCALE; +{$endif} + + +{ First we have the histogram data structure and routines for creating it. + + The number of bits of precision can be adjusted by changing these symbols. + We recommend keeping 6 bits for G and 5 each for R and B. + If you have plenty of memory and cycles, 6 bits all around gives marginally + better results; if you are short of memory, 5 bits all around will save + some space but degrade the results. + To maintain a fully accurate histogram, we'd need to allocate a "long" + (preferably unsigned long) for each cell. In practice this is overkill; + we can get by with 16 bits per cell. Few of the cell counts will overflow, + and clamping those that do overflow to the maximum value will give close- + enough results. This reduces the recommended histogram size from 256Kb + to 128Kb, which is a useful savings on PC-class machines. + (In the second pass the histogram space is re-used for pixel mapping data; + in that capacity, each cell must be able to store zero to the number of + desired colors. 16 bits/cell is plenty for that too.) + Since the JPEG code is intended to run in small memory model on 80x86 + machines, we can't just allocate the histogram in one chunk. Instead + of a true 3-D array, we use a row of pointers to 2-D arrays. Each + pointer corresponds to a C0 value (typically 2^5 = 32 pointers) and + each 2-D array has 2^6*2^5 = 2048 or 2^6*2^6 = 4096 entries. Note that + on 80x86 machines, the pointer row is in near memory but the actual + arrays are in far memory (same arrangement as we use for image arrays). } + + +const + MAXNUMCOLORS = (MAXJSAMPLE+1); { maximum size of colormap } + +{ These will do the right thing for either R,G,B or B,G,R color order, + but you may not like the results for other color orders. } + +const + HIST_C0_BITS = 5; { bits of precision in R/B histogram } + HIST_C1_BITS = 6; { bits of precision in G histogram } + HIST_C2_BITS = 5; { bits of precision in B/R histogram } + +{ Number of elements along histogram axes. } +const + HIST_C0_ELEMS = (1 shl HIST_C0_BITS); + HIST_C1_ELEMS = (1 shl HIST_C1_BITS); + HIST_C2_ELEMS = (1 shl HIST_C2_BITS); + +{ These are the amounts to shift an input value to get a histogram index. } +const + C0_SHIFT = (BITS_IN_JSAMPLE-HIST_C0_BITS); + C1_SHIFT = (BITS_IN_JSAMPLE-HIST_C1_BITS); + C2_SHIFT = (BITS_IN_JSAMPLE-HIST_C2_BITS); + + +type { Nomssi } + RGBptr = ^RGBtype; + RGBtype = packed record + r,g,b : JSAMPLE; + end; +type + histcell = UINT16; { histogram cell; prefer an unsigned type } + +type + histptr = ^histcell {FAR}; { for pointers to histogram cells } + +type + hist1d = array[0..HIST_C2_ELEMS-1] of histcell; { typedefs for the array } + {hist1d_ptr = ^hist1d;} + hist1d_field = array[0..HIST_C1_ELEMS-1] of hist1d; + { type for the 2nd-level pointers } + hist2d = ^hist1d_field; + hist2d_field = array[0..HIST_C0_ELEMS-1] of hist2d; + hist3d = ^hist2d_field; { type for top-level pointer } + + +{ Declarations for Floyd-Steinberg dithering. + + Errors are accumulated into the array fserrors[], at a resolution of + 1/16th of a pixel count. The error at a given pixel is propagated + to its not-yet-processed neighbors using the standard F-S fractions, + ... (here) 7/16 + 3/16 5/16 1/16 + We work left-to-right on even rows, right-to-left on odd rows. + + We can get away with a single array (holding one row's worth of errors) + by using it to store the current row's errors at pixel columns not yet + processed, but the next row's errors at columns already processed. We + need only a few extra variables to hold the errors immediately around the + current column. (If we are lucky, those variables are in registers, but + even if not, they're probably cheaper to access than array elements are.) + + The fserrors[] array has (#columns + 2) entries; the extra entry at + each end saves us from special-casing the first and last pixels. + Each entry is three values long, one value for each color component. + + Note: on a wide image, we might not have enough room in a PC's near data + segment to hold the error array; so it is allocated with alloc_large. } + + +{$ifdef BITS_IN_JSAMPLE_IS_8} +type + FSERROR = INT16; { 16 bits should be enough } + LOCFSERROR = int; { use 'int' for calculation temps } +{$else} +type + FSERROR = INT32; { may need more than 16 bits } + LOCFSERROR = INT32; { be sure calculation temps are big enough } +{$endif} +type { Nomssi } + RGB_FSERROR_PTR = ^RGB_FSERROR; + RGB_FSERROR = packed record + r,g,b : FSERROR; + end; + LOCRGB_FSERROR = packed record + r,g,b : LOCFSERROR; + end; + +type + FSERROR_PTR = ^FSERROR; + jFSError = 0..(MaxInt div SIZEOF(RGB_FSERROR))-1; + FS_ERROR_FIELD = array[jFSError] of RGB_FSERROR; + FS_ERROR_FIELD_PTR = ^FS_ERROR_FIELD;{far} + { pointer to error array (in FAR storage!) } + +type + error_limit_array = array[-MAXJSAMPLE..MAXJSAMPLE] of int; + { table for clamping the applied error } + error_limit_ptr = ^error_limit_array; + +{ Private subobject } +type + my_cquantize_ptr = ^my_cquantizer; + my_cquantizer = record + pub : jpeg_color_quantizer; { public fields } + + { Space for the eventually created colormap is stashed here } + sv_colormap : JSAMPARRAY; { colormap allocated at init time } + desired : int; { desired # of colors = size of colormap } + + { Variables for accumulating image statistics } + histogram : hist3d; { pointer to the histogram } + + needs_zeroed : boolean; { TRUE if next pass must zero histogram } + + { Variables for Floyd-Steinberg dithering } + fserrors : FS_ERROR_FIELD_PTR; { accumulated errors } + on_odd_row : boolean; { flag to remember which row we are on } + error_limiter : error_limit_ptr; { table for clamping the applied error } + end; + + + +{ Prescan some rows of pixels. + In this module the prescan simply updates the histogram, which has been + initialized to zeroes by start_pass. + An output_buf parameter is required by the method signature, but no data + is actually output (in fact the buffer controller is probably passing a + NIL pointer). } + +{METHODDEF} +procedure prescan_quantize (cinfo : j_decompress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPARRAY; + num_rows : int); +var + cquantize : my_cquantize_ptr; + {register} ptr : RGBptr; + {register} histp : histptr; + {register} histogram : hist3d; + row : int; + col : JDIMENSION; + width : JDIMENSION; +begin + cquantize := my_cquantize_ptr(cinfo^.cquantize); + histogram := cquantize^.histogram; + width := cinfo^.output_width; + + for row := 0 to pred(num_rows) do + begin + ptr := RGBptr(input_buf^[row]); + for col := pred(width) downto 0 do + begin + { get pixel value and index into the histogram } + histp := @(histogram^[GETJSAMPLE(ptr^.r) shr C0_SHIFT]^ + [GETJSAMPLE(ptr^.g) shr C1_SHIFT] + [GETJSAMPLE(ptr^.b) shr C2_SHIFT]); + { increment, check for overflow and undo increment if so. } + Inc(histp^); + if (histp^ <= 0) then + Dec(histp^); + Inc(ptr); + end; + end; +end; + +{ Next we have the really interesting routines: selection of a colormap + given the completed histogram. + These routines work with a list of "boxes", each representing a rectangular + subset of the input color space (to histogram precision). } + +type + box = record + { The bounds of the box (inclusive); expressed as histogram indexes } + c0min, c0max : int; + c1min, c1max : int; + c2min, c2max : int; + { The volume (actually 2-norm) of the box } + volume : INT32; + { The number of nonzero histogram cells within this box } + colorcount : long; + end; + +type + jBoxList = 0..(MaxInt div SizeOf(box))-1; + box_field = array[jBoxlist] of box; + boxlistptr = ^box_field; + boxptr = ^box; + +{LOCAL} +function find_biggest_color_pop (boxlist : boxlistptr; numboxes : int) : boxptr; +{ Find the splittable box with the largest color population } +{ Returns NIL if no splittable boxes remain } +var + boxp : boxptr ; {register} + i : int; {register} + maxc : long; {register} + which : boxptr; +begin + which := NIL; + boxp := @(boxlist^[0]); + maxc := 0; + for i := 0 to pred(numboxes) do + begin + if (boxp^.colorcount > maxc) and (boxp^.volume > 0) then + begin + which := boxp; + maxc := boxp^.colorcount; + end; + Inc(boxp); + end; + find_biggest_color_pop := which; +end; + + +{LOCAL} +function find_biggest_volume (boxlist : boxlistptr; numboxes : int) : boxptr; +{ Find the splittable box with the largest (scaled) volume } +{ Returns NULL if no splittable boxes remain } +var + {register} boxp : boxptr; + {register} i : int; + {register} maxv : INT32; + which : boxptr; +begin + maxv := 0; + which := NIL; + boxp := @(boxlist^[0]); + for i := 0 to pred(numboxes) do + begin + if (boxp^.volume > maxv) then + begin + which := boxp; + maxv := boxp^.volume; + end; + Inc(boxp); + end; + find_biggest_volume := which; +end; + + +{LOCAL} +procedure update_box (cinfo : j_decompress_ptr; var boxp : box); +label + have_c0min, have_c0max, + have_c1min, have_c1max, + have_c2min, have_c2max; +{ Shrink the min/max bounds of a box to enclose only nonzero elements, } +{ and recompute its volume and population } +var + cquantize : my_cquantize_ptr; + histogram : hist3d; + histp : histptr; + c0,c1,c2 : int; + c0min,c0max,c1min,c1max,c2min,c2max : int; + dist0,dist1,dist2 : INT32; + ccount : long; +begin + cquantize := my_cquantize_ptr(cinfo^.cquantize); + histogram := cquantize^.histogram; + + c0min := boxp.c0min; c0max := boxp.c0max; + c1min := boxp.c1min; c1max := boxp.c1max; + c2min := boxp.c2min; c2max := boxp.c2max; + + if (c0max > c0min) then + for c0 := c0min to c0max do + for c1 := c1min to c1max do + begin + histp := @(histogram^[c0]^[c1][c2min]); + for c2 := c2min to c2max do + begin + if (histp^ <> 0) then + begin + c0min := c0; + boxp.c0min := c0min; + goto have_c0min; + end; + Inc(histp); + end; + end; + have_c0min: + if (c0max > c0min) then + for c0 := c0max downto c0min do + for c1 := c1min to c1max do + begin + histp := @(histogram^[c0]^[c1][c2min]); + for c2 := c2min to c2max do + begin + if ( histp^ <> 0) then + begin + c0max := c0; + boxp.c0max := c0; + goto have_c0max; + end; + Inc(histp); + end; + end; + have_c0max: + if (c1max > c1min) then + for c1 := c1min to c1max do + for c0 := c0min to c0max do + begin + histp := @(histogram^[c0]^[c1][c2min]); + for c2 := c2min to c2max do + begin + if (histp^ <> 0) then + begin + c1min := c1; + boxp.c1min := c1; + goto have_c1min; + end; + Inc(histp); + end; + end; + have_c1min: + if (c1max > c1min) then + for c1 := c1max downto c1min do + for c0 := c0min to c0max do + begin + histp := @(histogram^[c0]^[c1][c2min]); + for c2 := c2min to c2max do + begin + if (histp^ <> 0) then + begin + c1max := c1; + boxp.c1max := c1; + goto have_c1max; + end; + Inc(histp); + end; + end; + have_c1max: + if (c2max > c2min) then + for c2 := c2min to c2max do + for c0 := c0min to c0max do + begin + histp := @(histogram^[c0]^[c1min][c2]); + for c1 := c1min to c1max do + begin + if (histp^ <> 0) then + begin + c2min := c2; + boxp.c2min := c2min; + goto have_c2min; + end; + Inc(histp, HIST_C2_ELEMS); + end; + end; + have_c2min: + if (c2max > c2min) then + for c2 := c2max downto c2min do + for c0 := c0min to c0max do + begin + histp := @(histogram^[c0]^[c1min][c2]); + for c1 := c1min to c1max do + begin + if (histp^ <> 0) then + begin + c2max := c2; + boxp.c2max := c2max; + goto have_c2max; + end; + Inc(histp, HIST_C2_ELEMS); + end; + end; + have_c2max: + + { Update box volume. + We use 2-norm rather than real volume here; this biases the method + against making long narrow boxes, and it has the side benefit that + a box is splittable iff norm > 0. + Since the differences are expressed in histogram-cell units, + we have to shift back to JSAMPLE units to get consistent distances; + after which, we scale according to the selected distance scale factors.} + + dist0 := ((c0max - c0min) shl C0_SHIFT) * C0_SCALE; + dist1 := ((c1max - c1min) shl C1_SHIFT) * C1_SCALE; + dist2 := ((c2max - c2min) shl C2_SHIFT) * C2_SCALE; + boxp.volume := dist0*dist0 + dist1*dist1 + dist2*dist2; + + { Now scan remaining volume of box and compute population } + ccount := 0; + for c0 := c0min to c0max do + for c1 := c1min to c1max do + begin + histp := @(histogram^[c0]^[c1][c2min]); + for c2 := c2min to c2max do + begin + if (histp^ <> 0) then + Inc(ccount); + Inc(histp); + end; + end; + boxp.colorcount := ccount; +end; + + +{LOCAL} +function median_cut (cinfo : j_decompress_ptr; boxlist : boxlistptr; + numboxes : int; desired_colors : int) : int; +{ Repeatedly select and split the largest box until we have enough boxes } +var + n,lb : int; + c0,c1,c2,cmax : int; + {register} b1,b2 : boxptr; +begin + while (numboxes < desired_colors) do + begin + { Select box to split. + Current algorithm: by population for first half, then by volume. } + + if (numboxes*2 <= desired_colors) then + b1 := find_biggest_color_pop(boxlist, numboxes) + else + b1 := find_biggest_volume(boxlist, numboxes); + + if (b1 = NIL) then { no splittable boxes left! } + break; + b2 := @(boxlist^[numboxes]); { where new box will go } + { Copy the color bounds to the new box. } + b2^.c0max := b1^.c0max; b2^.c1max := b1^.c1max; b2^.c2max := b1^.c2max; + b2^.c0min := b1^.c0min; b2^.c1min := b1^.c1min; b2^.c2min := b1^.c2min; + { Choose which axis to split the box on. + Current algorithm: longest scaled axis. + See notes in update_box about scaling distances. } + + c0 := ((b1^.c0max - b1^.c0min) shl C0_SHIFT) * C0_SCALE; + c1 := ((b1^.c1max - b1^.c1min) shl C1_SHIFT) * C1_SCALE; + c2 := ((b1^.c2max - b1^.c2min) shl C2_SHIFT) * C2_SCALE; + { We want to break any ties in favor of green, then red, blue last. + This code does the right thing for R,G,B or B,G,R color orders only. } + +{$ifdef RGB_RED_IS_0} + cmax := c1; n := 1; + if (c0 > cmax) then + begin + cmax := c0; + n := 0; + end; + if (c2 > cmax) then + n := 2; +{$else} + cmax := c1; + n := 1; + if (c2 > cmax) then + begin + cmax := c2; + n := 2; + end; + if (c0 > cmax) then + n := 0; +{$endif} + { Choose split point along selected axis, and update box bounds. + Current algorithm: split at halfway point. + (Since the box has been shrunk to minimum volume, + any split will produce two nonempty subboxes.) + Note that lb value is max for lower box, so must be < old max. } + + case n of + 0:begin + lb := (b1^.c0max + b1^.c0min) div 2; + b1^.c0max := lb; + b2^.c0min := lb+1; + end; + 1:begin + lb := (b1^.c1max + b1^.c1min) div 2; + b1^.c1max := lb; + b2^.c1min := lb+1; + end; + 2:begin + lb := (b1^.c2max + b1^.c2min) div 2; + b1^.c2max := lb; + b2^.c2min := lb+1; + end; + end; + { Update stats for boxes } + update_box(cinfo, b1^); + update_box(cinfo, b2^); + Inc(numboxes); + end; + median_cut := numboxes; +end; + + +{LOCAL} +procedure compute_color (cinfo : j_decompress_ptr; + const boxp : box; icolor : int); +{ Compute representative color for a box, put it in colormap[icolor] } +var + { Current algorithm: mean weighted by pixels (not colors) } + { Note it is important to get the rounding correct! } + cquantize : my_cquantize_ptr; + histogram : hist3d; + histp : histptr; + c0,c1,c2 : int; + c0min,c0max,c1min,c1max,c2min,c2max : int; + count : long; + total : long; + c0total : long; + c1total : long; + c2total : long; +begin + cquantize := my_cquantize_ptr(cinfo^.cquantize); + histogram := cquantize^.histogram; + total := 0; + c0total := 0; + c1total := 0; + c2total := 0; + + c0min := boxp.c0min; c0max := boxp.c0max; + c1min := boxp.c1min; c1max := boxp.c1max; + c2min := boxp.c2min; c2max := boxp.c2max; + + for c0 := c0min to c0max do + for c1 := c1min to c1max do + begin + histp := @(histogram^[c0]^[c1][c2min]); + for c2 := c2min to c2max do + begin + count := histp^; + Inc(histp); + if (count <> 0) then + begin + Inc(total, count); + Inc(c0total, ((c0 shl C0_SHIFT) + ((1 shl C0_SHIFT) shr 1)) * count); + Inc(c1total, ((c1 shl C1_SHIFT) + ((1 shl C1_SHIFT) shr 1)) * count); + Inc(c2total, ((c2 shl C2_SHIFT) + ((1 shl C2_SHIFT) shr 1)) * count); + end; + end; + end; + + cinfo^.colormap^[0]^[icolor] := JSAMPLE ((c0total + (total shr 1)) div total); + cinfo^.colormap^[1]^[icolor] := JSAMPLE ((c1total + (total shr 1)) div total); + cinfo^.colormap^[2]^[icolor] := JSAMPLE ((c2total + (total shr 1)) div total); +end; + + +{LOCAL} +procedure select_colors (cinfo : j_decompress_ptr; desired_colors : int); +{ Master routine for color selection } +var + boxlist : boxlistptr; + numboxes : int; + i : int; +begin + { Allocate workspace for box list } + boxlist := boxlistptr(cinfo^.mem^.alloc_small( + j_common_ptr(cinfo), JPOOL_IMAGE, desired_colors * SIZEOF(box))); + { Initialize one box containing whole space } + numboxes := 1; + boxlist^[0].c0min := 0; + boxlist^[0].c0max := MAXJSAMPLE shr C0_SHIFT; + boxlist^[0].c1min := 0; + boxlist^[0].c1max := MAXJSAMPLE shr C1_SHIFT; + boxlist^[0].c2min := 0; + boxlist^[0].c2max := MAXJSAMPLE shr C2_SHIFT; + { Shrink it to actually-used volume and set its statistics } + update_box(cinfo, boxlist^[0]); + { Perform median-cut to produce final box list } + numboxes := median_cut(cinfo, boxlist, numboxes, desired_colors); + { Compute the representative color for each box, fill colormap } + for i := 0 to pred(numboxes) do + compute_color(cinfo, boxlist^[i], i); + cinfo^.actual_number_of_colors := numboxes; + {$IFDEF DEBUG} + TRACEMS1(j_common_ptr(cinfo), 1, JTRC_QUANT_SELECTED, numboxes); + {$ENDIF} +end; + + +{ These routines are concerned with the time-critical task of mapping input + colors to the nearest color in the selected colormap. + + We re-use the histogram space as an "inverse color map", essentially a + cache for the results of nearest-color searches. All colors within a + histogram cell will be mapped to the same colormap entry, namely the one + closest to the cell's center. This may not be quite the closest entry to + the actual input color, but it's almost as good. A zero in the cache + indicates we haven't found the nearest color for that cell yet; the array + is cleared to zeroes before starting the mapping pass. When we find the + nearest color for a cell, its colormap index plus one is recorded in the + cache for future use. The pass2 scanning routines call fill_inverse_cmap + when they need to use an unfilled entry in the cache. + + Our method of efficiently finding nearest colors is based on the "locally + sorted search" idea described by Heckbert and on the incremental distance + calculation described by Spencer W. Thomas in chapter III.1 of Graphics + Gems II (James Arvo, ed. Academic Press, 1991). Thomas points out that + the distances from a given colormap entry to each cell of the histogram can + be computed quickly using an incremental method: the differences between + distances to adjacent cells themselves differ by a constant. This allows a + fairly fast implementation of the "brute force" approach of computing the + distance from every colormap entry to every histogram cell. Unfortunately, + it needs a work array to hold the best-distance-so-far for each histogram + cell (because the inner loop has to be over cells, not colormap entries). + The work array elements have to be INT32s, so the work array would need + 256Kb at our recommended precision. This is not feasible in DOS machines. + + To get around these problems, we apply Thomas' method to compute the + nearest colors for only the cells within a small subbox of the histogram. + The work array need be only as big as the subbox, so the memory usage + problem is solved. Furthermore, we need not fill subboxes that are never + referenced in pass2; many images use only part of the color gamut, so a + fair amount of work is saved. An additional advantage of this + approach is that we can apply Heckbert's locality criterion to quickly + eliminate colormap entries that are far away from the subbox; typically + three-fourths of the colormap entries are rejected by Heckbert's criterion, + and we need not compute their distances to individual cells in the subbox. + The speed of this approach is heavily influenced by the subbox size: too + small means too much overhead, too big loses because Heckbert's criterion + can't eliminate as many colormap entries. Empirically the best subbox + size seems to be about 1/512th of the histogram (1/8th in each direction). + + Thomas' article also describes a refined method which is asymptotically + faster than the brute-force method, but it is also far more complex and + cannot efficiently be applied to small subboxes. It is therefore not + useful for programs intended to be portable to DOS machines. On machines + with plenty of memory, filling the whole histogram in one shot with Thomas' + refined method might be faster than the present code --- but then again, + it might not be any faster, and it's certainly more complicated. } + + + +{ log2(histogram cells in update box) for each axis; this can be adjusted } +const + BOX_C0_LOG = (HIST_C0_BITS-3); + BOX_C1_LOG = (HIST_C1_BITS-3); + BOX_C2_LOG = (HIST_C2_BITS-3); + + BOX_C0_ELEMS = (1 shl BOX_C0_LOG); { # of hist cells in update box } + BOX_C1_ELEMS = (1 shl BOX_C1_LOG); + BOX_C2_ELEMS = (1 shl BOX_C2_LOG); + + BOX_C0_SHIFT = (C0_SHIFT + BOX_C0_LOG); + BOX_C1_SHIFT = (C1_SHIFT + BOX_C1_LOG); + BOX_C2_SHIFT = (C2_SHIFT + BOX_C2_LOG); + + +{ The next three routines implement inverse colormap filling. They could + all be folded into one big routine, but splitting them up this way saves + some stack space (the mindist[] and bestdist[] arrays need not coexist) + and may allow some compilers to produce better code by registerizing more + inner-loop variables. } + +{LOCAL} +function find_nearby_colors (cinfo : j_decompress_ptr; + minc0 : int; minc1 : int; minc2 : int; + var colorlist : array of JSAMPLE) : int; +{ Locate the colormap entries close enough to an update box to be candidates + for the nearest entry to some cell(s) in the update box. The update box + is specified by the center coordinates of its first cell. The number of + candidate colormap entries is returned, and their colormap indexes are + placed in colorlist[]. + This routine uses Heckbert's "locally sorted search" criterion to select + the colors that need further consideration. } + +var + numcolors : int; + maxc0, maxc1, maxc2 : int; + centerc0, centerc1, centerc2 : int; + i, x, ncolors : int; + minmaxdist, min_dist, max_dist, tdist : INT32; + mindist : array[0..MAXNUMCOLORS-1] of INT32; + { min distance to colormap entry i } +begin + numcolors := cinfo^.actual_number_of_colors; + + { Compute true coordinates of update box's upper corner and center. + Actually we compute the coordinates of the center of the upper-corner + histogram cell, which are the upper bounds of the volume we care about. + Note that since ">>" rounds down, the "center" values may be closer to + min than to max; hence comparisons to them must be "<=", not "<". } + + maxc0 := minc0 + ((1 shl BOX_C0_SHIFT) - (1 shl C0_SHIFT)); + centerc0 := (minc0 + maxc0) shr 1; + maxc1 := minc1 + ((1 shl BOX_C1_SHIFT) - (1 shl C1_SHIFT)); + centerc1 := (minc1 + maxc1) shr 1; + maxc2 := minc2 + ((1 shl BOX_C2_SHIFT) - (1 shl C2_SHIFT)); + centerc2 := (minc2 + maxc2) shr 1; + + { For each color in colormap, find: + 1. its minimum squared-distance to any point in the update box + (zero if color is within update box); + 2. its maximum squared-distance to any point in the update box. + Both of these can be found by considering only the corners of the box. + We save the minimum distance for each color in mindist[]; + only the smallest maximum distance is of interest. } + + minmaxdist := long($7FFFFFFF); + + for i := 0 to pred(numcolors) do + begin + { We compute the squared-c0-distance term, then add in the other two. } + x := GETJSAMPLE(cinfo^.colormap^[0]^[i]); + if (x < minc0) then + begin + tdist := (x - minc0) * C0_SCALE; + min_dist := tdist*tdist; + tdist := (x - maxc0) * C0_SCALE; + max_dist := tdist*tdist; + end + else + if (x > maxc0) then + begin + tdist := (x - maxc0) * C0_SCALE; + min_dist := tdist*tdist; + tdist := (x - minc0) * C0_SCALE; + max_dist := tdist*tdist; + end + else + begin + { within cell range so no contribution to min_dist } + min_dist := 0; + if (x <= centerc0) then + begin + tdist := (x - maxc0) * C0_SCALE; + max_dist := tdist*tdist; + end + else + begin + tdist := (x - minc0) * C0_SCALE; + max_dist := tdist*tdist; + end; + end; + + x := GETJSAMPLE(cinfo^.colormap^[1]^[i]); + if (x < minc1) then + begin + tdist := (x - minc1) * C1_SCALE; + Inc(min_dist, tdist*tdist); + tdist := (x - maxc1) * C1_SCALE; + Inc(max_dist, tdist*tdist); + end + else + if (x > maxc1) then + begin + tdist := (x - maxc1) * C1_SCALE; + Inc(min_dist, tdist*tdist); + tdist := (x - minc1) * C1_SCALE; + Inc(max_dist, tdist*tdist); + end + else + begin + { within cell range so no contribution to min_dist } + if (x <= centerc1) then + begin + tdist := (x - maxc1) * C1_SCALE; + Inc(max_dist, tdist*tdist); + end + else + begin + tdist := (x - minc1) * C1_SCALE; + Inc(max_dist, tdist*tdist); + end + end; + + x := GETJSAMPLE(cinfo^.colormap^[2]^[i]); + if (x < minc2) then + begin + tdist := (x - minc2) * C2_SCALE; + Inc(min_dist, tdist*tdist); + tdist := (x - maxc2) * C2_SCALE; + Inc(max_dist, tdist*tdist); + end + else + if (x > maxc2) then + begin + tdist := (x - maxc2) * C2_SCALE; + Inc(min_dist, tdist*tdist); + tdist := (x - minc2) * C2_SCALE; + Inc(max_dist, tdist*tdist); + end + else + begin + { within cell range so no contribution to min_dist } + if (x <= centerc2) then + begin + tdist := (x - maxc2) * C2_SCALE; + Inc(max_dist, tdist*tdist); + end + else + begin + tdist := (x - minc2) * C2_SCALE; + Inc(max_dist, tdist*tdist); + end; + end; + + mindist[i] := min_dist; { save away the results } + if (max_dist < minmaxdist) then + minmaxdist := max_dist; + end; + + { Now we know that no cell in the update box is more than minmaxdist + away from some colormap entry. Therefore, only colors that are + within minmaxdist of some part of the box need be considered. } + + ncolors := 0; + for i := 0 to pred(numcolors) do + begin + if (mindist[i] <= minmaxdist) then + begin + colorlist[ncolors] := JSAMPLE(i); + Inc(ncolors); + end; + end; + find_nearby_colors := ncolors; +end; + + +{LOCAL} +procedure find_best_colors (cinfo : j_decompress_ptr; + minc0 : int; minc1 : int; minc2 : int; + numcolors : int; + var colorlist : array of JSAMPLE; + var bestcolor : array of JSAMPLE); +{ Find the closest colormap entry for each cell in the update box, + given the list of candidate colors prepared by find_nearby_colors. + Return the indexes of the closest entries in the bestcolor[] array. + This routine uses Thomas' incremental distance calculation method to + find the distance from a colormap entry to successive cells in the box. } +const + { Nominal steps between cell centers ("x" in Thomas article) } + STEP_C0 = ((1 shl C0_SHIFT) * C0_SCALE); + STEP_C1 = ((1 shl C1_SHIFT) * C1_SCALE); + STEP_C2 = ((1 shl C2_SHIFT) * C2_SCALE); +var + ic0, ic1, ic2 : int; + i, icolor : int; + {register} bptr : INT32PTR; { pointer into bestdist[] array } + cptr : JSAMPLE_PTR; { pointer into bestcolor[] array } + dist0, dist1 : INT32; { initial distance values } + {register} dist2 : INT32; { current distance in inner loop } + xx0, xx1 : INT32; { distance increments } + {register} xx2 : INT32; + inc0, inc1, inc2 : INT32; { initial values for increments } + { This array holds the distance to the nearest-so-far color for each cell } + bestdist : array[0..BOX_C0_ELEMS * BOX_C1_ELEMS * BOX_C2_ELEMS-1] of INT32; +begin + { Initialize best-distance for each cell of the update box } + for i := BOX_C0_ELEMS*BOX_C1_ELEMS*BOX_C2_ELEMS-1 downto 0 do + bestdist[i] := $7FFFFFFF; + + { For each color selected by find_nearby_colors, + compute its distance to the center of each cell in the box. + If that's less than best-so-far, update best distance and color number. } + + + + for i := 0 to pred(numcolors) do + begin + icolor := GETJSAMPLE(colorlist[i]); + { Compute (square of) distance from minc0/c1/c2 to this color } + inc0 := (minc0 - GETJSAMPLE(cinfo^.colormap^[0]^[icolor])) * C0_SCALE; + dist0 := inc0*inc0; + inc1 := (minc1 - GETJSAMPLE(cinfo^.colormap^[1]^[icolor])) * C1_SCALE; + Inc(dist0, inc1*inc1); + inc2 := (minc2 - GETJSAMPLE(cinfo^.colormap^[2]^[icolor])) * C2_SCALE; + Inc(dist0, inc2*inc2); + { Form the initial difference increments } + inc0 := inc0 * (2 * STEP_C0) + STEP_C0 * STEP_C0; + inc1 := inc1 * (2 * STEP_C1) + STEP_C1 * STEP_C1; + inc2 := inc2 * (2 * STEP_C2) + STEP_C2 * STEP_C2; + { Now loop over all cells in box, updating distance per Thomas method } + bptr := @bestdist[0]; + cptr := @bestcolor[0]; + xx0 := inc0; + for ic0 := BOX_C0_ELEMS-1 downto 0 do + begin + dist1 := dist0; + xx1 := inc1; + for ic1 := BOX_C1_ELEMS-1 downto 0 do + begin + dist2 := dist1; + xx2 := inc2; + for ic2 := BOX_C2_ELEMS-1 downto 0 do + begin + if (dist2 < bptr^) then + begin + bptr^ := dist2; + cptr^ := JSAMPLE (icolor); + end; + Inc(dist2, xx2); + Inc(xx2, 2 * STEP_C2 * STEP_C2); + Inc(bptr); + Inc(cptr); + end; + Inc(dist1, xx1); + Inc(xx1, 2 * STEP_C1 * STEP_C1); + end; + Inc(dist0, xx0); + Inc(xx0, 2 * STEP_C0 * STEP_C0); + end; + end; +end; + + +{LOCAL} +procedure fill_inverse_cmap (cinfo : j_decompress_ptr; + c0 : int; c1 : int; c2 : int); +{ Fill the inverse-colormap entries in the update box that contains } +{ histogram cell c0/c1/c2. (Only that one cell MUST be filled, but } +{ we can fill as many others as we wish.) } +var + cquantize : my_cquantize_ptr; + histogram : hist3d; + minc0, minc1, minc2 : int; { lower left corner of update box } + ic0, ic1, ic2 : int; + {register} cptr : JSAMPLE_PTR; { pointer into bestcolor[] array } + {register} cachep : histptr; { pointer into main cache array } + { This array lists the candidate colormap indexes. } + colorlist : array[0..MAXNUMCOLORS-1] of JSAMPLE; + numcolors : int; { number of candidate colors } + { This array holds the actually closest colormap index for each cell. } + bestcolor : array[0..BOX_C0_ELEMS * BOX_C1_ELEMS * BOX_C2_ELEMS-1] of JSAMPLE; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + histogram := cquantize^.histogram; + + { Convert cell coordinates to update box ID } + c0 := c0 shr BOX_C0_LOG; + c1 := c1 shr BOX_C1_LOG; + c2 := c2 shr BOX_C2_LOG; + + { Compute true coordinates of update box's origin corner. + Actually we compute the coordinates of the center of the corner + histogram cell, which are the lower bounds of the volume we care about.} + + minc0 := (c0 shl BOX_C0_SHIFT) + ((1 shl C0_SHIFT) shr 1); + minc1 := (c1 shl BOX_C1_SHIFT) + ((1 shl C1_SHIFT) shr 1); + minc2 := (c2 shl BOX_C2_SHIFT) + ((1 shl C2_SHIFT) shr 1); + + { Determine which colormap entries are close enough to be candidates + for the nearest entry to some cell in the update box. } + + numcolors := find_nearby_colors(cinfo, minc0, minc1, minc2, colorlist); + + { Determine the actually nearest colors. } + find_best_colors(cinfo, minc0, minc1, minc2, numcolors, colorlist, + bestcolor); + + { Save the best color numbers (plus 1) in the main cache array } + c0 := c0 shl BOX_C0_LOG; { convert ID back to base cell indexes } + c1 := c1 shl BOX_C1_LOG; + c2 := c2 shl BOX_C2_LOG; + cptr := @(bestcolor[0]); + for ic0 := 0 to pred(BOX_C0_ELEMS) do + for ic1 := 0 to pred(BOX_C1_ELEMS) do + begin + cachep := @(histogram^[c0+ic0]^[c1+ic1][c2]); + for ic2 := 0 to pred(BOX_C2_ELEMS) do + begin + cachep^ := histcell (GETJSAMPLE(cptr^) + 1); + Inc(cachep); + Inc(cptr); + end; + end; +end; + + +{ Map some rows of pixels to the output colormapped representation. } + +{METHODDEF} +procedure pass2_no_dither (cinfo : j_decompress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPARRAY; + num_rows : int); +{ This version performs no dithering } +var + cquantize : my_cquantize_ptr; + histogram : hist3d; + {register} inptr : RGBptr; + outptr : JSAMPLE_PTR; + {register} cachep : histptr; + {register} c0, c1, c2 : int; + row : int; + col : JDIMENSION; + width : JDIMENSION; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + histogram := cquantize^.histogram; + width := cinfo^.output_width; + + for row := 0 to pred(num_rows) do + begin + inptr := RGBptr(input_buf^[row]); + outptr := JSAMPLE_PTR(output_buf^[row]); + for col := pred(width) downto 0 do + begin + { get pixel value and index into the cache } + c0 := GETJSAMPLE(inptr^.r) shr C0_SHIFT; + c1 := GETJSAMPLE(inptr^.g) shr C1_SHIFT; + c2 := GETJSAMPLE(inptr^.b) shr C2_SHIFT; + Inc(inptr); + cachep := @(histogram^[c0]^[c1][c2]); + { If we have not seen this color before, find nearest colormap entry } + { and update the cache } + if (cachep^ = 0) then + fill_inverse_cmap(cinfo, c0,c1,c2); + { Now emit the colormap index for this cell } + outptr^ := JSAMPLE (cachep^ - 1); + Inc(outptr); + end; + end; +end; + + +{METHODDEF} +procedure pass2_fs_dither (cinfo : j_decompress_ptr; + input_buf : JSAMPARRAY; + output_buf : JSAMPARRAY; + num_rows : int); +{ This version performs Floyd-Steinberg dithering } +var + cquantize : my_cquantize_ptr; + histogram : hist3d; + {register} cur : LOCRGB_FSERROR; { current error or pixel value } + belowerr : LOCRGB_FSERROR; { error for pixel below cur } + bpreverr : LOCRGB_FSERROR; { error for below/prev col } + prev_errorptr, + {register} errorptr : RGB_FSERROR_PTR; { => fserrors[] at column before current } + inptr : RGBptr; { => current input pixel } + outptr : JSAMPLE_PTR; { => current output pixel } + cachep : histptr; + dir : int; { +1 or -1 depending on direction } + row : int; + col : JDIMENSION; + width : JDIMENSION; + range_limit : range_limit_table_ptr; + error_limit : error_limit_ptr; + colormap0 : JSAMPROW; + colormap1 : JSAMPROW; + colormap2 : JSAMPROW; + {register} pixcode : int; + {register} bnexterr, delta : LOCFSERROR; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + histogram := cquantize^.histogram; + width := cinfo^.output_width; + range_limit := cinfo^.sample_range_limit; + error_limit := cquantize^.error_limiter; + colormap0 := cinfo^.colormap^[0]; + colormap1 := cinfo^.colormap^[1]; + colormap2 := cinfo^.colormap^[2]; + + for row := 0 to pred(num_rows) do + begin + inptr := RGBptr(input_buf^[row]); + outptr := JSAMPLE_PTR(output_buf^[row]); + errorptr := RGB_FSERROR_PTR(cquantize^.fserrors); { => entry before first real column } + if (cquantize^.on_odd_row) then + begin + { work right to left in this row } + Inc(inptr, (width-1)); { so point to rightmost pixel } + Inc(outptr, width-1); + dir := -1; + Inc(errorptr, (width+1)); { => entry after last column } + cquantize^.on_odd_row := FALSE; { flip for next time } + end + else + begin + { work left to right in this row } + dir := 1; + cquantize^.on_odd_row := TRUE; { flip for next time } + end; + + { Preset error values: no error propagated to first pixel from left } + cur.r := 0; + cur.g := 0; + cur.b := 0; + { and no error propagated to row below yet } + belowerr.r := 0; + belowerr.g := 0; + belowerr.b := 0; + bpreverr.r := 0; + bpreverr.g := 0; + bpreverr.b := 0; + + for col := pred(width) downto 0 do + begin + prev_errorptr := errorptr; + Inc(errorptr, dir); { advance errorptr to current column } + + { curN holds the error propagated from the previous pixel on the + current line. Add the error propagated from the previous line + to form the complete error correction term for this pixel, and + round the error term (which is expressed * 16) to an integer. + RIGHT_SHIFT rounds towards minus infinity, so adding 8 is correct + for either sign of the error value. + Note: prev_errorptr points to *previous* column's array entry. } + + { Nomssi Note: Borland Pascal SHR is unsigned } + cur.r := (cur.r + errorptr^.r + 8) div 16; + cur.g := (cur.g + errorptr^.g + 8) div 16; + cur.b := (cur.b + errorptr^.b + 8) div 16; + { Limit the error using transfer function set by init_error_limit. + See comments with init_error_limit for rationale. } + + cur.r := error_limit^[cur.r]; + cur.g := error_limit^[cur.g]; + cur.b := error_limit^[cur.b]; + { Form pixel value + error, and range-limit to 0..MAXJSAMPLE. + The maximum error is +- MAXJSAMPLE (or less with error limiting); + this sets the required size of the range_limit array. } + + Inc(cur.r, GETJSAMPLE(inptr^.r)); + Inc(cur.g, GETJSAMPLE(inptr^.g)); + Inc(cur.b, GETJSAMPLE(inptr^.b)); + + cur.r := GETJSAMPLE(range_limit^[cur.r]); + cur.g := GETJSAMPLE(range_limit^[cur.g]); + cur.b := GETJSAMPLE(range_limit^[cur.b]); + { Index into the cache with adjusted pixel value } + cachep := @(histogram^[cur.r shr C0_SHIFT]^ + [cur.g shr C1_SHIFT][cur.b shr C2_SHIFT]); + { If we have not seen this color before, find nearest colormap } + { entry and update the cache } + if (cachep^ = 0) then + fill_inverse_cmap(cinfo, cur.r shr C0_SHIFT, + cur.g shr C1_SHIFT, + cur.b shr C2_SHIFT); + { Now emit the colormap index for this cell } + + pixcode := cachep^ - 1; + outptr^ := JSAMPLE (pixcode); + + { Compute representation error for this pixel } + Dec(cur.r, GETJSAMPLE(colormap0^[pixcode])); + Dec(cur.g, GETJSAMPLE(colormap1^[pixcode])); + Dec(cur.b, GETJSAMPLE(colormap2^[pixcode])); + + { Compute error fractions to be propagated to adjacent pixels. + Add these into the running sums, and simultaneously shift the + next-line error sums left by 1 column. } + + bnexterr := cur.r; { Process component 0 } + delta := cur.r * 2; + Inc(cur.r, delta); { form error * 3 } + prev_errorptr^.r := FSERROR (bpreverr.r + cur.r); + Inc(cur.r, delta); { form error * 5 } + bpreverr.r := belowerr.r + cur.r; + belowerr.r := bnexterr; + Inc(cur.r, delta); { form error * 7 } + bnexterr := cur.g; { Process component 1 } + delta := cur.g * 2; + Inc(cur.g, delta); { form error * 3 } + prev_errorptr^.g := FSERROR (bpreverr.g + cur.g); + Inc(cur.g, delta); { form error * 5 } + bpreverr.g := belowerr.g + cur.g; + belowerr.g := bnexterr; + Inc(cur.g, delta); { form error * 7 } + bnexterr := cur.b; { Process component 2 } + delta := cur.b * 2; + Inc(cur.b, delta); { form error * 3 } + prev_errorptr^.b := FSERROR (bpreverr.b + cur.b); + Inc(cur.b, delta); { form error * 5 } + bpreverr.b := belowerr.b + cur.b; + belowerr.b := bnexterr; + Inc(cur.b, delta); { form error * 7 } + + { At this point curN contains the 7/16 error value to be propagated + to the next pixel on the current line, and all the errors for the + next line have been shifted over. We are therefore ready to move on.} + + Inc(inptr, dir); { Advance pixel pointers to next column } + Inc(outptr, dir); + end; + { Post-loop cleanup: we must unload the final error values into the + final fserrors[] entry. Note we need not unload belowerrN because + it is for the dummy column before or after the actual array. } + + errorptr^.r := FSERROR (bpreverr.r); { unload prev errs into array } + errorptr^.g := FSERROR (bpreverr.g); + errorptr^.b := FSERROR (bpreverr.b); + end; +end; + + +{ Initialize the error-limiting transfer function (lookup table). + The raw F-S error computation can potentially compute error values of up to + +- MAXJSAMPLE. But we want the maximum correction applied to a pixel to be + much less, otherwise obviously wrong pixels will be created. (Typical + effects include weird fringes at color-area boundaries, isolated bright + pixels in a dark area, etc.) The standard advice for avoiding this problem + is to ensure that the "corners" of the color cube are allocated as output + colors; then repeated errors in the same direction cannot cause cascading + error buildup. However, that only prevents the error from getting + completely out of hand; Aaron Giles reports that error limiting improves + the results even with corner colors allocated. + A simple clamping of the error values to about +- MAXJSAMPLE/8 works pretty + well, but the smoother transfer function used below is even better. Thanks + to Aaron Giles for this idea. } + +{LOCAL} +procedure init_error_limit (cinfo : j_decompress_ptr); +const + STEPSIZE = ((MAXJSAMPLE+1) div 16); +{ Allocate and fill in the error_limiter table } +var + cquantize : my_cquantize_ptr; + table : error_limit_ptr; + inp, out : int; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + table := error_limit_ptr (cinfo^.mem^.alloc_small + (j_common_ptr (cinfo), JPOOL_IMAGE, (MAXJSAMPLE*2+1) * SIZEOF(int))); + { not needed: Inc(table, MAXJSAMPLE); + so can index -MAXJSAMPLE .. +MAXJSAMPLE } + cquantize^.error_limiter := table; + { Map errors 1:1 up to +- MAXJSAMPLE/16 } + out := 0; + for inp := 0 to pred(STEPSIZE) do + begin + table^[inp] := out; + table^[-inp] := -out; + Inc(out); + end; + { Map errors 1:2 up to +- 3*MAXJSAMPLE/16 } + inp := STEPSIZE; { Nomssi: avoid problems with Delphi2 optimizer } + while (inp < STEPSIZE*3) do + begin + table^[inp] := out; + table^[-inp] := -out; + Inc(inp); + if Odd(inp) then + Inc(out); + end; + { Clamp the rest to final out value (which is (MAXJSAMPLE+1)/8) } + inp := STEPSIZE*3; { Nomssi: avoid problems with Delphi 2 optimizer } + while inp <= MAXJSAMPLE do + begin + table^[inp] := out; + table^[-inp] := -out; + Inc(inp); + end; +end; + +{ Finish up at the end of each pass. } + +{METHODDEF} +procedure finish_pass1 (cinfo : j_decompress_ptr); +var + cquantize : my_cquantize_ptr; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + + { Select the representative colors and fill in cinfo^.colormap } + cinfo^.colormap := cquantize^.sv_colormap; + select_colors(cinfo, cquantize^.desired); + { Force next pass to zero the color index table } + cquantize^.needs_zeroed := TRUE; +end; + + +{METHODDEF} +procedure finish_pass2 (cinfo : j_decompress_ptr); +begin + { no work } +end; + + +{ Initialize for each processing pass. } + +{METHODDEF} +procedure start_pass_2_quant (cinfo : j_decompress_ptr; + is_pre_scan : boolean); +var + cquantize : my_cquantize_ptr; + histogram : hist3d; + i : int; +var + arraysize : size_t; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + histogram := cquantize^.histogram; + { Only F-S dithering or no dithering is supported. } + { If user asks for ordered dither, give him F-S. } + if (cinfo^.dither_mode <> JDITHER_NONE) then + cinfo^.dither_mode := JDITHER_FS; + + if (is_pre_scan) then + begin + { Set up method pointers } + cquantize^.pub.color_quantize := prescan_quantize; + cquantize^.pub.finish_pass := finish_pass1; + cquantize^.needs_zeroed := TRUE; { Always zero histogram } + end + else + begin + { Set up method pointers } + if (cinfo^.dither_mode = JDITHER_FS) then + cquantize^.pub.color_quantize := pass2_fs_dither + else + cquantize^.pub.color_quantize := pass2_no_dither; + cquantize^.pub.finish_pass := finish_pass2; + + { Make sure color count is acceptable } + i := cinfo^.actual_number_of_colors; + if (i < 1) then + ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_FEW_COLORS, 1); + if (i > MAXNUMCOLORS) then + ERREXIT1(j_common_ptr(cinfo), JERR_QUANT_MANY_COLORS, MAXNUMCOLORS); + + if (cinfo^.dither_mode = JDITHER_FS) then + begin + arraysize := size_t ((cinfo^.output_width + 2) * + (3 * SIZEOF(FSERROR))); + { Allocate Floyd-Steinberg workspace if we didn't already. } + if (cquantize^.fserrors = NIL) then + cquantize^.fserrors := FS_ERROR_FIELD_PTR (cinfo^.mem^.alloc_large + (j_common_ptr(cinfo), JPOOL_IMAGE, arraysize)); + { Initialize the propagated errors to zero. } + jzero_far(cquantize^.fserrors, arraysize); + { Make the error-limit table if we didn't already. } + if (cquantize^.error_limiter = NIL) then + init_error_limit(cinfo); + cquantize^.on_odd_row := FALSE; + end; + + end; + { Zero the histogram or inverse color map, if necessary } + if (cquantize^.needs_zeroed) then + begin + for i := 0 to pred(HIST_C0_ELEMS) do + begin + jzero_far( histogram^[i], + HIST_C1_ELEMS*HIST_C2_ELEMS * SIZEOF(histcell)); + end; + cquantize^.needs_zeroed := FALSE; + end; +end; + + +{ Switch to a new external colormap between output passes. } + +{METHODDEF} +procedure new_color_map_2_quant (cinfo : j_decompress_ptr); +var + cquantize : my_cquantize_ptr; +begin + cquantize := my_cquantize_ptr (cinfo^.cquantize); + + { Reset the inverse color map } + cquantize^.needs_zeroed := TRUE; +end; + + +{ Module initialization routine for 2-pass color quantization. } + + +{GLOBAL} +procedure jinit_2pass_quantizer (cinfo : j_decompress_ptr); +var + cquantize : my_cquantize_ptr; + i : int; +var + desired : int; +begin + cquantize := my_cquantize_ptr( + cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_IMAGE, + SIZEOF(my_cquantizer))); + cinfo^.cquantize := jpeg_color_quantizer_ptr(cquantize); + cquantize^.pub.start_pass := start_pass_2_quant; + cquantize^.pub.new_color_map := new_color_map_2_quant; + cquantize^.fserrors := NIL; { flag optional arrays not allocated } + cquantize^.error_limiter := NIL; + + { Make sure jdmaster didn't give me a case I can't handle } + if (cinfo^.out_color_components <> 3) then + ERREXIT(j_common_ptr(cinfo), JERR_NOTIMPL); + + { Allocate the histogram/inverse colormap storage } + cquantize^.histogram := hist3d (cinfo^.mem^.alloc_small + (j_common_ptr (cinfo), JPOOL_IMAGE, HIST_C0_ELEMS * SIZEOF(hist2d))); + for i := 0 to pred(HIST_C0_ELEMS) do + begin + cquantize^.histogram^[i] := hist2d (cinfo^.mem^.alloc_large + (j_common_ptr (cinfo), JPOOL_IMAGE, + HIST_C1_ELEMS*HIST_C2_ELEMS * SIZEOF(histcell))); + end; + cquantize^.needs_zeroed := TRUE; { histogram is garbage now } + + { Allocate storage for the completed colormap, if required. + We do this now since it is FAR storage and may affect + the memory manager's space calculations. } + + if (cinfo^.enable_2pass_quant) then + begin + { Make sure color count is acceptable } + desired := cinfo^.desired_number_of_colors; + { Lower bound on # of colors ... somewhat arbitrary as long as > 0 } + if (desired < 8) then + ERREXIT1(j_common_ptr (cinfo), JERR_QUANT_FEW_COLORS, 8); + { Make sure colormap indexes can be represented by JSAMPLEs } + if (desired > MAXNUMCOLORS) then + ERREXIT1(j_common_ptr (cinfo), JERR_QUANT_MANY_COLORS, MAXNUMCOLORS); + cquantize^.sv_colormap := cinfo^.mem^.alloc_sarray + (j_common_ptr (cinfo),JPOOL_IMAGE, JDIMENSION(desired), JDIMENSION(3)); + cquantize^.desired := desired; + end + else + cquantize^.sv_colormap := NIL; + + { Only F-S dithering or no dithering is supported. } + { If user asks for ordered dither, give him F-S. } + if (cinfo^.dither_mode <> JDITHER_NONE) then + cinfo^.dither_mode := JDITHER_FS; + + { Allocate Floyd-Steinberg workspace if necessary. + This isn't really needed until pass 2, but again it is FAR storage. + Although we will cope with a later change in dither_mode, + we do not promise to honor max_memory_to_use if dither_mode changes. } + + if (cinfo^.dither_mode = JDITHER_FS) then + begin + cquantize^.fserrors := FS_ERROR_FIELD_PTR (cinfo^.mem^.alloc_large + (j_common_ptr(cinfo), JPOOL_IMAGE, + size_t ((cinfo^.output_width + 2) * (3 * SIZEOF(FSERROR))) ) ); + { Might as well create the error-limiting table too. } + init_error_limit(cinfo); + end; +end; +{ QUANT_2PASS_SUPPORTED } +end. diff --git a/Imaging/JpegLib/imjutils.pas b/Imaging/JpegLib/imjutils.pas index eb147b9..2f78eef 100644 --- a/Imaging/JpegLib/imjutils.pas +++ b/Imaging/JpegLib/imjutils.pas @@ -1,232 +1,232 @@ -unit imjutils; - -{ This file contains tables and miscellaneous utility routines needed - for both compression and decompression. - Note we prefix all global names with "j" to minimize conflicts with - a surrounding application. } - -{ Source: jutils.c; Copyright (C) 1991-1996, Thomas G. Lane. } - -interface - -{$I imjconfig.inc} - -uses - imjmorecfg, - imjinclude, - imjpeglib; - - -{ jpeg_zigzag_order[i] is the zigzag-order position of the i'th element - of a DCT block read in natural order (left to right, top to bottom). } - - -{$ifdef FALSE} { This table is not actually needed in v6a } - -const - jpeg_zigzag_order : array[0..DCTSIZE2] of int = - (0, 1, 5, 6, 14, 15, 27, 28, - 2, 4, 7, 13, 16, 26, 29, 42, - 3, 8, 12, 17, 25, 30, 41, 43, - 9, 11, 18, 24, 31, 40, 44, 53, - 10, 19, 23, 32, 39, 45, 52, 54, - 20, 22, 33, 38, 46, 51, 55, 60, - 21, 34, 37, 47, 50, 56, 59, 61, - 35, 36, 48, 49, 57, 58, 62, 63); - -{$endif} - - -{ jpeg_natural_order[i] is the natural-order position of the i'th element - of zigzag order. - - When reading corrupted data, the Huffman decoders could attempt - to reference an entry beyond the end of this array (if the decoded - zero run length reaches past the end of the block). To prevent - wild stores without adding an inner-loop test, we put some extra - "63"s after the real entries. This will cause the extra coefficient - to be stored in location 63 of the block, not somewhere random. - The worst case would be a run-length of 15, which means we need 16 - fake entries. } - - -const - jpeg_natural_order : array[0..DCTSIZE2+16-1] of int = - (0, 1, 8, 16, 9, 2, 3, 10, - 17, 24, 32, 25, 18, 11, 4, 5, - 12, 19, 26, 33, 40, 48, 41, 34, - 27, 20, 13, 6, 7, 14, 21, 28, - 35, 42, 49, 56, 57, 50, 43, 36, - 29, 22, 15, 23, 30, 37, 44, 51, - 58, 59, 52, 45, 38, 31, 39, 46, - 53, 60, 61, 54, 47, 55, 62, 63, - 63, 63, 63, 63, 63, 63, 63, 63, { extra entries for safety in decoder } - 63, 63, 63, 63, 63, 63, 63, 63); - - - -{ Arithmetic utilities } - -{GLOBAL} -function jdiv_round_up (a : long; b : long) : long; - -{GLOBAL} -function jround_up (a : long; b : long) : long; - -{GLOBAL} -procedure jcopy_sample_rows (input_array : JSAMPARRAY; - source_row : int; - output_array : JSAMPARRAY; dest_row : int; - num_rows : int; num_cols : JDIMENSION); - -{GLOBAL} -procedure jcopy_block_row (input_row : JBLOCKROW; - output_row : JBLOCKROW; - num_blocks : JDIMENSION); - -{GLOBAL} -procedure jzero_far (target : pointer;{far} bytestozero : size_t); - -procedure FMEMZERO(target : pointer; size : size_t); - -procedure FMEMCOPY(dest,src : pointer; size : size_t); - -implementation - -{GLOBAL} -function jdiv_round_up (a : long; b : long) : long; -{ Compute a/b rounded up to next integer, ie, ceil(a/b) } -{ Assumes a >= 0, b > 0 } -begin - jdiv_round_up := (a + b - long(1)) div b; -end; - - -{GLOBAL} -function jround_up (a : long; b : long) : long; -{ Compute a rounded up to next multiple of b, ie, ceil(a/b)*b } -{ Assumes a >= 0, b > 0 } -begin - Inc(a, b - long(1)); - jround_up := a - (a mod b); -end; - -{ On normal machines we can apply MEMCOPY() and MEMZERO() to sample arrays - and coefficient-block arrays. This won't work on 80x86 because the arrays - are FAR and we're assuming a small-pointer memory model. However, some - DOS compilers provide far-pointer versions of memcpy() and memset() even - in the small-model libraries. These will be used if USE_FMEM is defined. - Otherwise, the routines below do it the hard way. (The performance cost - is not all that great, because these routines aren't very heavily used.) } - - -{$ifndef NEED_FAR_POINTERS} { normal case, same as regular macros } -procedure FMEMZERO(target : pointer; size : size_t); -begin - FillChar(target^, size, 0); -end; - -procedure FMEMCOPY(dest,src : pointer; size : size_t); -begin - Move(src^, dest^, size); -end; - - -{$else} { 80x86 case, define if we can } - {$ifdef USE_FMEM} - FMEMCOPY(dest,src,size) _fmemcpy((void FAR *)(dest), (const void FAR *)(src), (size_t)(size)) - FMEMZERO(target,size) _fmemset((void FAR *)(target), 0, (size_t)(size)) - {$endif} -{$endif} - - -{GLOBAL} -procedure jcopy_sample_rows (input_array : JSAMPARRAY; source_row : int; - output_array : JSAMPARRAY; dest_row : int; - num_rows : int; num_cols : JDIMENSION); -{ Copy some rows of samples from one place to another. - num_rows rows are copied from input_array[source_row++] - to output_array[dest_row++]; these areas may overlap for duplication. - The source and destination arrays must be at least as wide as num_cols. } -var - inptr, outptr : JSAMPLE_PTR; {register} -{$ifdef FMEMCOPY} - count : size_t; {register} -{$else} - count : JDIMENSION; {register} -{$endif} - row : int; {register} -begin -{$ifdef FMEMCOPY} - count := size_t(num_cols * SIZEOF(JSAMPLE)); -{$endif} - Inc(JSAMPROW_PTR(input_array), source_row); - Inc(JSAMPROW_PTR(output_array), dest_row); - - for row := pred(num_rows) downto 0 do - begin - inptr := JSAMPLE_PTR(input_array^[0]); - Inc(JSAMPROW_PTR(input_array)); - outptr := JSAMPLE_PTR(output_array^[0]); - Inc(JSAMPROW_PTR(output_array)); -{$ifdef FMEMCOPY} - FMEMCOPY(outptr, inptr, count); -{$else} - for count := pred(num_cols) downto 0 do - begin - outptr^ := inptr^; { needn't bother with GETJSAMPLE() here } - Inc(inptr); - Inc(outptr); - end; -{$endif} - end; -end; - - -{GLOBAL} -procedure jcopy_block_row (input_row : JBLOCKROW; - output_row : JBLOCKROW; - num_blocks : JDIMENSION); -{ Copy a row of coefficient blocks from one place to another. } -{$ifdef FMEMCOPY} -begin - FMEMCOPY(output_row, input_row, num_blocks * (DCTSIZE2 * SIZEOF(JCOEF))); -{$else} -var - inptr, outptr : JCOEFPTR; {register} - count : long; {register} -begin - inptr := JCOEFPTR (input_row); - outptr := JCOEFPTR (output_row); - for count := long(num_blocks) * DCTSIZE2 -1 downto 0 do - begin - outptr^ := inptr^; - Inc(outptr); - Inc(inptr); - end; -{$endif} -end; - - -{GLOBAL} -procedure jzero_far (target : pointer;{far} bytestozero : size_t); -{ Zero out a chunk of FAR memory. } -{ This might be sample-array data, block-array data, or alloc_large data. } -{$ifdef FMEMZERO} -begin - FMEMZERO(target, bytestozero); -{$else} -var - ptr : byteptr; - count : size_t; {register} -begin - ptr := target; - for count := bytestozero-1 downto 0 do - begin - ptr^ := 0; - Inc(ptr); - end; -{$endif} -end; - -end. +unit imjutils; + +{ This file contains tables and miscellaneous utility routines needed + for both compression and decompression. + Note we prefix all global names with "j" to minimize conflicts with + a surrounding application. } + +{ Source: jutils.c; Copyright (C) 1991-1996, Thomas G. Lane. } + +interface + +{$I imjconfig.inc} + +uses + imjmorecfg, + imjinclude, + imjpeglib; + + +{ jpeg_zigzag_order[i] is the zigzag-order position of the i'th element + of a DCT block read in natural order (left to right, top to bottom). } + + +{$ifdef FALSE} { This table is not actually needed in v6a } + +const + jpeg_zigzag_order : array[0..DCTSIZE2] of int = + (0, 1, 5, 6, 14, 15, 27, 28, + 2, 4, 7, 13, 16, 26, 29, 42, + 3, 8, 12, 17, 25, 30, 41, 43, + 9, 11, 18, 24, 31, 40, 44, 53, + 10, 19, 23, 32, 39, 45, 52, 54, + 20, 22, 33, 38, 46, 51, 55, 60, + 21, 34, 37, 47, 50, 56, 59, 61, + 35, 36, 48, 49, 57, 58, 62, 63); + +{$endif} + + +{ jpeg_natural_order[i] is the natural-order position of the i'th element + of zigzag order. + + When reading corrupted data, the Huffman decoders could attempt + to reference an entry beyond the end of this array (if the decoded + zero run length reaches past the end of the block). To prevent + wild stores without adding an inner-loop test, we put some extra + "63"s after the real entries. This will cause the extra coefficient + to be stored in location 63 of the block, not somewhere random. + The worst case would be a run-length of 15, which means we need 16 + fake entries. } + + +const + jpeg_natural_order : array[0..DCTSIZE2+16-1] of int = + (0, 1, 8, 16, 9, 2, 3, 10, + 17, 24, 32, 25, 18, 11, 4, 5, + 12, 19, 26, 33, 40, 48, 41, 34, + 27, 20, 13, 6, 7, 14, 21, 28, + 35, 42, 49, 56, 57, 50, 43, 36, + 29, 22, 15, 23, 30, 37, 44, 51, + 58, 59, 52, 45, 38, 31, 39, 46, + 53, 60, 61, 54, 47, 55, 62, 63, + 63, 63, 63, 63, 63, 63, 63, 63, { extra entries for safety in decoder } + 63, 63, 63, 63, 63, 63, 63, 63); + + + +{ Arithmetic utilities } + +{GLOBAL} +function jdiv_round_up (a : long; b : long) : long; + +{GLOBAL} +function jround_up (a : long; b : long) : long; + +{GLOBAL} +procedure jcopy_sample_rows (input_array : JSAMPARRAY; + source_row : int; + output_array : JSAMPARRAY; dest_row : int; + num_rows : int; num_cols : JDIMENSION); + +{GLOBAL} +procedure jcopy_block_row (input_row : JBLOCKROW; + output_row : JBLOCKROW; + num_blocks : JDIMENSION); + +{GLOBAL} +procedure jzero_far (target : pointer;{far} bytestozero : size_t); + +procedure FMEMZERO(target : pointer; size : size_t); + +procedure FMEMCOPY(dest,src : pointer; size : size_t); + +implementation + +{GLOBAL} +function jdiv_round_up (a : long; b : long) : long; +{ Compute a/b rounded up to next integer, ie, ceil(a/b) } +{ Assumes a >= 0, b > 0 } +begin + jdiv_round_up := (a + b - long(1)) div b; +end; + + +{GLOBAL} +function jround_up (a : long; b : long) : long; +{ Compute a rounded up to next multiple of b, ie, ceil(a/b)*b } +{ Assumes a >= 0, b > 0 } +begin + Inc(a, b - long(1)); + jround_up := a - (a mod b); +end; + +{ On normal machines we can apply MEMCOPY() and MEMZERO() to sample arrays + and coefficient-block arrays. This won't work on 80x86 because the arrays + are FAR and we're assuming a small-pointer memory model. However, some + DOS compilers provide far-pointer versions of memcpy() and memset() even + in the small-model libraries. These will be used if USE_FMEM is defined. + Otherwise, the routines below do it the hard way. (The performance cost + is not all that great, because these routines aren't very heavily used.) } + + +{$ifndef NEED_FAR_POINTERS} { normal case, same as regular macros } +procedure FMEMZERO(target : pointer; size : size_t); +begin + FillChar(target^, size, 0); +end; + +procedure FMEMCOPY(dest,src : pointer; size : size_t); +begin + Move(src^, dest^, size); +end; + + +{$else} { 80x86 case, define if we can } + {$ifdef USE_FMEM} + FMEMCOPY(dest,src,size) _fmemcpy((void FAR *)(dest), (const void FAR *)(src), (size_t)(size)) + FMEMZERO(target,size) _fmemset((void FAR *)(target), 0, (size_t)(size)) + {$endif} +{$endif} + + +{GLOBAL} +procedure jcopy_sample_rows (input_array : JSAMPARRAY; source_row : int; + output_array : JSAMPARRAY; dest_row : int; + num_rows : int; num_cols : JDIMENSION); +{ Copy some rows of samples from one place to another. + num_rows rows are copied from input_array[source_row++] + to output_array[dest_row++]; these areas may overlap for duplication. + The source and destination arrays must be at least as wide as num_cols. } +var + inptr, outptr : JSAMPLE_PTR; {register} +{$ifdef FMEMCOPY} + count : size_t; {register} +{$else} + count : JDIMENSION; {register} +{$endif} + row : int; {register} +begin +{$ifdef FMEMCOPY} + count := size_t(num_cols * SIZEOF(JSAMPLE)); +{$endif} + Inc(JSAMPROW_PTR(input_array), source_row); + Inc(JSAMPROW_PTR(output_array), dest_row); + + for row := pred(num_rows) downto 0 do + begin + inptr := JSAMPLE_PTR(input_array^[0]); + Inc(JSAMPROW_PTR(input_array)); + outptr := JSAMPLE_PTR(output_array^[0]); + Inc(JSAMPROW_PTR(output_array)); +{$ifdef FMEMCOPY} + FMEMCOPY(outptr, inptr, count); +{$else} + for count := pred(num_cols) downto 0 do + begin + outptr^ := inptr^; { needn't bother with GETJSAMPLE() here } + Inc(inptr); + Inc(outptr); + end; +{$endif} + end; +end; + + +{GLOBAL} +procedure jcopy_block_row (input_row : JBLOCKROW; + output_row : JBLOCKROW; + num_blocks : JDIMENSION); +{ Copy a row of coefficient blocks from one place to another. } +{$ifdef FMEMCOPY} +begin + FMEMCOPY(output_row, input_row, num_blocks * (DCTSIZE2 * SIZEOF(JCOEF))); +{$else} +var + inptr, outptr : JCOEFPTR; {register} + count : long; {register} +begin + inptr := JCOEFPTR (input_row); + outptr := JCOEFPTR (output_row); + for count := long(num_blocks) * DCTSIZE2 -1 downto 0 do + begin + outptr^ := inptr^; + Inc(outptr); + Inc(inptr); + end; +{$endif} +end; + + +{GLOBAL} +procedure jzero_far (target : pointer;{far} bytestozero : size_t); +{ Zero out a chunk of FAR memory. } +{ This might be sample-array data, block-array data, or alloc_large data. } +{$ifdef FMEMZERO} +begin + FMEMZERO(target, bytestozero); +{$else} +var + ptr : byteptr; + count : size_t; {register} +begin + ptr := target; + for count := bytestozero-1 downto 0 do + begin + ptr^ := 0; + Inc(ptr); + end; +{$endif} +end; + +end. diff --git a/Imaging/JpegLib/readme.txt b/Imaging/JpegLib/readme.txt index 3cbe890..bb98251 100644 --- a/Imaging/JpegLib/readme.txt +++ b/Imaging/JpegLib/readme.txt @@ -1,381 +1,381 @@ -_____________________________________________________________________________ - -PASJPEG 1.1 May 29th, 1999 - -Based on the Independent JPEG Group's JPEG software release 6b - -Copyright (C) 1996,1998,1999 by NOMSSI NZALI Jacques H. C. -[kn&n DES] See "Legal issues" for conditions of distribution and use. -_____________________________________________________________________________ - - -Information in this file -======================== - - o Introduction - o Notes - o File list - o Translation - o Legal issues - o Archive Locations - -Introduction -============ - -PASJPEG is a port of the sixth public release of the IJG C source (release -6b of 27-Mar-98) [3], that implements JPEG baseline, extended-sequential, and -progressive compression processes to Turbo Pascal 7.0 for DOS (TP). The code -has been tested under Delphi 3.0, it can be ported to other Pascal -environments, since many compilers try to be compatible to TP. - -JPEG (pronounced "jay-peg") is a standardized familly of algorithms for -compression of continous tone still images. Most JPEG processes are lossy, -the output image is not exactly identical to the input image. However, on -typical photographic images, very good compression levels can be obtained -with no visible change, and remarkably high compression levels are possible -if you can tolerate a low-quality image [1],[2]. The Independent JPEG Group -(IJG) has created a free, portable C library for JPEG compression and -decompression of JPEG images. - -The IJG documentation (system architecture, using the IJG JPEG library, -usage and file list) is a must read. The files DEMO.PAS, TEST.PAS, CJPEG.PAS, -DJPEG.PAS and EXAMPLE.PAS demonstrate the usage of the JPEG decompression -and compression library. The RDJPGCOM application shows how to parse a JFIF -file. - -Notes: -====== - -* Please report any errors/problems you may find in code and in the - documentation (e.g. this README.TXT file). - -* The sample applications (CJPEG, DJPEG) doesn't support all the options - of the original C code. WRJPGCOM is not ported. - -* Environment variable JPEGMEM syntax changed; - -* You can modify the jpeg.pas unit from the Delphi 3 distribution to - use PasJPEG. - -Change log -========== - -1. bugs fixed: - * in procedure read_gif_map(), unit RDCOLMAP.PAS (used by DJPEG sample - application). Davie Lee Reed - * -dct int and -dct fast now bytewise equal to the IJG output. - * -dct float produced large files - -2. Support for scripts - -3. BASM version of JIDCTINT.PAS for Delphi 2 and 3. - -4. images with integral sampling ratios were not decoded correctly. - Create a jpeg file with cjpeg and the option "-sample 4x1" and try to decode - it with any software that uses PasJpeg. Thanks to Jannie Gerber for reporting - this with a fix: In JDSAMPLE.PAS, procedure int_upsample(), - - for h := pred(h_expand) downto 0 do - begin - outptr^ := invalue; - +=> inc(outptr); { this is the culprit that was left out!!! } - Dec(outcount); - end; - -File list -========= - -Here is a road map to the files in the PasJPEG distribution. The -distribution includes the JPEG library proper, plus two application -programs ("cjpeg" and "djpeg") which use the library to convert JPEG -files to and from some other popular image formats. A third application -"jpegtran" uses the library to do lossless conversion between different -variants of JPEG. There is also the stand-alone applications "rdjpgcom". - -Documentation(see README for a guide to the documentation files): - -readme.txt Introduction, Documentation - -Additional files - -demo.pas Demo program, uses example.pas -example.pas Sample code for calling JPEG library. -test.pas Sample application code for demo.pas - -Configuration/installation files and programs (see install.doc for more info): - -jconfig.inc Configuration declarations. - -*.ijg script files - -Pascal source code files: - -jinclude.pas Central include file used by all IJG .c files to reference - system include files. -jpeglib.pas JPEG library's internal data structures, exported data - and function declarations. -jmorecfg.pas Additional configuration declarations; need not be changed - for a standard installation. -jdeferr.pas defines the error and message text. -jerror.pas Declares JPEG library's error and trace message codes. -jinclude.pas the place to specify system depedent input/output code. -jdct.pas Private declarations for forward & reverse DCT subsystems. - -These files contain most of the functions intended to be called directly by -an application program: - -jcapimin.pas Application program interface: core routines for compression. -jcapistd.pas Application program interface: standard compression. -jdapimin.pas Application program interface: core routines for decompression. -jdapistd.pas Application program interface: standard decompression. -jcomapi.pas Application program interface routines common to compression - and decompression. -jcparam.pas Compression parameter setting helper routines. -jctrans.pas API and library routines for transcoding compression. -jdtrans.pas API and library routines for transcoding decompression. - -Compression side of the library: - -jcinit.pas Initialization: determines which other modules to use. -jcmaster.pas Master control: setup and inter-pass sequencing logic. -jcmainct.pas Main buffer controller (preprocessor => JPEG compressor). -jcprepct.pas Preprocessor buffer controller. -jccoefct.pas Buffer controller for DCT coefficient buffer. -jccolor.pas Color space conversion. -jcsample.pas Downsampling. -jcdctmgr.pas DCT manager (DCT implementation selection & control). -jfdctint.pas Forward DCT using slow-but-accurate integer method. -jfdctfst.pas Forward DCT using faster, less accurate integer method. -jfdctflt.pas Forward DCT using floating-point arithmetic. -jchuff.pas Huffman entropy coding for sequential JPEG. -jcphuff.pas Huffman entropy coding for progressive JPEG. -jcmarker.pas JPEG marker writing. -jdatadst.pas Data destination manager for stdio output. - -Decompression side of the library: - -jdmaster.pas Master control: determines which other modules to use. -jdinput.pas Input controller: controls input processing modules. -jdmainct.pas Main buffer controller (JPEG decompressor => postprocessor). -jdcoefct.pas Buffer controller for DCT coefficient buffer. -jdpostct.pas Postprocessor buffer controller. -jdmarker.pas JPEG marker reading. -jdhuff.pas Huffman entropy decoding for sequential JPEG. -jdphuff.pas Huffman entropy decoding for progressive JPEG. -jddctmgr.pas IDCT manager (IDCT implementation selection & control). -jidctint.pas Inverse DCT using slow-but-accurate integer method. -jidctasm.pas BASM specific version of jidctint.pas for 32bit Delphi. -jidctfst.pas Inverse DCT using faster, less accurate integer method. -jidctflt.pas Inverse DCT using floating-point arithmetic. -jidctred.pas Inverse DCTs with reduced-size outputs. -jidct2d.pas How to for a direct 2D Inverse DCT - not used -jdsample.pas Upsampling. -jdcolor.pas Color space conversion. -jdmerge.pas Merged upsampling/color conversion (faster, lower quality). -jquant1.pas One-pass color quantization using a fixed-spacing colormap. -jquant2.pas Two-pass color quantization using a custom-generated colormap. - Also handles one-pass quantization to an externally given map. -jdatasrc.pas Data source manager for stdio input. - -Support files for both compression and decompression: - -jerror.pas Standard error handling routines (application replaceable). -jmemmgr.pas System-independent (more or less) memory management code. -jutils.pas Miscellaneous utility routines. - -jmemmgr.pas relies on a system-dependent memory management module. The -PASJPEG distribution includes the following implementations of the system- -dependent module: - -jmemnobs.pas "No backing store": assumes adequate virtual memory exists. -jmemdos.pas Custom implementation for MS-DOS (16-bit environment only): - can use extended and expanded memory as well as temporary - files. -jmemsys.pas A skeleton with all the declaration you need to create a - working system-dependent JPEG memory manager on unusual - systems. - -Exactly one of the system-dependent units should be used in jmemmgr.pas. - -jmemdosa.pas BASM 80x86 assembly code support for jmemdos.pas; used only - in MS-DOS-specific configurations of the JPEG library. - - -Applications using the library should use jmorecfg, jerror, jpeglib, and -include jconfig.inc. - -CJPEG/DJPEG/JPEGTRAN - -Pascal source code files: - -cderror.pas Additional error and trace message codes for cjpeg/djpeg. - Not used, Those errors have been added to jdeferr. -cjpeg.pas Main program for cjpeg. -djpeg.pas Main program for djpeg. -jpegtran.pas Main program for jpegtran. -cdjpeg.pas Utility routines used by all three programs. -rdcolmap.pas Code to read a colormap file for djpeg's "-map" switch. -rdswitch.pas Code to process some of cjpeg's more complex switches. - Also used by jpegtran. -transupp.pas Support code for jpegtran: lossless image manipulations. - -fcache.pas -rdswitch.pas Code to process some of cjpeg's more complex switches. - Also used by jpegtran. - -Image file writer modules for djpeg: - -wrbmp.pas BMP file output. -wrppm.pas PPM/PGM file output. -wrtarga.pas Targa file output. - -Image file reader modules for cjpeg: - -rdbmp.pas BMP file input. -rdppm.pas PPM/PGM file input. -rdtarga.pas Targa file input. - NOT READY YET - -This program does not depend on the JPEG library - -rdjpgcom.pas Stand-alone rdjpgcom application. - - -Translation -=========== - -TP is unit-centric, exported type definitions and routines are declared -in the "interface" part of the unit, "make" files are not needed. -Macros are not supported, they were either copied as needed or translated -to Pascal routines (procedure). The procedures will be replaced by code in -later releases. -Conditional defines that indicate whether to include various optional -functions are defined in the file JCONFIG.INC. This file is included first -in all source files. - -The base type definitions are in the unit JMORECFG.PAS. The error handling -macros have been converted to procedures in JERROR.PAS. The error codes are -in JDEFERR.PAS. jpegint.h and jpeglib.h were merged into one large unit -JPEGLIB.PAS containing type definitions with global scope. - -The translation of the header file is the most sophisticated work, a good -understanding of the syntax is required. Once the header files are done, -the translation turns into a lot of editing work. Each C source file was -converted to a unit by editing the syntax (separate variable definition -and usage, define labels, group variable definitions, expanding macros, etc). - -The IJG source labels routines GLOBAL, METHODDEF and LOCAL. All globals -routines are in the interface section of the units. The "far" directive is -used for methods (METHODDEF). - -Some C -> Pascal examples. - -* "{" -> "begin" "->" -> "^." " = " -> " := " "<<" -> " shl " - "}" -> "end;" "!=" -> "<>" " == " -> " = " ">>" -> " shr " - "/*" -> "{" routine -> function "0x" -> "$" - "*/" -> "}" (void) procedure "NULL" -> "NIL" - -* structs are records, Unions are variable records, pointers are always far, - the operators && and || (and/or) have not the same priority in both - languages, so parenthesis are important. The Pascal "case" doesn't have the - falltrough option of the C "switch" statement, my work around is to split - one "switch" statement into many case statements. -* The pointer type in C is not readily interchangeable. It is used to address - an array (Pascal pointer to an array) or in pointer arithmetic a pointer to - a single element. I've used the Inc() statement with type casting to - translate pointer arithmetic most of the time. - - C example: - typedef JSAMPLE* JSAMPROW; /* ptr to one image row of pixel samples. */ - - Pascal - type - JSAMPLE_PTR = ^JSAMPLE; { ptr to a single pixel sample. } - jTSample = 0..(MaxInt div SIZEOF(JSAMPLE))-1; - JSAMPLE_ARRAY = Array[jTSample] of JSAMPLE; {far} - JSAMPROW = ^JSAMPLE_ARRAY; { ptr to one image row of pixel samples. } - - The following code - - JSAMPROW buffer0, buffer1; /* ptr to a JSAMPLE buffer. */ - - ... - - buffer1 = buffer0 + i; - - can be translated to - - var - buffer0, buffer1 : JSAMPROW; - - ... - - buffer1 := buffer0; - Inc(JSAMPLE_PTR(buffer1), i); - - or - - buffer1 := JSAMPROW(@ buffer0^[i]); - - Declaring the variables as JSAMPLE_PTR may reduce type casting in some - places. I use help pointers to handle negative array offsets. - -While translating the type of function parameter from C to Pascal, one can -often use "var", "const", or "array of" parameters instead of pointers. - -While translating for(;;)-loops with more than one induction variable to -Pascal "for to/downto do"-loops, the extra induction variables have to be -manually updated at the end of the loop and before "continue"-statements. - - -Legal issues -============ - -Copyright (C) 1996,1998 by Jacques Nomssi Nzali - - This software is provided 'as-is', without any express or implied - warranty. In no event will the author be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - -Archive Locations: -================== - -[1] Thomas G. Lane, JPEG FAQ - - in comp.graphics.misc and related newsgroups - -[2] Wallace, Gregory K.: The JPEG Still Picture Compression Standard - - ftp.uu.net, graphics/jpeg/wallace.ps.Z - -[3] The Independent JPEG Group C library for JPEG encoding and decoding, - rev 6b. - - ftp://ftp.uu.net/graphics/jpeg/ - - or SimTel in msdos/graphics/ - -[4] JPEG implementation, written by the PVRG group at Stanford, - ftp havefun.stanford.edu:/pub/jpeg/JPEGv1.2.tar.Z. - -[5] PASJPEG.ZIP at NView ftp site - - ftp://druckfix.physik.tu-chemnitz.de/pub/nv/ - http://www.tu-chemnitz.de/~nomssi/pub/pasjpeg.zip - -[6] The PasJPEG home page with links - - http://www.tu-chemnitz.de/~nomssi/pasjpeg.html +_____________________________________________________________________________ + +PASJPEG 1.1 May 29th, 1999 + +Based on the Independent JPEG Group's JPEG software release 6b + +Copyright (C) 1996,1998,1999 by NOMSSI NZALI Jacques H. C. +[kn&n DES] See "Legal issues" for conditions of distribution and use. +_____________________________________________________________________________ + + +Information in this file +======================== + + o Introduction + o Notes + o File list + o Translation + o Legal issues + o Archive Locations + +Introduction +============ + +PASJPEG is a port of the sixth public release of the IJG C source (release +6b of 27-Mar-98) [3], that implements JPEG baseline, extended-sequential, and +progressive compression processes to Turbo Pascal 7.0 for DOS (TP). The code +has been tested under Delphi 3.0, it can be ported to other Pascal +environments, since many compilers try to be compatible to TP. + +JPEG (pronounced "jay-peg") is a standardized familly of algorithms for +compression of continous tone still images. Most JPEG processes are lossy, +the output image is not exactly identical to the input image. However, on +typical photographic images, very good compression levels can be obtained +with no visible change, and remarkably high compression levels are possible +if you can tolerate a low-quality image [1],[2]. The Independent JPEG Group +(IJG) has created a free, portable C library for JPEG compression and +decompression of JPEG images. + +The IJG documentation (system architecture, using the IJG JPEG library, +usage and file list) is a must read. The files DEMO.PAS, TEST.PAS, CJPEG.PAS, +DJPEG.PAS and EXAMPLE.PAS demonstrate the usage of the JPEG decompression +and compression library. The RDJPGCOM application shows how to parse a JFIF +file. + +Notes: +====== + +* Please report any errors/problems you may find in code and in the + documentation (e.g. this README.TXT file). + +* The sample applications (CJPEG, DJPEG) doesn't support all the options + of the original C code. WRJPGCOM is not ported. + +* Environment variable JPEGMEM syntax changed; + +* You can modify the jpeg.pas unit from the Delphi 3 distribution to + use PasJPEG. + +Change log +========== + +1. bugs fixed: + * in procedure read_gif_map(), unit RDCOLMAP.PAS (used by DJPEG sample + application). Davie Lee Reed + * -dct int and -dct fast now bytewise equal to the IJG output. + * -dct float produced large files + +2. Support for scripts + +3. BASM version of JIDCTINT.PAS for Delphi 2 and 3. + +4. images with integral sampling ratios were not decoded correctly. + Create a jpeg file with cjpeg and the option "-sample 4x1" and try to decode + it with any software that uses PasJpeg. Thanks to Jannie Gerber for reporting + this with a fix: In JDSAMPLE.PAS, procedure int_upsample(), + + for h := pred(h_expand) downto 0 do + begin + outptr^ := invalue; + +=> inc(outptr); { this is the culprit that was left out!!! } + Dec(outcount); + end; + +File list +========= + +Here is a road map to the files in the PasJPEG distribution. The +distribution includes the JPEG library proper, plus two application +programs ("cjpeg" and "djpeg") which use the library to convert JPEG +files to and from some other popular image formats. A third application +"jpegtran" uses the library to do lossless conversion between different +variants of JPEG. There is also the stand-alone applications "rdjpgcom". + +Documentation(see README for a guide to the documentation files): + +readme.txt Introduction, Documentation + +Additional files + +demo.pas Demo program, uses example.pas +example.pas Sample code for calling JPEG library. +test.pas Sample application code for demo.pas + +Configuration/installation files and programs (see install.doc for more info): + +jconfig.inc Configuration declarations. + +*.ijg script files + +Pascal source code files: + +jinclude.pas Central include file used by all IJG .c files to reference + system include files. +jpeglib.pas JPEG library's internal data structures, exported data + and function declarations. +jmorecfg.pas Additional configuration declarations; need not be changed + for a standard installation. +jdeferr.pas defines the error and message text. +jerror.pas Declares JPEG library's error and trace message codes. +jinclude.pas the place to specify system depedent input/output code. +jdct.pas Private declarations for forward & reverse DCT subsystems. + +These files contain most of the functions intended to be called directly by +an application program: + +jcapimin.pas Application program interface: core routines for compression. +jcapistd.pas Application program interface: standard compression. +jdapimin.pas Application program interface: core routines for decompression. +jdapistd.pas Application program interface: standard decompression. +jcomapi.pas Application program interface routines common to compression + and decompression. +jcparam.pas Compression parameter setting helper routines. +jctrans.pas API and library routines for transcoding compression. +jdtrans.pas API and library routines for transcoding decompression. + +Compression side of the library: + +jcinit.pas Initialization: determines which other modules to use. +jcmaster.pas Master control: setup and inter-pass sequencing logic. +jcmainct.pas Main buffer controller (preprocessor => JPEG compressor). +jcprepct.pas Preprocessor buffer controller. +jccoefct.pas Buffer controller for DCT coefficient buffer. +jccolor.pas Color space conversion. +jcsample.pas Downsampling. +jcdctmgr.pas DCT manager (DCT implementation selection & control). +jfdctint.pas Forward DCT using slow-but-accurate integer method. +jfdctfst.pas Forward DCT using faster, less accurate integer method. +jfdctflt.pas Forward DCT using floating-point arithmetic. +jchuff.pas Huffman entropy coding for sequential JPEG. +jcphuff.pas Huffman entropy coding for progressive JPEG. +jcmarker.pas JPEG marker writing. +jdatadst.pas Data destination manager for stdio output. + +Decompression side of the library: + +jdmaster.pas Master control: determines which other modules to use. +jdinput.pas Input controller: controls input processing modules. +jdmainct.pas Main buffer controller (JPEG decompressor => postprocessor). +jdcoefct.pas Buffer controller for DCT coefficient buffer. +jdpostct.pas Postprocessor buffer controller. +jdmarker.pas JPEG marker reading. +jdhuff.pas Huffman entropy decoding for sequential JPEG. +jdphuff.pas Huffman entropy decoding for progressive JPEG. +jddctmgr.pas IDCT manager (IDCT implementation selection & control). +jidctint.pas Inverse DCT using slow-but-accurate integer method. +jidctasm.pas BASM specific version of jidctint.pas for 32bit Delphi. +jidctfst.pas Inverse DCT using faster, less accurate integer method. +jidctflt.pas Inverse DCT using floating-point arithmetic. +jidctred.pas Inverse DCTs with reduced-size outputs. +jidct2d.pas How to for a direct 2D Inverse DCT - not used +jdsample.pas Upsampling. +jdcolor.pas Color space conversion. +jdmerge.pas Merged upsampling/color conversion (faster, lower quality). +jquant1.pas One-pass color quantization using a fixed-spacing colormap. +jquant2.pas Two-pass color quantization using a custom-generated colormap. + Also handles one-pass quantization to an externally given map. +jdatasrc.pas Data source manager for stdio input. + +Support files for both compression and decompression: + +jerror.pas Standard error handling routines (application replaceable). +jmemmgr.pas System-independent (more or less) memory management code. +jutils.pas Miscellaneous utility routines. + +jmemmgr.pas relies on a system-dependent memory management module. The +PASJPEG distribution includes the following implementations of the system- +dependent module: + +jmemnobs.pas "No backing store": assumes adequate virtual memory exists. +jmemdos.pas Custom implementation for MS-DOS (16-bit environment only): + can use extended and expanded memory as well as temporary + files. +jmemsys.pas A skeleton with all the declaration you need to create a + working system-dependent JPEG memory manager on unusual + systems. + +Exactly one of the system-dependent units should be used in jmemmgr.pas. + +jmemdosa.pas BASM 80x86 assembly code support for jmemdos.pas; used only + in MS-DOS-specific configurations of the JPEG library. + + +Applications using the library should use jmorecfg, jerror, jpeglib, and +include jconfig.inc. + +CJPEG/DJPEG/JPEGTRAN + +Pascal source code files: + +cderror.pas Additional error and trace message codes for cjpeg/djpeg. + Not used, Those errors have been added to jdeferr. +cjpeg.pas Main program for cjpeg. +djpeg.pas Main program for djpeg. +jpegtran.pas Main program for jpegtran. +cdjpeg.pas Utility routines used by all three programs. +rdcolmap.pas Code to read a colormap file for djpeg's "-map" switch. +rdswitch.pas Code to process some of cjpeg's more complex switches. + Also used by jpegtran. +transupp.pas Support code for jpegtran: lossless image manipulations. + +fcache.pas +rdswitch.pas Code to process some of cjpeg's more complex switches. + Also used by jpegtran. + +Image file writer modules for djpeg: + +wrbmp.pas BMP file output. +wrppm.pas PPM/PGM file output. +wrtarga.pas Targa file output. + +Image file reader modules for cjpeg: + +rdbmp.pas BMP file input. +rdppm.pas PPM/PGM file input. +rdtarga.pas Targa file input. - NOT READY YET + +This program does not depend on the JPEG library + +rdjpgcom.pas Stand-alone rdjpgcom application. + + +Translation +=========== + +TP is unit-centric, exported type definitions and routines are declared +in the "interface" part of the unit, "make" files are not needed. +Macros are not supported, they were either copied as needed or translated +to Pascal routines (procedure). The procedures will be replaced by code in +later releases. +Conditional defines that indicate whether to include various optional +functions are defined in the file JCONFIG.INC. This file is included first +in all source files. + +The base type definitions are in the unit JMORECFG.PAS. The error handling +macros have been converted to procedures in JERROR.PAS. The error codes are +in JDEFERR.PAS. jpegint.h and jpeglib.h were merged into one large unit +JPEGLIB.PAS containing type definitions with global scope. + +The translation of the header file is the most sophisticated work, a good +understanding of the syntax is required. Once the header files are done, +the translation turns into a lot of editing work. Each C source file was +converted to a unit by editing the syntax (separate variable definition +and usage, define labels, group variable definitions, expanding macros, etc). + +The IJG source labels routines GLOBAL, METHODDEF and LOCAL. All globals +routines are in the interface section of the units. The "far" directive is +used for methods (METHODDEF). + +Some C -> Pascal examples. + +* "{" -> "begin" "->" -> "^." " = " -> " := " "<<" -> " shl " + "}" -> "end;" "!=" -> "<>" " == " -> " = " ">>" -> " shr " + "/*" -> "{" routine -> function "0x" -> "$" + "*/" -> "}" (void) procedure "NULL" -> "NIL" + +* structs are records, Unions are variable records, pointers are always far, + the operators && and || (and/or) have not the same priority in both + languages, so parenthesis are important. The Pascal "case" doesn't have the + falltrough option of the C "switch" statement, my work around is to split + one "switch" statement into many case statements. +* The pointer type in C is not readily interchangeable. It is used to address + an array (Pascal pointer to an array) or in pointer arithmetic a pointer to + a single element. I've used the Inc() statement with type casting to + translate pointer arithmetic most of the time. + + C example: + typedef JSAMPLE* JSAMPROW; /* ptr to one image row of pixel samples. */ + + Pascal + type + JSAMPLE_PTR = ^JSAMPLE; { ptr to a single pixel sample. } + jTSample = 0..(MaxInt div SIZEOF(JSAMPLE))-1; + JSAMPLE_ARRAY = Array[jTSample] of JSAMPLE; {far} + JSAMPROW = ^JSAMPLE_ARRAY; { ptr to one image row of pixel samples. } + + The following code + + JSAMPROW buffer0, buffer1; /* ptr to a JSAMPLE buffer. */ + + ... + + buffer1 = buffer0 + i; + + can be translated to + + var + buffer0, buffer1 : JSAMPROW; + + ... + + buffer1 := buffer0; + Inc(JSAMPLE_PTR(buffer1), i); + + or + + buffer1 := JSAMPROW(@ buffer0^[i]); + + Declaring the variables as JSAMPLE_PTR may reduce type casting in some + places. I use help pointers to handle negative array offsets. + +While translating the type of function parameter from C to Pascal, one can +often use "var", "const", or "array of" parameters instead of pointers. + +While translating for(;;)-loops with more than one induction variable to +Pascal "for to/downto do"-loops, the extra induction variables have to be +manually updated at the end of the loop and before "continue"-statements. + + +Legal issues +============ + +Copyright (C) 1996,1998 by Jacques Nomssi Nzali + + This software is provided 'as-is', without any express or implied + warranty. In no event will the author be held liable for any damages + arising from the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software + in a product, an acknowledgment in the product documentation would be + appreciated but is not required. + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + 3. This notice may not be removed or altered from any source distribution. + + +Archive Locations: +================== + +[1] Thomas G. Lane, JPEG FAQ + + in comp.graphics.misc and related newsgroups + +[2] Wallace, Gregory K.: The JPEG Still Picture Compression Standard + + ftp.uu.net, graphics/jpeg/wallace.ps.Z + +[3] The Independent JPEG Group C library for JPEG encoding and decoding, + rev 6b. + + ftp://ftp.uu.net/graphics/jpeg/ + + or SimTel in msdos/graphics/ + +[4] JPEG implementation, written by the PVRG group at Stanford, + ftp havefun.stanford.edu:/pub/jpeg/JPEGv1.2.tar.Z. + +[5] PASJPEG.ZIP at NView ftp site + + ftp://druckfix.physik.tu-chemnitz.de/pub/nv/ + http://www.tu-chemnitz.de/~nomssi/pub/pasjpeg.zip + +[6] The PasJPEG home page with links + + http://www.tu-chemnitz.de/~nomssi/pasjpeg.html _____________________________________________________________________________ \ No newline at end of file diff --git a/Imaging/ZLib/dzlib.pas b/Imaging/ZLib/dzlib.pas index a335628..0986098 100644 --- a/Imaging/ZLib/dzlib.pas +++ b/Imaging/ZLib/dzlib.pas @@ -1,520 +1,525 @@ -{*******************************************************} -{ } -{ Delphi Supplemental Components } -{ ZLIB Data Compression Interface Unit } -{ } -{ Copyright (c) 1997 Borland International } -{ Copyright (c) 1998 Jacques Nomssi Nzali } -{ } -{*******************************************************} - -{ - Modified for - Vampyre Imaging Library - by Marek Mauder - http://imaginglib.sourceforge.net - - You can choose which pascal zlib implementation will be - used. IMPASZLIB and FPCPASZLIB are translations of zlib - to pascal so they don't need any *.obj files. - The others are interfaces to *.obj files (Windows) or - *.so libraries (Linux). - Default implementation is IMPASZLIB because it can be compiled - by all supported compilers and works on all supported platforms. - I usually use implementation with the fastest decompression - when building release Win32 binaries. - FPCPASZLIB is useful for Lazarus applications. FPC's zlib is linked - to exe by default so there is no need to link additional (and almost identical) - IMPASZLIB. - - There is a small speed comparison table of some of the - supported implementations (TGA image 28 311 570 bytes, compression level = 6, - Delphi 9, Win32, Athlon XP 1900). - - ZLib version Decompression Compression Comp. Size - IMPASZLIB | 1.1.2 | 824 ms | 4 280 ms | 18 760 133 B - ZLIBEX | 1.2.2 | 710 ms | 1 590 ms* | 19 056 621 B - DELPHIZLIB | 1.0.4 | 976 ms | 9 190 ms | 18 365 562 B - ZLIBPAS | 1.2.3 | 680 ms | 3 790 ms | 18 365 387 B - * obj files are compiled with compression level hardcoded to 1 (fastest) -} - -unit dzlib; - -{$I ImagingOptions.inc} - -interface - -{ $DEFINE ZLIBEX} -{ $DEFINE DELPHIZLIB} -{ $DEFINE ZLIBPAS} -{$DEFINE IMPASZLIB} -{ $DEFINE FPCPASZLIB} - -{ Automatically use FPC's PasZLib when compiling with Lazarus.} - -{$IFDEF LCL} - {$UNDEF IMPASZLIB} - {$DEFINE FPCPASZLIB} -{$ENDIF} - -uses -{$IF Defined(ZLIBEX)} - { Use ZlibEx unit.} - ZLibEx, -{$ELSEIF Defined(DELPHIZLIB)} - { Use ZLib unit shipped with Delphi.} - ZLib, -{$ELSEIF Defined(ZLIBPAS)} - { Pascal interface to ZLib shipped with ZLib C source.} - zlibpas, -{$ELSEIF Defined(IMPASZLIB)} - { Use paszlib modified by me for Delphi and FPC.} - imzdeflate, imzinflate, impaszlib, -{$ELSEIF Defined(FPCPASZLIB)} - { Use FPC's paszlib.} - zbase, paszlib, -{$IFEND} - SysUtils, Classes; - -{$IF Defined(IMPASZLIB) or Defined(FPCPASZLIB) or Defined(ZLIBPAS)} -type - TZStreamRec = z_stream; -{$IFEND} -{$IFDEF ZLIBEX} -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_RLE = 3; - Z_DEFAULT_STRATEGY = 0; - - Z_BINARY = 0; - Z_ASCII = 1; - Z_UNKNOWN = 2; - - Z_DEFLATED = 8; -{$ENDIF} - -type - { Abstract ancestor class } - TCustomZlibStream = class(TStream) - private - FStrm: TStream; - FStrmPos: Integer; - FOnProgress: TNotifyEvent; - FZRec: TZStreamRec; - FBuffer: array [Word] of Byte; - protected - procedure Progress(Sender: TObject); dynamic; - property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; - constructor Create(Strm: TStream); - end; - -{ TCompressionStream compresses data on the fly as data is written to it, and - stores the compressed data to another stream. - - TCompressionStream is write-only and strictly sequential. Reading from the - stream will raise an exception. Using Seek to move the stream pointer - will raise an exception. - - Output data is cached internally, written to the output stream only when - the internal output buffer is full. All pending output data is flushed - when the stream is destroyed. - - The Position property returns the number of uncompressed bytes of - data that have been written to the stream so far. - - CompressionRate returns the on-the-fly percentage by which the original - data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100 - If raw data size = 100 and compressed data size = 25, the CompressionRate - is 75% - - The OnProgress event is called each time the output buffer is filled and - written to the output stream. This is useful for updating a progress - indicator when you are writing a large chunk of data to the compression - stream in a single call.} - - - TCompressionLevel = (clNone, clFastest, clDefault, clMax); - - TCompressionStream = class(TCustomZlibStream) - private - function GetCompressionRate: Single; - public - constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream); - destructor Destroy; override; - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - property CompressionRate: Single read GetCompressionRate; - property OnProgress; - end; - -{ TDecompressionStream decompresses data on the fly as data is read from it. - - Compressed data comes from a separate source stream. TDecompressionStream - is read-only and unidirectional; you can seek forward in the stream, but not - backwards. The special case of setting the stream position to zero is - allowed. Seeking forward decompresses data until the requested position in - the uncompressed data has been reached. Seeking backwards, seeking relative - to the end of the stream, requesting the size of the stream, and writing to - the stream will raise an exception. - - The Position property returns the number of bytes of uncompressed data that - have been read from the stream so far. - - The OnProgress event is called each time the internal input buffer of - compressed data is exhausted and the next block is read from the input stream. - This is useful for updating a progress indicator when you are reading a - large chunk of data from the decompression stream in a single call.} - - TDecompressionStream = class(TCustomZlibStream) - public - constructor Create(Source: TStream); - destructor Destroy; override; - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - property OnProgress; - end; - - - -{ CompressBuf compresses data, buffer to buffer, in one call. - In: InBuf = ptr to compressed data - InBytes = number of bytes in InBuf - Out: OutBuf = ptr to newly allocated buffer containing decompressed data - OutBytes = number of bytes in OutBuf } -procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; - var OutBuf: Pointer; var OutBytes: Integer; - CompressLevel: Integer = Z_DEFAULT_COMPRESSION); - -{ DecompressBuf decompresses data, buffer to buffer, in one call. - In: InBuf = ptr to compressed data - InBytes = number of bytes in InBuf - OutEstimate = zero, or est. size of the decompressed data - Out: OutBuf = ptr to newly allocated buffer containing decompressed data - OutBytes = number of bytes in OutBuf } -procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; - OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer); - - -type - EZlibError = class(Exception); - ECompressionError = class(EZlibError); - EDecompressionError = class(EZlibError); - -implementation - -const - ZErrorMessages: array[0..9] of PAnsiChar = ( - '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) - ''); - -function zlibAllocMem(AppData: Pointer; Items, Size: Cardinal): Pointer; -begin - GetMem(Result, Items*Size); -end; - -procedure zlibFreeMem(AppData, Block: Pointer); -begin - FreeMem(Block); -end; - -function CCheck(code: Integer): Integer; -begin - Result := code; - if code < 0 then - raise ECompressionError.Create('zlib: ' + ZErrorMessages[2 - code]); -end; - -function DCheck(code: Integer): Integer; -begin - Result := code; - if code < 0 then - raise EDecompressionError.Create('zlib: ' + ZErrorMessages[2 - code]); -end; - -procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; - var OutBuf: Pointer; var OutBytes: Integer; - CompressLevel: Integer); -var - strm: TZStreamRec; - P: Pointer; -begin - FillChar(strm, sizeof(strm), 0); -{$IFNDEF FPCPASZLIB} - strm.zalloc := @zlibAllocMem; - strm.zfree := @zlibFreeMem; -{$ENDIF} - OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255; - GetMem(OutBuf, OutBytes); - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; - CCheck(deflateInit_(strm, CompressLevel, zlib_version, sizeof(strm))); - try - while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do - begin - P := OutBuf; - Inc(OutBytes, 256); - ReallocMem(OutBuf, OutBytes); - strm.next_out := Pointer(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); - strm.avail_out := 256; - end; - finally - CCheck(deflateEnd(strm)); - end; - ReallocMem(OutBuf, strm.total_out); - OutBytes := strm.total_out; - except - zlibFreeMem(nil, OutBuf); - raise - end; -end; - -procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; - OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer); -var - strm: TZStreamRec; - P: Pointer; - BufInc: Integer; -begin - FillChar(strm, sizeof(strm), 0); -{$IFNDEF FPCPASZLIB} - strm.zalloc := @zlibAllocMem; - strm.zfree := @zlibFreeMem; -{$ENDIF} - BufInc := (InBytes + 255) and not 255; - if OutEstimate = 0 then - OutBytes := BufInc - else - OutBytes := OutEstimate; - GetMem(OutBuf, OutBytes); - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; - DCheck(inflateInit_(strm, zlib_version, sizeof(strm))); - try - while DCheck(inflate(strm, Z_NO_FLUSH)) <> Z_STREAM_END do - begin - P := OutBuf; - Inc(OutBytes, BufInc); - ReallocMem(OutBuf, OutBytes); - strm.next_out := Pointer(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); - strm.avail_out := BufInc; - end; - finally - DCheck(inflateEnd(strm)); - end; - ReallocMem(OutBuf, strm.total_out); - OutBytes := strm.total_out; - except - zlibFreeMem(nil, OutBuf); - raise - end; -end; - - -{ TCustomZlibStream } - -constructor TCustomZLibStream.Create(Strm: TStream); -begin - inherited Create; - FStrm := Strm; - FStrmPos := Strm.Position; -{$IFNDEF FPCPASZLIB} - FZRec.zalloc := @zlibAllocMem; - FZRec.zfree := @zlibFreeMem; -{$ENDIF} -end; - -procedure TCustomZLibStream.Progress(Sender: TObject); -begin - if Assigned(FOnProgress) then FOnProgress(Sender); -end; - -{ TCompressionStream } - -constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel; - Dest: TStream); -const - Levels: array [TCompressionLevel] of ShortInt = - (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION); -begin - inherited Create(Dest); - FZRec.next_out := @FBuffer; - FZRec.avail_out := sizeof(FBuffer); - CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec))); -end; - -destructor TCompressionStream.Destroy; -begin - FZRec.next_in := nil; - FZRec.avail_in := 0; - try - if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END) - and (FZRec.avail_out = 0) do - begin - FStrm.WriteBuffer(FBuffer, sizeof(FBuffer)); - FZRec.next_out := @FBuffer; - FZRec.avail_out := sizeof(FBuffer); - end; - if FZRec.avail_out < sizeof(FBuffer) then - FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out); - finally - deflateEnd(FZRec); - end; - inherited Destroy; -end; - -function TCompressionStream.Read(var Buffer; Count: Longint): Longint; -begin - raise ECompressionError.Create('Invalid stream operation'); -end; - -function TCompressionStream.Write(const Buffer; Count: Longint): Longint; -begin - FZRec.next_in := @Buffer; - FZRec.avail_in := Count; - if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - while (FZRec.avail_in > 0) do - begin - CCheck(deflate(FZRec, 0)); - if FZRec.avail_out = 0 then - begin - FStrm.WriteBuffer(FBuffer, sizeof(FBuffer)); - FZRec.next_out := @FBuffer; - FZRec.avail_out := sizeof(FBuffer); - FStrmPos := FStrm.Position; - Progress(Self); - end; - end; - Result := Count; -end; - -function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint; -begin - if (Offset = 0) and (Origin = soFromCurrent) then - Result := FZRec.total_in - else - raise ECompressionError.Create('Invalid stream operation'); -end; - -function TCompressionStream.GetCompressionRate: Single; -begin - if FZRec.total_in = 0 then - Result := 0 - else - Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0; -end; - -{ TDecompressionStream } - -constructor TDecompressionStream.Create(Source: TStream); -begin - inherited Create(Source); - FZRec.next_in := @FBuffer; - FZRec.avail_in := 0; - DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec))); -end; - -destructor TDecompressionStream.Destroy; -begin - inflateEnd(FZRec); - inherited Destroy; -end; - -function TDecompressionStream.Read(var Buffer; Count: Longint): Longint; -begin - FZRec.next_out := @Buffer; - FZRec.avail_out := Count; - if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - while (FZRec.avail_out > 0) do - begin - if FZRec.avail_in = 0 then - begin - FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer)); - if FZRec.avail_in = 0 then - begin - Result := Count - Integer(FZRec.avail_out); - Exit; - end; - FZRec.next_in := @FBuffer; - FStrmPos := FStrm.Position; - Progress(Self); - end; - CCheck(inflate(FZRec, 0)); - end; - Result := Count; -end; - -function TDecompressionStream.Write(const Buffer; Count: Longint): Longint; -begin - raise EDecompressionError.Create('Invalid stream operation'); -end; - -function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint; -var - I: Integer; - Buf: array [0..4095] of Byte; -begin - if (Offset = 0) and (Origin = soFromBeginning) then - begin - DCheck(inflateReset(FZRec)); - FZRec.next_in := @FBuffer; - FZRec.avail_in := 0; - FStrm.Position := 0; - FStrmPos := 0; - end - else if ( (Offset >= 0) and (Origin = soFromCurrent)) or - ( ((Offset - Integer(FZRec.total_out)) > 0) and (Origin = soFromBeginning)) then - begin - if Origin = soFromBeginning then Dec(Offset, FZRec.total_out); - if Offset > 0 then - begin - for I := 1 to Offset div sizeof(Buf) do - ReadBuffer(Buf, sizeof(Buf)); - ReadBuffer(Buf, Offset mod sizeof(Buf)); - end; - end - else - raise EDecompressionError.Create('Invalid stream operation'); - Result := FZRec.total_out; -end; - -end. +{*******************************************************} +{ } +{ Delphi Supplemental Components } +{ ZLIB Data Compression Interface Unit } +{ } +{ Copyright (c) 1997 Borland International } +{ Copyright (c) 1998 Jacques Nomssi Nzali } +{ } +{*******************************************************} + +{ + Modified for + Vampyre Imaging Library + by Marek Mauder + http://imaginglib.sourceforge.net + + You can choose which pascal zlib implementation will be + used. IMPASZLIB and FPCPASZLIB are translations of zlib + to pascal so they don't need any *.obj files. + The others are interfaces to *.obj files (Windows) or + *.so libraries (Linux). + Default implementation is IMPASZLIB because it can be compiled + by all supported compilers and works on all supported platforms. + I usually use implementation with the fastest decompression + when building release Win32 binaries. + FPCPASZLIB is useful for Lazarus applications. FPC's zlib is linked + to exe by default so there is no need to link additional (and almost identical) + IMPASZLIB. + + There is a small speed comparison table of some of the + supported implementations (TGA image 28 311 570 bytes, compression level = 6, + Delphi 9, Win32, Athlon XP 1900). + + ZLib version Decompression Compression Comp. Size + IMPASZLIB | 1.1.2 | 824 ms | 4 280 ms | 18 760 133 B + ZLIBEX | 1.2.2 | 710 ms | 1 590 ms* | 19 056 621 B + DELPHIZLIB | 1.0.4 | 976 ms | 9 190 ms | 18 365 562 B + ZLIBPAS | 1.2.3 | 680 ms | 3 790 ms | 18 365 387 B + * obj files are compiled with compression level hardcoded to 1 (fastest) +} + +unit dzlib; + +{$I ImagingOptions.inc} + +interface + +{$DEFINE IMPASZLIB} +{ $DEFINE ZLIBPAS} +{ $DEFINE FPCPASZLIB} +{ $DEFINE ZLIBEX} +{ $DEFINE DELPHIZLIB} + +{ Automatically use FPC's PasZLib when compiling with FPC.} + +{$IFDEF FPC} + {$UNDEF IMPASZLIB} + {$DEFINE FPCPASZLIB} +{$ENDIF} + +uses +{$IF Defined(IMPASZLIB)} + { Use paszlib modified by me for Delphi and FPC } + imzdeflate, imzinflate, impaszlib, +{$ELSEIF Defined(FPCPASZLIB)} + { Use FPC's paszlib } + zbase, paszlib, +{$ELSEIF Defined(ZLIBPAS)} + { Pascal interface to ZLib shipped with ZLib C source } + zlibpas, +{$ELSEIF Defined(ZLIBEX)} + { Use ZlibEx unit } + ZLibEx, +{$ELSEIF Defined(DELPHIZLIB)} + { Use ZLib unit shipped with Delphi } + ZLib, +{$IFEND} + ImagingTypes, SysUtils, Classes; + +{$IF Defined(IMPASZLIB) or Defined(FPCPASZLIB) or Defined(ZLIBPAS)} +type + TZStreamRec = z_stream; +{$IFEND} + +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_RLE = 3; + Z_DEFAULT_STRATEGY = 0; + + Z_BINARY = 0; + Z_ASCII = 1; + Z_UNKNOWN = 2; + + Z_DEFLATED = 8; + +type + { Abstract ancestor class } + TCustomZlibStream = class(TStream) + private + FStrm: TStream; + FStrmPos: Integer; + FOnProgress: TNotifyEvent; + FZRec: TZStreamRec; + FBuffer: array [Word] of Byte; + protected + procedure Progress(Sender: TObject); dynamic; + property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; + constructor Create(Strm: TStream); + end; + +{ TCompressionStream compresses data on the fly as data is written to it, and + stores the compressed data to another stream. + + TCompressionStream is write-only and strictly sequential. Reading from the + stream will raise an exception. Using Seek to move the stream pointer + will raise an exception. + + Output data is cached internally, written to the output stream only when + the internal output buffer is full. All pending output data is flushed + when the stream is destroyed. + + The Position property returns the number of uncompressed bytes of + data that have been written to the stream so far. + + CompressionRate returns the on-the-fly percentage by which the original + data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100 + If raw data size = 100 and compressed data size = 25, the CompressionRate + is 75% + + The OnProgress event is called each time the output buffer is filled and + written to the output stream. This is useful for updating a progress + indicator when you are writing a large chunk of data to the compression + stream in a single call.} + + + TCompressionLevel = (clNone, clFastest, clDefault, clMax); + + TCompressionStream = class(TCustomZlibStream) + private + function GetCompressionRate: Single; + public + constructor Create(CompressionLevel: TCompressionLevel; Dest: TStream); + destructor Destroy; override; + function Read(var Buffer; Count: Longint): Longint; override; + function Write(const Buffer; Count: Longint): Longint; override; + function Seek(Offset: Longint; Origin: Word): Longint; override; + property CompressionRate: Single read GetCompressionRate; + property OnProgress; + end; + +{ TDecompressionStream decompresses data on the fly as data is read from it. + + Compressed data comes from a separate source stream. TDecompressionStream + is read-only and unidirectional; you can seek forward in the stream, but not + backwards. The special case of setting the stream position to zero is + allowed. Seeking forward decompresses data until the requested position in + the uncompressed data has been reached. Seeking backwards, seeking relative + to the end of the stream, requesting the size of the stream, and writing to + the stream will raise an exception. + + The Position property returns the number of bytes of uncompressed data that + have been read from the stream so far. + + The OnProgress event is called each time the internal input buffer of + compressed data is exhausted and the next block is read from the input stream. + This is useful for updating a progress indicator when you are reading a + large chunk of data from the decompression stream in a single call.} + + TDecompressionStream = class(TCustomZlibStream) + public + constructor Create(Source: TStream); + destructor Destroy; override; + function Read(var Buffer; Count: Longint): Longint; override; + function Write(const Buffer; Count: Longint): Longint; override; + function Seek(Offset: Longint; Origin: Word): Longint; override; + property OnProgress; + end; + + + +{ CompressBuf compresses data, buffer to buffer, in one call. + In: InBuf = ptr to compressed data + InBytes = number of bytes in InBuf + Out: OutBuf = ptr to newly allocated buffer containing decompressed data + OutBytes = number of bytes in OutBuf } +procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; + var OutBuf: Pointer; var OutBytes: Integer; + CompressLevel: Integer = Z_DEFAULT_COMPRESSION; + CompressStrategy: Integer = Z_DEFAULT_STRATEGY); + +{ DecompressBuf decompresses data, buffer to buffer, in one call. + In: InBuf = ptr to compressed data + InBytes = number of bytes in InBuf + OutEstimate = zero, or est. size of the decompressed data + Out: OutBuf = ptr to newly allocated buffer containing decompressed data + OutBytes = number of bytes in OutBuf } +procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; + OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer); + + +type + EZlibError = class(Exception); + ECompressionError = class(EZlibError); + EDecompressionError = class(EZlibError); + +implementation + +const + ZErrorMessages: array[0..9] of PAnsiChar = ( + '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) + ''); + +function zlibAllocMem(AppData: Pointer; Items, Size: Cardinal): Pointer; +begin + GetMem(Result, Items*Size); +end; + +procedure zlibFreeMem(AppData, Block: Pointer); +begin + FreeMem(Block); +end; + +function CCheck(code: Integer): Integer; +begin + Result := code; + if code < 0 then + raise ECompressionError.Create('zlib: ' + ZErrorMessages[2 - code]); +end; + +function DCheck(code: Integer): Integer; +begin + Result := code; + if code < 0 then + raise EDecompressionError.Create('zlib: ' + ZErrorMessages[2 - code]); +end; + +procedure CompressBuf(const InBuf: Pointer; InBytes: Integer; + var OutBuf: Pointer; var OutBytes: Integer; + CompressLevel, CompressStrategy: Integer); +var + strm: TZStreamRec; + P: Pointer; +begin + FillChar(strm, sizeof(strm), 0); +{$IFNDEF FPCPASZLIB} + strm.zalloc := @zlibAllocMem; + strm.zfree := @zlibFreeMem; +{$ENDIF} + OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255; + GetMem(OutBuf, OutBytes); + try + strm.next_in := InBuf; + strm.avail_in := InBytes; + strm.next_out := OutBuf; + strm.avail_out := OutBytes; + + CCheck(deflateInit2(strm, CompressLevel, Z_DEFLATED, MAX_WBITS, + DEF_MEM_LEVEL, CompressStrategy)); + + try + while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do + begin + P := OutBuf; + Inc(OutBytes, 256); + ReallocMem(OutBuf, OutBytes); + strm.next_out := Pointer(PtrUInt(OutBuf) + (PtrUInt(strm.next_out) - PtrUInt(P))); + strm.avail_out := 256; + end; + finally + CCheck(deflateEnd(strm)); + end; + ReallocMem(OutBuf, strm.total_out); + OutBytes := strm.total_out; + except + zlibFreeMem(nil, OutBuf); + raise + end; +end; + +procedure DecompressBuf(const InBuf: Pointer; InBytes: Integer; + OutEstimate: Integer; var OutBuf: Pointer; var OutBytes: Integer); +var + strm: TZStreamRec; + P: Pointer; + BufInc: Integer; +begin + FillChar(strm, sizeof(strm), 0); +{$IFNDEF FPCPASZLIB} + strm.zalloc := @zlibAllocMem; + strm.zfree := @zlibFreeMem; +{$ENDIF} + BufInc := (InBytes + 255) and not 255; + if OutEstimate = 0 then + OutBytes := BufInc + else + OutBytes := OutEstimate; + GetMem(OutBuf, OutBytes); + try + strm.next_in := InBuf; + strm.avail_in := InBytes; + strm.next_out := OutBuf; + strm.avail_out := OutBytes; + DCheck(inflateInit_(strm, zlib_version, sizeof(strm))); + try + while DCheck(inflate(strm, Z_NO_FLUSH)) <> Z_STREAM_END do + begin + P := OutBuf; + Inc(OutBytes, BufInc); + ReallocMem(OutBuf, OutBytes); + strm.next_out := Pointer(PtrUInt(OutBuf) + (PtrUInt(strm.next_out) - PtrUInt(P))); + strm.avail_out := BufInc; + end; + finally + DCheck(inflateEnd(strm)); + end; + ReallocMem(OutBuf, strm.total_out); + OutBytes := strm.total_out; + except + zlibFreeMem(nil, OutBuf); + raise + end; +end; + + +{ TCustomZlibStream } + +constructor TCustomZLibStream.Create(Strm: TStream); +begin + inherited Create; + FStrm := Strm; + FStrmPos := Strm.Position; +{$IFNDEF FPCPASZLIB} + FZRec.zalloc := @zlibAllocMem; + FZRec.zfree := @zlibFreeMem; +{$ENDIF} +end; + +procedure TCustomZLibStream.Progress(Sender: TObject); +begin + if Assigned(FOnProgress) then FOnProgress(Sender); +end; + +{ TCompressionStream } + +constructor TCompressionStream.Create(CompressionLevel: TCompressionLevel; + Dest: TStream); +const + Levels: array [TCompressionLevel] of ShortInt = + (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION); +begin + inherited Create(Dest); + FZRec.next_out := @FBuffer; + FZRec.avail_out := sizeof(FBuffer); + CCheck(deflateInit_(FZRec, Levels[CompressionLevel], zlib_version, sizeof(FZRec))); +end; + +destructor TCompressionStream.Destroy; +begin + FZRec.next_in := nil; + FZRec.avail_in := 0; + try + if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; + while (CCheck(deflate(FZRec, Z_FINISH)) <> Z_STREAM_END) + and (FZRec.avail_out = 0) do + begin + FStrm.WriteBuffer(FBuffer, sizeof(FBuffer)); + FZRec.next_out := @FBuffer; + FZRec.avail_out := sizeof(FBuffer); + end; + if FZRec.avail_out < sizeof(FBuffer) then + FStrm.WriteBuffer(FBuffer, sizeof(FBuffer) - FZRec.avail_out); + finally + deflateEnd(FZRec); + end; + inherited Destroy; +end; + +function TCompressionStream.Read(var Buffer; Count: Longint): Longint; +begin + Result := 0; + raise ECompressionError.Create('Invalid stream operation'); +end; + +function TCompressionStream.Write(const Buffer; Count: Longint): Longint; +begin + FZRec.next_in := @Buffer; + FZRec.avail_in := Count; + if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; + while (FZRec.avail_in > 0) do + begin + CCheck(deflate(FZRec, 0)); + if FZRec.avail_out = 0 then + begin + FStrm.WriteBuffer(FBuffer, sizeof(FBuffer)); + FZRec.next_out := @FBuffer; + FZRec.avail_out := sizeof(FBuffer); + FStrmPos := FStrm.Position; + Progress(Self); + end; + end; + Result := Count; +end; + +function TCompressionStream.Seek(Offset: Longint; Origin: Word): Longint; +begin + if (Offset = 0) and (Origin = soFromCurrent) then + Result := FZRec.total_in + else + raise ECompressionError.Create('Invalid stream operation'); +end; + +function TCompressionStream.GetCompressionRate: Single; +begin + if FZRec.total_in = 0 then + Result := 0 + else + Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0; +end; + +{ TDecompressionStream } + +constructor TDecompressionStream.Create(Source: TStream); +begin + inherited Create(Source); + FZRec.next_in := @FBuffer; + FZRec.avail_in := 0; + DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec))); +end; + +destructor TDecompressionStream.Destroy; +begin + inflateEnd(FZRec); + inherited Destroy; +end; + +function TDecompressionStream.Read(var Buffer; Count: Longint): Longint; +begin + FZRec.next_out := @Buffer; + FZRec.avail_out := Count; + if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; + while (FZRec.avail_out > 0) do + begin + if FZRec.avail_in = 0 then + begin + FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer)); + if FZRec.avail_in = 0 then + begin + Result := Count - Integer(FZRec.avail_out); + Exit; + end; + FZRec.next_in := @FBuffer; + FStrmPos := FStrm.Position; + Progress(Self); + end; + CCheck(inflate(FZRec, 0)); + end; + Result := Count; +end; + +function TDecompressionStream.Write(const Buffer; Count: Longint): Longint; +begin + Result := 0; + raise EDecompressionError.Create('Invalid stream operation'); +end; + +function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint; +var + I: Integer; + Buf: array [0..4095] of Byte; +begin + if (Offset = 0) and (Origin = soFromBeginning) then + begin + DCheck(inflateReset(FZRec)); + FZRec.next_in := @FBuffer; + FZRec.avail_in := 0; + FStrm.Position := 0; + FStrmPos := 0; + end + else if ( (Offset >= 0) and (Origin = soFromCurrent)) or + ( ((Offset - Integer(FZRec.total_out)) > 0) and (Origin = soFromBeginning)) then + begin + if Origin = soFromBeginning then Dec(Offset, FZRec.total_out); + if Offset > 0 then + begin + for I := 1 to Offset div sizeof(Buf) do + ReadBuffer(Buf, sizeof(Buf)); + ReadBuffer(Buf, Offset mod sizeof(Buf)); + end; + end + else + raise EDecompressionError.Create('Invalid stream operation'); + Result := FZRec.total_out; +end; + +end. diff --git a/Imaging/ZLib/imadler.pas b/Imaging/ZLib/imadler.pas index 4438056..73a7768 100644 --- a/Imaging/ZLib/imadler.pas +++ b/Imaging/ZLib/imadler.pas @@ -1,114 +1,114 @@ -Unit imadler; - -{ - adler32.c -- compute the Adler-32 checksum of a data stream - Copyright (C) 1995-1998 Mark Adler - - Pascal tranlastion - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - -interface - -{$I imzconf.inc} - -uses - imzutil; - -function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; - -{ Update a running Adler-32 checksum with the bytes buf[0..len-1] and - return the updated checksum. If buf is NIL, this function returns - the required initial value for the checksum. - An Adler-32 checksum is almost as reliable as a CRC32 but can be computed - much faster. Usage example: - - var - adler : uLong; - begin - adler := adler32(0, Z_NULL, 0); - - while (read_buffer(buffer, length) <> EOF) do - adler := adler32(adler, buffer, length); - - if (adler <> original_adler) then - error(); - end; -} - -implementation - -const - BASE = uLong(65521); { largest prime smaller than 65536 } - {NMAX = 5552; original code with unsigned 32 bit integer } - { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 } - NMAX = 3854; { code with signed 32 bit integer } - { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 } - { The penalty is the time loss in the extra MOD-calls. } - - -{ ========================================================================= } - -function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; -var - s1, s2 : uLong; - k : int; -begin - s1 := adler and $ffff; - s2 := (adler shr 16) and $ffff; - - if not Assigned(buf) then - begin - adler32 := uLong(1); - exit; - end; - - while (len > 0) do - begin - if len < NMAX then - k := len - else - k := NMAX; - Dec(len, k); - { - while (k >= 16) do - begin - DO16(buf); - Inc(buf, 16); - Dec(k, 16); - end; - if (k <> 0) then - repeat - Inc(s1, buf^); - Inc(puf); - Inc(s2, s1); - Dec(k); - until (k = 0); - } - while (k > 0) do - begin - Inc(s1, buf^); - Inc(s2, s1); - Inc(buf); - Dec(k); - end; - s1 := s1 mod BASE; - s2 := s2 mod BASE; - end; - adler32 := (s2 shl 16) or s1; -end; - -{ -#define DO1(buf,i) - begin - Inc(s1, buf[i]); - Inc(s2, s1); - end; -#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1); -#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2); -#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4); -#define DO16(buf) DO8(buf,0); DO8(buf,8); -} -end. - +Unit imadler; + +{ + adler32.c -- compute the Adler-32 checksum of a data stream + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I imzconf.inc} + +uses + imzutil; + +function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; + +{ Update a running Adler-32 checksum with the bytes buf[0..len-1] and + return the updated checksum. If buf is NIL, this function returns + the required initial value for the checksum. + An Adler-32 checksum is almost as reliable as a CRC32 but can be computed + much faster. Usage example: + + var + adler : uLong; + begin + adler := adler32(0, Z_NULL, 0); + + while (read_buffer(buffer, length) <> EOF) do + adler := adler32(adler, buffer, length); + + if (adler <> original_adler) then + error(); + end; +} + +implementation + +const + BASE = uLong(65521); { largest prime smaller than 65536 } + {NMAX = 5552; original code with unsigned 32 bit integer } + { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 } + NMAX = 3854; { code with signed 32 bit integer } + { NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^31-1 } + { The penalty is the time loss in the extra MOD-calls. } + + +{ ========================================================================= } + +function adler32(adler : uLong; buf : pBytef; len : uInt) : uLong; +var + s1, s2 : uLong; + k : int; +begin + s1 := adler and $ffff; + s2 := (adler shr 16) and $ffff; + + if not Assigned(buf) then + begin + adler32 := uLong(1); + exit; + end; + + while (len > 0) do + begin + if len < NMAX then + k := len + else + k := NMAX; + Dec(len, k); + { + while (k >= 16) do + begin + DO16(buf); + Inc(buf, 16); + Dec(k, 16); + end; + if (k <> 0) then + repeat + Inc(s1, buf^); + Inc(puf); + Inc(s2, s1); + Dec(k); + until (k = 0); + } + while (k > 0) do + begin + Inc(s1, buf^); + Inc(s2, s1); + Inc(buf); + Dec(k); + end; + s1 := s1 mod BASE; + s2 := s2 mod BASE; + end; + adler32 := (s2 shl 16) or s1; +end; + +{ +#define DO1(buf,i) + begin + Inc(s1, buf[i]); + Inc(s2, s1); + end; +#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1); +#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2); +#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4); +#define DO16(buf) DO8(buf,0); DO8(buf,8); +} +end. + diff --git a/Imaging/ZLib/iminfblock.pas b/Imaging/ZLib/iminfblock.pas index 7ab003f..556df99 100644 --- a/Imaging/ZLib/iminfblock.pas +++ b/Imaging/ZLib/iminfblock.pas @@ -1,951 +1,951 @@ -Unit iminfblock; - -{ infblock.h and - infblock.c -- interpret and process block types to last block - Copyright (C) 1995-1998 Mark Adler - - Pascal tranlastion - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - -interface - -{$I imzconf.inc} - -uses - {$IFDEF DEBUG} - SysUtils, strutils, - {$ENDIF} - imzutil, impaszlib; - -function inflate_blocks_new(var z : z_stream; - c : check_func; { check function } - w : uInt { window size } - ) : pInflate_blocks_state; - -function inflate_blocks (var s : inflate_blocks_state; - var z : z_stream; - r : int { initial return code } - ) : int; - -procedure inflate_blocks_reset (var s : inflate_blocks_state; - var z : z_stream; - c : puLong); { check value on output } - - -function inflate_blocks_free(s : pInflate_blocks_state; - var z : z_stream) : int; - -procedure inflate_set_dictionary(var s : inflate_blocks_state; - const d : array of byte; { dictionary } - n : uInt); { dictionary length } - -function inflate_blocks_sync_point(var s : inflate_blocks_state) : int; - -implementation - -uses - iminfcodes, iminftrees, iminfutil; - -{ Tables for deflate from PKZIP's appnote.txt. } -Const - border : Array [0..18] Of Word { Order of the bit length code lengths } - = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15); - -{ Notes beyond the 1.93a appnote.txt: - - 1. Distance pointers never point before the beginning of the output - stream. - 2. Distance pointers can point back across blocks, up to 32k away. - 3. There is an implied maximum of 7 bits for the bit length table and - 15 bits for the actual data. - 4. If only one code exists, then it is encoded using one bit. (Zero - would be more efficient, but perhaps a little confusing.) If two - codes exist, they are coded using one bit each (0 and 1). - 5. There is no way of sending zero distance codes--a dummy must be - sent if there are none. (History: a pre 2.0 version of PKZIP would - store blocks with no distance codes, but this was discovered to be - too harsh a criterion.) Valid only for 1.93a. 2.04c does allow - zero distance codes, which is sent as one code of zero bits in - length. - 6. There are up to 286 literal/length codes. Code 256 represents the - end-of-block. Note however that the static length tree defines - 288 codes just to fill out the Huffman codes. Codes 286 and 287 - cannot be used though, since there is no length base or extra bits - defined for them. Similarily, there are up to 30 distance codes. - However, static trees define 32 codes (all 5 bits) to fill out the - Huffman codes, but the last two had better not show up in the data. - 7. Unzip can check dynamic Huffman blocks for complete code sets. - The exception is that a single code would not be complete (see #4). - 8. The five bits following the block type is really the number of - literal codes sent minus 257. - 9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits - (1+6+6). Therefore, to output three times the length, you output - three codes (1+1+1), whereas to output four times the same length, - you only need two codes (1+3). Hmm. - 10. In the tree reconstruction algorithm, Code = Code + Increment - only if BitLength(i) is not zero. (Pretty obvious.) - 11. Correction: 4 Bits: # of Bit Length codes - 4 (4 - 19) - 12. Note: length code 284 can represent 227-258, but length code 285 - really is 258. The last length deserves its own, short code - since it gets used a lot in very redundant files. The length - 258 is special since 258 - 3 (the min match length) is 255. - 13. The literal/length and distance code bit lengths are read as a - single stream of lengths. It is possible (and advantageous) for - a repeat code (16, 17, or 18) to go across the boundary between - the two sets of lengths. } - - -procedure inflate_blocks_reset (var s : inflate_blocks_state; - var z : z_stream; - c : puLong); { check value on output } -begin - if (c <> Z_NULL) then - c^ := s.check; - if (s.mode = BTREE) or (s.mode = DTREE) then - ZFREE(z, s.sub.trees.blens); - if (s.mode = CODES) then - inflate_codes_free(s.sub.decode.codes, z); - - s.mode := ZTYPE; - s.bitk := 0; - s.bitb := 0; - - s.write := s.window; - s.read := s.window; - if Assigned(s.checkfn) then - begin - s.check := s.checkfn(uLong(0), pBytef(NIL), 0); - z.adler := s.check; - end; - {$IFDEF DEBUG} - Tracev('inflate: blocks reset'); - {$ENDIF} -end; - - -function inflate_blocks_new(var z : z_stream; - c : check_func; { check function } - w : uInt { window size } - ) : pInflate_blocks_state; -var - s : pInflate_blocks_state; -begin - s := pInflate_blocks_state( ZALLOC(z,1, sizeof(inflate_blocks_state)) ); - if (s = Z_NULL) then - begin - inflate_blocks_new := s; - exit; - end; - s^.hufts := huft_ptr( ZALLOC(z, sizeof(inflate_huft), MANY) ); - - if (s^.hufts = Z_NULL) then - begin - ZFREE(z, s); - inflate_blocks_new := Z_NULL; - exit; - end; - - s^.window := pBytef( ZALLOC(z, 1, w) ); - if (s^.window = Z_NULL) then - begin - ZFREE(z, s^.hufts); - ZFREE(z, s); - inflate_blocks_new := Z_NULL; - exit; - end; - s^.zend := s^.window; - Inc(s^.zend, w); - s^.checkfn := c; - s^.mode := ZTYPE; - {$IFDEF DEBUG} - Tracev('inflate: blocks allocated'); - {$ENDIF} - inflate_blocks_reset(s^, z, Z_NULL); - inflate_blocks_new := s; -end; - - -function inflate_blocks (var s : inflate_blocks_state; - var z : z_stream; - r : int) : int; { initial return code } -label - start_btree, start_dtree, - start_blkdone, start_dry, - start_codes; - -var - t : uInt; { temporary storage } - b : uLong; { bit buffer } - k : uInt; { bits in bit buffer } - p : pBytef; { input data pointer } - n : uInt; { bytes available there } - q : pBytef; { output window write pointer } - m : uInt; { bytes to end of window or read pointer } -{ fixed code blocks } -var - bl, bd : uInt; - tl, td : pInflate_huft; -var - h : pInflate_huft; - i, j, c : uInt; -var - cs : pInflate_codes_state; -begin - { copy input/output information to locals } - p := z.next_in; - n := z.avail_in; - b := s.bitb; - k := s.bitk; - q := s.write; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - -{ decompress an inflated block } - - - { process input based on current state } - while True do - Case s.mode of - ZTYPE: - begin - {NEEDBITS(3);} - while (k < 3) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - - t := uInt(b) and 7; - s.last := boolean(t and 1); - case (t shr 1) of - 0: { stored } - begin - {$IFDEF DEBUG} - if s.last then - Tracev('inflate: stored block (last)') - else - Tracev('inflate: stored block'); - {$ENDIF} - {DUMPBITS(3);} - b := b shr 3; - Dec(k, 3); - - t := k and 7; { go to byte boundary } - {DUMPBITS(t);} - b := b shr t; - Dec(k, t); - - s.mode := LENS; { get length of stored block } - end; - 1: { fixed } - begin - begin - {$IFDEF DEBUG} - if s.last then - Tracev('inflate: fixed codes blocks (last)') - else - Tracev('inflate: fixed codes blocks'); - {$ENDIF} - inflate_trees_fixed(bl, bd, tl, td, z); - s.sub.decode.codes := inflate_codes_new(bl, bd, tl, td, z); - if (s.sub.decode.codes = Z_NULL) then - begin - r := Z_MEM_ERROR; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - end; - {DUMPBITS(3);} - b := b shr 3; - Dec(k, 3); - - s.mode := CODES; - end; - 2: { dynamic } - begin - {$IFDEF DEBUG} - if s.last then - Tracev('inflate: dynamic codes block (last)') - else - Tracev('inflate: dynamic codes block'); - {$ENDIF} - {DUMPBITS(3);} - b := b shr 3; - Dec(k, 3); - - s.mode := TABLE; - end; - 3: - begin { illegal } - {DUMPBITS(3);} - b := b shr 3; - Dec(k, 3); - - s.mode := BLKBAD; - z.msg := 'invalid block type'; - r := Z_DATA_ERROR; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - end; - end; - LENS: - begin - {NEEDBITS(32);} - while (k < 32) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - - if (((not b) shr 16) and $ffff) <> (b and $ffff) then - begin - s.mode := BLKBAD; - z.msg := 'invalid stored block lengths'; - r := Z_DATA_ERROR; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - s.sub.left := uInt(b) and $ffff; - k := 0; - b := 0; { dump bits } - {$IFDEF DEBUG} - Tracev('inflate: stored length '+IntToStr(s.sub.left)); - {$ENDIF} - if s.sub.left <> 0 then - s.mode := STORED - else - if s.last then - s.mode := DRY - else - s.mode := ZTYPE; - end; - STORED: - begin - if (n = 0) then - begin - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - {NEEDOUT} - if (m = 0) then - begin - {WRAP} - if (q = s.zend) and (s.read <> s.window) then - begin - q := s.window; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - end; - - if (m = 0) then - begin - {FLUSH} - s.write := q; - r := inflate_flush(s,z,r); - q := s.write; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - - {WRAP} - if (q = s.zend) and (s.read <> s.window) then - begin - q := s.window; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - end; - - if (m = 0) then - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - end; - end; - r := Z_OK; - - t := s.sub.left; - if (t > n) then - t := n; - if (t > m) then - t := m; - zmemcpy(q, p, t); - Inc(p, t); Dec(n, t); - Inc(q, t); Dec(m, t); - Dec(s.sub.left, t); - if (s.sub.left = 0) then - begin - {$IFDEF DEBUG} - if (ptr2int(q) >= ptr2int(s.read)) then - Tracev('inflate: stored end '+ - IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out') - else - Tracev('inflate: stored end '+ - IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) + - ptr2int(q) - ptr2int(s.window)) + ' total out'); - {$ENDIF} - if s.last then - s.mode := DRY - else - s.mode := ZTYPE; - end; - end; - TABLE: - begin - {NEEDBITS(14);} - while (k < 14) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - - t := uInt(b) and $3fff; - s.sub.trees.table := t; - {$ifndef PKZIP_BUG_WORKAROUND} - if ((t and $1f) > 29) or (((t shr 5) and $1f) > 29) then - begin - s.mode := BLKBAD; - z.msg := 'too many length or distance symbols'; - r := Z_DATA_ERROR; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - {$endif} - t := 258 + (t and $1f) + ((t shr 5) and $1f); - s.sub.trees.blens := puIntArray( ZALLOC(z, t, sizeof(uInt)) ); - if (s.sub.trees.blens = Z_NULL) then - begin - r := Z_MEM_ERROR; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - {DUMPBITS(14);} - b := b shr 14; - Dec(k, 14); - - s.sub.trees.index := 0; - {$IFDEF DEBUG} - Tracev('inflate: table sizes ok'); - {$ENDIF} - s.mode := BTREE; - { fall trough case is handled by the while } - { try GOTO for speed - Nomssi } - goto start_btree; - end; - BTREE: - begin - start_btree: - while (s.sub.trees.index < 4 + (s.sub.trees.table shr 10)) do - begin - {NEEDBITS(3);} - while (k < 3) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - - s.sub.trees.blens^[border[s.sub.trees.index]] := uInt(b) and 7; - Inc(s.sub.trees.index); - {DUMPBITS(3);} - b := b shr 3; - Dec(k, 3); - end; - while (s.sub.trees.index < 19) do - begin - s.sub.trees.blens^[border[s.sub.trees.index]] := 0; - Inc(s.sub.trees.index); - end; - s.sub.trees.bb := 7; - t := inflate_trees_bits(s.sub.trees.blens^, s.sub.trees.bb, - s.sub.trees.tb, s.hufts^, z); - if (t <> Z_OK) then - begin - ZFREE(z, s.sub.trees.blens); - r := t; - if (r = Z_DATA_ERROR) then - s.mode := BLKBAD; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - s.sub.trees.index := 0; - {$IFDEF DEBUG} - Tracev('inflate: bits tree ok'); - {$ENDIF} - s.mode := DTREE; - { fall through again } - goto start_dtree; - end; - DTREE: - begin - start_dtree: - while TRUE do - begin - t := s.sub.trees.table; - if not (s.sub.trees.index < 258 + - (t and $1f) + ((t shr 5) and $1f)) then - break; - t := s.sub.trees.bb; - {NEEDBITS(t);} - while (k < t) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - - h := s.sub.trees.tb; - Inc(h, uInt(b) and inflate_mask[t]); - t := h^.Bits; - c := h^.Base; - - if (c < 16) then - begin - {DUMPBITS(t);} - b := b shr t; - Dec(k, t); - - s.sub.trees.blens^[s.sub.trees.index] := c; - Inc(s.sub.trees.index); - end - else { c = 16..18 } - begin - if c = 18 then - begin - i := 7; - j := 11; - end - else - begin - i := c - 14; - j := 3; - end; - {NEEDBITS(t + i);} - while (k < t + i) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - - {DUMPBITS(t);} - b := b shr t; - Dec(k, t); - - Inc(j, uInt(b) and inflate_mask[i]); - {DUMPBITS(i);} - b := b shr i; - Dec(k, i); - - i := s.sub.trees.index; - t := s.sub.trees.table; - if (i + j > 258 + (t and $1f) + ((t shr 5) and $1f)) or - ((c = 16) and (i < 1)) then - begin - ZFREE(z, s.sub.trees.blens); - s.mode := BLKBAD; - z.msg := 'invalid bit length repeat'; - r := Z_DATA_ERROR; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - if c = 16 then - c := s.sub.trees.blens^[i - 1] - else - c := 0; - repeat - s.sub.trees.blens^[i] := c; - Inc(i); - Dec(j); - until (j=0); - s.sub.trees.index := i; - end; - end; { while } - s.sub.trees.tb := Z_NULL; - begin - bl := 9; { must be <= 9 for lookahead assumptions } - bd := 6; { must be <= 9 for lookahead assumptions } - t := s.sub.trees.table; - t := inflate_trees_dynamic(257 + (t and $1f), - 1 + ((t shr 5) and $1f), - s.sub.trees.blens^, bl, bd, tl, td, s.hufts^, z); - ZFREE(z, s.sub.trees.blens); - if (t <> Z_OK) then - begin - if (t = uInt(Z_DATA_ERROR)) then - s.mode := BLKBAD; - r := t; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - {$IFDEF DEBUG} - Tracev('inflate: trees ok'); - {$ENDIF} - { c renamed to cs } - cs := inflate_codes_new(bl, bd, tl, td, z); - if (cs = Z_NULL) then - begin - r := Z_MEM_ERROR; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - s.sub.decode.codes := cs; - end; - s.mode := CODES; - { yet another falltrough } - goto start_codes; - end; - CODES: - begin - start_codes: - { update pointers } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - - r := inflate_codes(s, z, r); - if (r <> Z_STREAM_END) then - begin - inflate_blocks := inflate_flush(s, z, r); - exit; - end; - r := Z_OK; - inflate_codes_free(s.sub.decode.codes, z); - { load local pointers } - p := z.next_in; - n := z.avail_in; - b := s.bitb; - k := s.bitk; - q := s.write; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - {$IFDEF DEBUG} - if (ptr2int(q) >= ptr2int(s.read)) then - Tracev('inflate: codes end '+ - IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out') - else - Tracev('inflate: codes end '+ - IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) + - ptr2int(q) - ptr2int(s.window)) + ' total out'); - {$ENDIF} - if (not s.last) then - begin - s.mode := ZTYPE; - continue; { break for switch statement in C-code } - end; - {$ifndef patch112} - if (k > 7) then { return unused byte, if any } - begin - {$IFDEF DEBUG} - Assert(k < 16, 'inflate_codes grabbed too many bytes'); - {$ENDIF} - Dec(k, 8); - Inc(n); - Dec(p); { can always return one } - end; - {$endif} - s.mode := DRY; - { another falltrough } - goto start_dry; - end; - DRY: - begin - start_dry: - {FLUSH} - s.write := q; - r := inflate_flush(s,z,r); - q := s.write; - - { not needed anymore, we are done: - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - } - - if (s.read <> s.write) then - begin - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - s.mode := BLKDONE; - goto start_blkdone; - end; - BLKDONE: - begin - start_blkdone: - r := Z_STREAM_END; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - BLKBAD: - begin - r := Z_DATA_ERROR; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - else - begin - r := Z_STREAM_ERROR; - { update pointers and return } - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_blocks := inflate_flush(s,z,r); - exit; - end; - end; { Case s.mode of } - -end; - - -function inflate_blocks_free(s : pInflate_blocks_state; - var z : z_stream) : int; -begin - inflate_blocks_reset(s^, z, Z_NULL); - ZFREE(z, s^.window); - ZFREE(z, s^.hufts); - ZFREE(z, s); - {$IFDEF DEBUG} - Trace('inflate: blocks freed'); - {$ENDIF} - inflate_blocks_free := Z_OK; -end; - - -procedure inflate_set_dictionary(var s : inflate_blocks_state; - const d : array of byte; { dictionary } - n : uInt); { dictionary length } -begin - zmemcpy(s.window, pBytef(@d), n); - s.write := s.window; - Inc(s.write, n); - s.read := s.write; -end; - - -{ Returns true if inflate is currently at the end of a block generated - by Z_SYNC_FLUSH or Z_FULL_FLUSH. - IN assertion: s <> Z_NULL } - -function inflate_blocks_sync_point(var s : inflate_blocks_state) : int; -begin - inflate_blocks_sync_point := int(s.mode = LENS); -end; - -end. +Unit iminfblock; + +{ infblock.h and + infblock.c -- interpret and process block types to last block + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I imzconf.inc} + +uses + {$IFDEF DEBUG} + SysUtils, strutils, + {$ENDIF} + imzutil, impaszlib; + +function inflate_blocks_new(var z : z_stream; + c : check_func; { check function } + w : uInt { window size } + ) : pInflate_blocks_state; + +function inflate_blocks (var s : inflate_blocks_state; + var z : z_stream; + r : int { initial return code } + ) : int; + +procedure inflate_blocks_reset (var s : inflate_blocks_state; + var z : z_stream; + c : puLong); { check value on output } + + +function inflate_blocks_free(s : pInflate_blocks_state; + var z : z_stream) : int; + +procedure inflate_set_dictionary(var s : inflate_blocks_state; + const d : array of byte; { dictionary } + n : uInt); { dictionary length } + +function inflate_blocks_sync_point(var s : inflate_blocks_state) : int; + +implementation + +uses + iminfcodes, iminftrees, iminfutil; + +{ Tables for deflate from PKZIP's appnote.txt. } +Const + border : Array [0..18] Of Word { Order of the bit length code lengths } + = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15); + +{ Notes beyond the 1.93a appnote.txt: + + 1. Distance pointers never point before the beginning of the output + stream. + 2. Distance pointers can point back across blocks, up to 32k away. + 3. There is an implied maximum of 7 bits for the bit length table and + 15 bits for the actual data. + 4. If only one code exists, then it is encoded using one bit. (Zero + would be more efficient, but perhaps a little confusing.) If two + codes exist, they are coded using one bit each (0 and 1). + 5. There is no way of sending zero distance codes--a dummy must be + sent if there are none. (History: a pre 2.0 version of PKZIP would + store blocks with no distance codes, but this was discovered to be + too harsh a criterion.) Valid only for 1.93a. 2.04c does allow + zero distance codes, which is sent as one code of zero bits in + length. + 6. There are up to 286 literal/length codes. Code 256 represents the + end-of-block. Note however that the static length tree defines + 288 codes just to fill out the Huffman codes. Codes 286 and 287 + cannot be used though, since there is no length base or extra bits + defined for them. Similarily, there are up to 30 distance codes. + However, static trees define 32 codes (all 5 bits) to fill out the + Huffman codes, but the last two had better not show up in the data. + 7. Unzip can check dynamic Huffman blocks for complete code sets. + The exception is that a single code would not be complete (see #4). + 8. The five bits following the block type is really the number of + literal codes sent minus 257. + 9. Length codes 8,16,16 are interpreted as 13 length codes of 8 bits + (1+6+6). Therefore, to output three times the length, you output + three codes (1+1+1), whereas to output four times the same length, + you only need two codes (1+3). Hmm. + 10. In the tree reconstruction algorithm, Code = Code + Increment + only if BitLength(i) is not zero. (Pretty obvious.) + 11. Correction: 4 Bits: # of Bit Length codes - 4 (4 - 19) + 12. Note: length code 284 can represent 227-258, but length code 285 + really is 258. The last length deserves its own, short code + since it gets used a lot in very redundant files. The length + 258 is special since 258 - 3 (the min match length) is 255. + 13. The literal/length and distance code bit lengths are read as a + single stream of lengths. It is possible (and advantageous) for + a repeat code (16, 17, or 18) to go across the boundary between + the two sets of lengths. } + + +procedure inflate_blocks_reset (var s : inflate_blocks_state; + var z : z_stream; + c : puLong); { check value on output } +begin + if (c <> Z_NULL) then + c^ := s.check; + if (s.mode = BTREE) or (s.mode = DTREE) then + ZFREE(z, s.sub.trees.blens); + if (s.mode = CODES) then + inflate_codes_free(s.sub.decode.codes, z); + + s.mode := ZTYPE; + s.bitk := 0; + s.bitb := 0; + + s.write := s.window; + s.read := s.window; + if Assigned(s.checkfn) then + begin + s.check := s.checkfn(uLong(0), pBytef(NIL), 0); + z.adler := s.check; + end; + {$IFDEF DEBUG} + Tracev('inflate: blocks reset'); + {$ENDIF} +end; + + +function inflate_blocks_new(var z : z_stream; + c : check_func; { check function } + w : uInt { window size } + ) : pInflate_blocks_state; +var + s : pInflate_blocks_state; +begin + s := pInflate_blocks_state( ZALLOC(z,1, sizeof(inflate_blocks_state)) ); + if (s = Z_NULL) then + begin + inflate_blocks_new := s; + exit; + end; + s^.hufts := huft_ptr( ZALLOC(z, sizeof(inflate_huft), MANY) ); + + if (s^.hufts = Z_NULL) then + begin + ZFREE(z, s); + inflate_blocks_new := Z_NULL; + exit; + end; + + s^.window := pBytef( ZALLOC(z, 1, w) ); + if (s^.window = Z_NULL) then + begin + ZFREE(z, s^.hufts); + ZFREE(z, s); + inflate_blocks_new := Z_NULL; + exit; + end; + s^.zend := s^.window; + Inc(s^.zend, w); + s^.checkfn := c; + s^.mode := ZTYPE; + {$IFDEF DEBUG} + Tracev('inflate: blocks allocated'); + {$ENDIF} + inflate_blocks_reset(s^, z, Z_NULL); + inflate_blocks_new := s; +end; + + +function inflate_blocks (var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; { initial return code } +label + start_btree, start_dtree, + start_blkdone, start_dry, + start_codes; + +var + t : uInt; { temporary storage } + b : uLong; { bit buffer } + k : uInt; { bits in bit buffer } + p : pBytef; { input data pointer } + n : uInt; { bytes available there } + q : pBytef; { output window write pointer } + m : uInt; { bytes to end of window or read pointer } +{ fixed code blocks } +var + bl, bd : uInt; + tl, td : pInflate_huft; +var + h : pInflate_huft; + i, j, c : uInt; +var + cs : pInflate_codes_state; +begin + { copy input/output information to locals } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + +{ decompress an inflated block } + + + { process input based on current state } + while True do + Case s.mode of + ZTYPE: + begin + {NEEDBITS(3);} + while (k < 3) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := uInt(b) and 7; + s.last := boolean(t and 1); + case (t shr 1) of + 0: { stored } + begin + {$IFDEF DEBUG} + if s.last then + Tracev('inflate: stored block (last)') + else + Tracev('inflate: stored block'); + {$ENDIF} + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + t := k and 7; { go to byte boundary } + {DUMPBITS(t);} + b := b shr t; + Dec(k, t); + + s.mode := LENS; { get length of stored block } + end; + 1: { fixed } + begin + begin + {$IFDEF DEBUG} + if s.last then + Tracev('inflate: fixed codes blocks (last)') + else + Tracev('inflate: fixed codes blocks'); + {$ENDIF} + inflate_trees_fixed(bl, bd, tl, td, z); + s.sub.decode.codes := inflate_codes_new(bl, bd, tl, td, z); + if (s.sub.decode.codes = Z_NULL) then + begin + r := Z_MEM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + s.mode := CODES; + end; + 2: { dynamic } + begin + {$IFDEF DEBUG} + if s.last then + Tracev('inflate: dynamic codes block (last)') + else + Tracev('inflate: dynamic codes block'); + {$ENDIF} + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + s.mode := TABLE; + end; + 3: + begin { illegal } + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + + s.mode := BLKBAD; + z.msg := 'invalid block type'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; + end; + LENS: + begin + {NEEDBITS(32);} + while (k < 32) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + if (((not b) shr 16) and $ffff) <> (b and $ffff) then + begin + s.mode := BLKBAD; + z.msg := 'invalid stored block lengths'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.sub.left := uInt(b) and $ffff; + k := 0; + b := 0; { dump bits } + {$IFDEF DEBUG} + Tracev('inflate: stored length '+IntToStr(s.sub.left)); + {$ENDIF} + if s.sub.left <> 0 then + s.mode := STORED + else + if s.last then + s.mode := DRY + else + s.mode := ZTYPE; + end; + STORED: + begin + if (n = 0) then + begin + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {NEEDOUT} + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + + t := s.sub.left; + if (t > n) then + t := n; + if (t > m) then + t := m; + zmemcpy(q, p, t); + Inc(p, t); Dec(n, t); + Inc(q, t); Dec(m, t); + Dec(s.sub.left, t); + if (s.sub.left = 0) then + begin + {$IFDEF DEBUG} + if (ptr2int(q) >= ptr2int(s.read)) then + Tracev('inflate: stored end '+ + IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out') + else + Tracev('inflate: stored end '+ + IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) + + ptr2int(q) - ptr2int(s.window)) + ' total out'); + {$ENDIF} + if s.last then + s.mode := DRY + else + s.mode := ZTYPE; + end; + end; + TABLE: + begin + {NEEDBITS(14);} + while (k < 14) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := uInt(b) and $3fff; + s.sub.trees.table := t; + {$ifndef PKZIP_BUG_WORKAROUND} + if ((t and $1f) > 29) or (((t shr 5) and $1f) > 29) then + begin + s.mode := BLKBAD; + z.msg := 'too many length or distance symbols'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {$endif} + t := 258 + (t and $1f) + ((t shr 5) and $1f); + s.sub.trees.blens := puIntArray( ZALLOC(z, t, sizeof(uInt)) ); + if (s.sub.trees.blens = Z_NULL) then + begin + r := Z_MEM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {DUMPBITS(14);} + b := b shr 14; + Dec(k, 14); + + s.sub.trees.index := 0; + {$IFDEF DEBUG} + Tracev('inflate: table sizes ok'); + {$ENDIF} + s.mode := BTREE; + { fall trough case is handled by the while } + { try GOTO for speed - Nomssi } + goto start_btree; + end; + BTREE: + begin + start_btree: + while (s.sub.trees.index < 4 + (s.sub.trees.table shr 10)) do + begin + {NEEDBITS(3);} + while (k < 3) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + s.sub.trees.blens^[border[s.sub.trees.index]] := uInt(b) and 7; + Inc(s.sub.trees.index); + {DUMPBITS(3);} + b := b shr 3; + Dec(k, 3); + end; + while (s.sub.trees.index < 19) do + begin + s.sub.trees.blens^[border[s.sub.trees.index]] := 0; + Inc(s.sub.trees.index); + end; + s.sub.trees.bb := 7; + t := inflate_trees_bits(s.sub.trees.blens^, s.sub.trees.bb, + s.sub.trees.tb, s.hufts^, z); + if (t <> Z_OK) then + begin + ZFREE(z, s.sub.trees.blens); + r := t; + if (r = Z_DATA_ERROR) then + s.mode := BLKBAD; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.sub.trees.index := 0; + {$IFDEF DEBUG} + Tracev('inflate: bits tree ok'); + {$ENDIF} + s.mode := DTREE; + { fall through again } + goto start_dtree; + end; + DTREE: + begin + start_dtree: + while TRUE do + begin + t := s.sub.trees.table; + if not (s.sub.trees.index < 258 + + (t and $1f) + ((t shr 5) and $1f)) then + break; + t := s.sub.trees.bb; + {NEEDBITS(t);} + while (k < t) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + h := s.sub.trees.tb; + Inc(h, uInt(b) and inflate_mask[t]); + t := h^.Bits; + c := h^.Base; + + if (c < 16) then + begin + {DUMPBITS(t);} + b := b shr t; + Dec(k, t); + + s.sub.trees.blens^[s.sub.trees.index] := c; + Inc(s.sub.trees.index); + end + else { c = 16..18 } + begin + if c = 18 then + begin + i := 7; + j := 11; + end + else + begin + i := c - 14; + j := 3; + end; + {NEEDBITS(t + i);} + while (k < t + i) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + {DUMPBITS(t);} + b := b shr t; + Dec(k, t); + + Inc(j, uInt(b) and inflate_mask[i]); + {DUMPBITS(i);} + b := b shr i; + Dec(k, i); + + i := s.sub.trees.index; + t := s.sub.trees.table; + if (i + j > 258 + (t and $1f) + ((t shr 5) and $1f)) or + ((c = 16) and (i < 1)) then + begin + ZFREE(z, s.sub.trees.blens); + s.mode := BLKBAD; + z.msg := 'invalid bit length repeat'; + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + if c = 16 then + c := s.sub.trees.blens^[i - 1] + else + c := 0; + repeat + s.sub.trees.blens^[i] := c; + Inc(i); + Dec(j); + until (j=0); + s.sub.trees.index := i; + end; + end; { while } + s.sub.trees.tb := Z_NULL; + begin + bl := 9; { must be <= 9 for lookahead assumptions } + bd := 6; { must be <= 9 for lookahead assumptions } + t := s.sub.trees.table; + t := inflate_trees_dynamic(257 + (t and $1f), + 1 + ((t shr 5) and $1f), + s.sub.trees.blens^, bl, bd, tl, td, s.hufts^, z); + ZFREE(z, s.sub.trees.blens); + if (t <> Z_OK) then + begin + if (t = uInt(Z_DATA_ERROR)) then + s.mode := BLKBAD; + r := t; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + {$IFDEF DEBUG} + Tracev('inflate: trees ok'); + {$ENDIF} + { c renamed to cs } + cs := inflate_codes_new(bl, bd, tl, td, z); + if (cs = Z_NULL) then + begin + r := Z_MEM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.sub.decode.codes := cs; + end; + s.mode := CODES; + { yet another falltrough } + goto start_codes; + end; + CODES: + begin + start_codes: + { update pointers } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + + r := inflate_codes(s, z, r); + if (r <> Z_STREAM_END) then + begin + inflate_blocks := inflate_flush(s, z, r); + exit; + end; + r := Z_OK; + inflate_codes_free(s.sub.decode.codes, z); + { load local pointers } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + {$IFDEF DEBUG} + if (ptr2int(q) >= ptr2int(s.read)) then + Tracev('inflate: codes end '+ + IntToStr(z.total_out + ptr2int(q) - ptr2int(s.read)) + ' total out') + else + Tracev('inflate: codes end '+ + IntToStr(z.total_out + ptr2int(s.zend) - ptr2int(s.read) + + ptr2int(q) - ptr2int(s.window)) + ' total out'); + {$ENDIF} + if (not s.last) then + begin + s.mode := ZTYPE; + continue; { break for switch statement in C-code } + end; + {$ifndef patch112} + if (k > 7) then { return unused byte, if any } + begin + {$IFDEF DEBUG} + Assert(k < 16, 'inflate_codes grabbed too many bytes'); + {$ENDIF} + Dec(k, 8); + Inc(n); + Dec(p); { can always return one } + end; + {$endif} + s.mode := DRY; + { another falltrough } + goto start_dry; + end; + DRY: + begin + start_dry: + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + + { not needed anymore, we are done: + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + } + + if (s.read <> s.write) then + begin + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + s.mode := BLKDONE; + goto start_blkdone; + end; + BLKDONE: + begin + start_blkdone: + r := Z_STREAM_END; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + BLKBAD: + begin + r := Z_DATA_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + else + begin + r := Z_STREAM_ERROR; + { update pointers and return } + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_blocks := inflate_flush(s,z,r); + exit; + end; + end; { Case s.mode of } + +end; + + +function inflate_blocks_free(s : pInflate_blocks_state; + var z : z_stream) : int; +begin + inflate_blocks_reset(s^, z, Z_NULL); + ZFREE(z, s^.window); + ZFREE(z, s^.hufts); + ZFREE(z, s); + {$IFDEF DEBUG} + Trace('inflate: blocks freed'); + {$ENDIF} + inflate_blocks_free := Z_OK; +end; + + +procedure inflate_set_dictionary(var s : inflate_blocks_state; + const d : array of byte; { dictionary } + n : uInt); { dictionary length } +begin + zmemcpy(s.window, pBytef(@d), n); + s.write := s.window; + Inc(s.write, n); + s.read := s.write; +end; + + +{ Returns true if inflate is currently at the end of a block generated + by Z_SYNC_FLUSH or Z_FULL_FLUSH. + IN assertion: s <> Z_NULL } + +function inflate_blocks_sync_point(var s : inflate_blocks_state) : int; +begin + inflate_blocks_sync_point := int(s.mode = LENS); +end; + +end. diff --git a/Imaging/ZLib/iminfcodes.pas b/Imaging/ZLib/iminfcodes.pas index 5a1a781..0c1de54 100644 --- a/Imaging/ZLib/iminfcodes.pas +++ b/Imaging/ZLib/iminfcodes.pas @@ -1,576 +1,576 @@ -Unit iminfcodes; - -{ infcodes.c -- process literals and length/distance pairs - Copyright (C) 1995-1998 Mark Adler - - Pascal tranlastion - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - -interface - -{$I imzconf.inc} - -uses - {$IFDEF DEBUG} - SysUtils, strutils, - {$ENDIF} - imzutil, impaszlib; - -function inflate_codes_new (bl : uInt; - bd : uInt; - tl : pInflate_huft; - td : pInflate_huft; - var z : z_stream): pInflate_codes_state; - -function inflate_codes(var s : inflate_blocks_state; - var z : z_stream; - r : int) : int; - -procedure inflate_codes_free(c : pInflate_codes_state; - var z : z_stream); - -implementation - -uses - iminfutil, iminffast; - - -function inflate_codes_new (bl : uInt; - bd : uInt; - tl : pInflate_huft; - td : pInflate_huft; - var z : z_stream): pInflate_codes_state; -var - c : pInflate_codes_state; -begin - c := pInflate_codes_state( ZALLOC(z,1,sizeof(inflate_codes_state)) ); - if (c <> Z_NULL) then - begin - c^.mode := START; - c^.lbits := Byte(bl); - c^.dbits := Byte(bd); - c^.ltree := tl; - c^.dtree := td; - {$IFDEF DEBUG} - Tracev('inflate: codes new'); - {$ENDIF} - end; - inflate_codes_new := c; -end; - - -function inflate_codes(var s : inflate_blocks_state; - var z : z_stream; - r : int) : int; -var - j : uInt; { temporary storage } - t : pInflate_huft; { temporary pointer } - e : uInt; { extra bits or operation } - b : uLong; { bit buffer } - k : uInt; { bits in bit buffer } - p : pBytef; { input data pointer } - n : uInt; { bytes available there } - q : pBytef; { output window write pointer } - m : uInt; { bytes to end of window or read pointer } - f : pBytef; { pointer to copy strings from } -var - c : pInflate_codes_state; -begin - c := s.sub.decode.codes; { codes state } - - { copy input/output information to locals } - p := z.next_in; - n := z.avail_in; - b := s.bitb; - k := s.bitk; - q := s.write; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - - { process input and output based on current state } - while True do - case (c^.mode) of - { waiting for "i:"=input, "o:"=output, "x:"=nothing } - START: { x: set up for LEN } - begin -{$ifndef SLOW} - if (m >= 258) and (n >= 10) then - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - - r := inflate_fast(c^.lbits, c^.dbits, c^.ltree, c^.dtree, s, z); - {LOAD} - p := z.next_in; - n := z.avail_in; - b := s.bitb; - k := s.bitk; - q := s.write; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - - if (r <> Z_OK) then - begin - if (r = Z_STREAM_END) then - c^.mode := WASH - else - c^.mode := BADCODE; - continue; { break for switch-statement in C } - end; - end; -{$endif} { not SLOW } - c^.sub.code.need := c^.lbits; - c^.sub.code.tree := c^.ltree; - c^.mode := LEN; { falltrough } - end; - LEN: { i: get length/literal/eob next } - begin - j := c^.sub.code.need; - {NEEDBITS(j);} - while (k < j) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - t := c^.sub.code.tree; - Inc(t, uInt(b) and inflate_mask[j]); - {DUMPBITS(t^.bits);} - b := b shr t^.bits; - Dec(k, t^.bits); - - e := uInt(t^.exop); - if (e = 0) then { literal } - begin - c^.sub.lit := t^.base; - {$IFDEF DEBUG} - if (t^.base >= $20) and (t^.base < $7f) then - Tracevv('inflate: literal '+AnsiChar(t^.base)) - else - Tracevv('inflate: literal '+IntToStr(t^.base)); - {$ENDIF} - c^.mode := LIT; - continue; { break switch statement } - end; - if (e and 16 <> 0) then { length } - begin - c^.sub.copy.get := e and 15; - c^.len := t^.base; - c^.mode := LENEXT; - continue; { break C-switch statement } - end; - if (e and 64 = 0) then { next table } - begin - c^.sub.code.need := e; - c^.sub.code.tree := @huft_ptr(t)^[t^.base]; - continue; { break C-switch statement } - end; - if (e and 32 <> 0) then { end of block } - begin - {$IFDEF DEBUG} - Tracevv('inflate: end of block'); - {$ENDIF} - c^.mode := WASH; - continue; { break C-switch statement } - end; - c^.mode := BADCODE; { invalid code } - z.msg := 'invalid literal/length code'; - r := Z_DATA_ERROR; - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - LENEXT: { i: getting length extra (have base) } - begin - j := c^.sub.copy.get; - {NEEDBITS(j);} - while (k < j) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - Inc(c^.len, uInt(b and inflate_mask[j])); - {DUMPBITS(j);} - b := b shr j; - Dec(k, j); - - c^.sub.code.need := c^.dbits; - c^.sub.code.tree := c^.dtree; - {$IFDEF DEBUG} - Tracevv('inflate: length '+IntToStr(c^.len)); - {$ENDIF} - c^.mode := DIST; - { falltrough } - end; - DIST: { i: get distance next } - begin - j := c^.sub.code.need; - {NEEDBITS(j);} - while (k < j) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - t := @huft_ptr(c^.sub.code.tree)^[uInt(b) and inflate_mask[j]]; - {DUMPBITS(t^.bits);} - b := b shr t^.bits; - Dec(k, t^.bits); - - e := uInt(t^.exop); - if (e and 16 <> 0) then { distance } - begin - c^.sub.copy.get := e and 15; - c^.sub.copy.dist := t^.base; - c^.mode := DISTEXT; - continue; { break C-switch statement } - end; - if (e and 64 = 0) then { next table } - begin - c^.sub.code.need := e; - c^.sub.code.tree := @huft_ptr(t)^[t^.base]; - continue; { break C-switch statement } - end; - c^.mode := BADCODE; { invalid code } - z.msg := 'invalid distance code'; - r := Z_DATA_ERROR; - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - DISTEXT: { i: getting distance extra } - begin - j := c^.sub.copy.get; - {NEEDBITS(j);} - while (k < j) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - Inc(c^.sub.copy.dist, uInt(b) and inflate_mask[j]); - {DUMPBITS(j);} - b := b shr j; - Dec(k, j); - {$IFDEF DEBUG} - Tracevv('inflate: distance '+ IntToStr(c^.sub.copy.dist)); - {$ENDIF} - c^.mode := COPY; - { falltrough } - end; - COPY: { o: copying bytes in window, waiting for space } - begin - f := q; - Dec(f, c^.sub.copy.dist); - if (uInt(ptr2int(q) - ptr2int(s.window)) < c^.sub.copy.dist) then - begin - f := s.zend; - Dec(f, c^.sub.copy.dist - uInt(ptr2int(q) - ptr2int(s.window))); - end; - - while (c^.len <> 0) do - begin - {NEEDOUT} - if (m = 0) then - begin - {WRAP} - if (q = s.zend) and (s.read <> s.window) then - begin - q := s.window; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - end; - - if (m = 0) then - begin - {FLUSH} - s.write := q; - r := inflate_flush(s,z,r); - q := s.write; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - - {WRAP} - if (q = s.zend) and (s.read <> s.window) then - begin - q := s.window; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - end; - - if (m = 0) then - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - end; - end; - r := Z_OK; - - {OUTBYTE( *f++)} - q^ := f^; - Inc(q); - Inc(f); - Dec(m); - - if (f = s.zend) then - f := s.window; - Dec(c^.len); - end; - c^.mode := START; - { C-switch break; not needed } - end; - LIT: { o: got literal, waiting for output space } - begin - {NEEDOUT} - if (m = 0) then - begin - {WRAP} - if (q = s.zend) and (s.read <> s.window) then - begin - q := s.window; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - end; - - if (m = 0) then - begin - {FLUSH} - s.write := q; - r := inflate_flush(s,z,r); - q := s.write; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - - {WRAP} - if (q = s.zend) and (s.read <> s.window) then - begin - q := s.window; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - end; - - if (m = 0) then - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - end; - end; - r := Z_OK; - - {OUTBYTE(c^.sub.lit);} - q^ := c^.sub.lit; - Inc(q); - Dec(m); - - c^.mode := START; - {break;} - end; - WASH: { o: got eob, possibly more output } - begin - {$ifdef patch112} - if (k > 7) then { return unused byte, if any } - begin - {$IFDEF DEBUG} - Assert(k < 16, 'inflate_codes grabbed too many bytes'); - {$ENDIF} - Dec(k, 8); - Inc(n); - Dec(p); { can always return one } - end; - {$endif} - {FLUSH} - s.write := q; - r := inflate_flush(s,z,r); - q := s.write; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - - if (s.read <> s.write) then - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - c^.mode := ZEND; - { falltrough } - end; - - ZEND: - begin - r := Z_STREAM_END; - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - BADCODE: { x: got error } - begin - r := Z_DATA_ERROR; - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - else - begin - r := Z_STREAM_ERROR; - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_codes := inflate_flush(s,z,r); - exit; - end; - end; -{NEED_DUMMY_RETURN - Delphi2+ dumb compilers complain without this } - inflate_codes := Z_STREAM_ERROR; -end; - - -procedure inflate_codes_free(c : pInflate_codes_state; - var z : z_stream); -begin - ZFREE(z, c); - {$IFDEF DEBUG} - Tracev('inflate: codes free'); - {$ENDIF} -end; - -end. +Unit iminfcodes; + +{ infcodes.c -- process literals and length/distance pairs + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I imzconf.inc} + +uses + {$IFDEF DEBUG} + SysUtils, strutils, + {$ENDIF} + imzutil, impaszlib; + +function inflate_codes_new (bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var z : z_stream): pInflate_codes_state; + +function inflate_codes(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; + +procedure inflate_codes_free(c : pInflate_codes_state; + var z : z_stream); + +implementation + +uses + iminfutil, iminffast; + + +function inflate_codes_new (bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var z : z_stream): pInflate_codes_state; +var + c : pInflate_codes_state; +begin + c := pInflate_codes_state( ZALLOC(z,1,sizeof(inflate_codes_state)) ); + if (c <> Z_NULL) then + begin + c^.mode := START; + c^.lbits := Byte(bl); + c^.dbits := Byte(bd); + c^.ltree := tl; + c^.dtree := td; + {$IFDEF DEBUG} + Tracev('inflate: codes new'); + {$ENDIF} + end; + inflate_codes_new := c; +end; + + +function inflate_codes(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; +var + j : uInt; { temporary storage } + t : pInflate_huft; { temporary pointer } + e : uInt; { extra bits or operation } + b : uLong; { bit buffer } + k : uInt; { bits in bit buffer } + p : pBytef; { input data pointer } + n : uInt; { bytes available there } + q : pBytef; { output window write pointer } + m : uInt; { bytes to end of window or read pointer } + f : pBytef; { pointer to copy strings from } +var + c : pInflate_codes_state; +begin + c := s.sub.decode.codes; { codes state } + + { copy input/output information to locals } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + { process input and output based on current state } + while True do + case (c^.mode) of + { waiting for "i:"=input, "o:"=output, "x:"=nothing } + START: { x: set up for LEN } + begin +{$ifndef SLOW} + if (m >= 258) and (n >= 10) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + + r := inflate_fast(c^.lbits, c^.dbits, c^.ltree, c^.dtree, s, z); + {LOAD} + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + if (r <> Z_OK) then + begin + if (r = Z_STREAM_END) then + c^.mode := WASH + else + c^.mode := BADCODE; + continue; { break for switch-statement in C } + end; + end; +{$endif} { not SLOW } + c^.sub.code.need := c^.lbits; + c^.sub.code.tree := c^.ltree; + c^.mode := LEN; { falltrough } + end; + LEN: { i: get length/literal/eob next } + begin + j := c^.sub.code.need; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + t := c^.sub.code.tree; + Inc(t, uInt(b) and inflate_mask[j]); + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + e := uInt(t^.exop); + if (e = 0) then { literal } + begin + c^.sub.lit := t^.base; + {$IFDEF DEBUG} + if (t^.base >= $20) and (t^.base < $7f) then + Tracevv('inflate: literal '+AnsiChar(t^.base)) + else + Tracevv('inflate: literal '+IntToStr(t^.base)); + {$ENDIF} + c^.mode := LIT; + continue; { break switch statement } + end; + if (e and 16 <> 0) then { length } + begin + c^.sub.copy.get := e and 15; + c^.len := t^.base; + c^.mode := LENEXT; + continue; { break C-switch statement } + end; + if (e and 64 = 0) then { next table } + begin + c^.sub.code.need := e; + c^.sub.code.tree := @huft_ptr(t)^[t^.base]; + continue; { break C-switch statement } + end; + if (e and 32 <> 0) then { end of block } + begin + {$IFDEF DEBUG} + Tracevv('inflate: end of block'); + {$ENDIF} + c^.mode := WASH; + continue; { break C-switch statement } + end; + c^.mode := BADCODE; { invalid code } + z.msg := 'invalid literal/length code'; + r := Z_DATA_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + LENEXT: { i: getting length extra (have base) } + begin + j := c^.sub.copy.get; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + Inc(c^.len, uInt(b and inflate_mask[j])); + {DUMPBITS(j);} + b := b shr j; + Dec(k, j); + + c^.sub.code.need := c^.dbits; + c^.sub.code.tree := c^.dtree; + {$IFDEF DEBUG} + Tracevv('inflate: length '+IntToStr(c^.len)); + {$ENDIF} + c^.mode := DIST; + { falltrough } + end; + DIST: { i: get distance next } + begin + j := c^.sub.code.need; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + t := @huft_ptr(c^.sub.code.tree)^[uInt(b) and inflate_mask[j]]; + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + e := uInt(t^.exop); + if (e and 16 <> 0) then { distance } + begin + c^.sub.copy.get := e and 15; + c^.sub.copy.dist := t^.base; + c^.mode := DISTEXT; + continue; { break C-switch statement } + end; + if (e and 64 = 0) then { next table } + begin + c^.sub.code.need := e; + c^.sub.code.tree := @huft_ptr(t)^[t^.base]; + continue; { break C-switch statement } + end; + c^.mode := BADCODE; { invalid code } + z.msg := 'invalid distance code'; + r := Z_DATA_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + DISTEXT: { i: getting distance extra } + begin + j := c^.sub.copy.get; + {NEEDBITS(j);} + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + Inc(c^.sub.copy.dist, uInt(b) and inflate_mask[j]); + {DUMPBITS(j);} + b := b shr j; + Dec(k, j); + {$IFDEF DEBUG} + Tracevv('inflate: distance '+ IntToStr(c^.sub.copy.dist)); + {$ENDIF} + c^.mode := COPY; + { falltrough } + end; + COPY: { o: copying bytes in window, waiting for space } + begin + f := q; + Dec(f, c^.sub.copy.dist); + if (uInt(ptr2int(q) - ptr2int(s.window)) < c^.sub.copy.dist) then + begin + f := s.zend; + Dec(f, c^.sub.copy.dist - uInt(ptr2int(q) - ptr2int(s.window))); + end; + + while (c^.len <> 0) do + begin + {NEEDOUT} + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + + {OUTBYTE( *f++)} + q^ := f^; + Inc(q); + Inc(f); + Dec(m); + + if (f = s.zend) then + f := s.window; + Dec(c^.len); + end; + c^.mode := START; + { C-switch break; not needed } + end; + LIT: { o: got literal, waiting for output space } + begin + {NEEDOUT} + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + + {OUTBYTE(c^.sub.lit);} + q^ := c^.sub.lit; + Inc(q); + Dec(m); + + c^.mode := START; + {break;} + end; + WASH: { o: got eob, possibly more output } + begin + {$ifdef patch112} + if (k > 7) then { return unused byte, if any } + begin + {$IFDEF DEBUG} + Assert(k < 16, 'inflate_codes grabbed too many bytes'); + {$ENDIF} + Dec(k, 8); + Inc(n); + Dec(p); { can always return one } + end; + {$endif} + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + if (s.read <> s.write) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + c^.mode := ZEND; + { falltrough } + end; + + ZEND: + begin + r := Z_STREAM_END; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + BADCODE: { x: got error } + begin + r := Z_DATA_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + else + begin + r := Z_STREAM_ERROR; + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_codes := inflate_flush(s,z,r); + exit; + end; + end; +{NEED_DUMMY_RETURN - Delphi2+ dumb compilers complain without this } + inflate_codes := Z_STREAM_ERROR; +end; + + +procedure inflate_codes_free(c : pInflate_codes_state; + var z : z_stream); +begin + ZFREE(z, c); + {$IFDEF DEBUG} + Tracev('inflate: codes free'); + {$ENDIF} +end; + +end. diff --git a/Imaging/ZLib/iminffast.pas b/Imaging/ZLib/iminffast.pas index 400b0fc..84210c2 100644 --- a/Imaging/ZLib/iminffast.pas +++ b/Imaging/ZLib/iminffast.pas @@ -1,318 +1,318 @@ -Unit iminffast; - -{ - inffast.h and - inffast.c -- process literals and length/distance pairs fast - Copyright (C) 1995-1998 Mark Adler - - Pascal tranlastion - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - - -interface - -{$I imzconf.inc} - -uses - {$ifdef DEBUG} - SysUtils, strutils, - {$ENDIF} - imzutil, impaszlib; - -function inflate_fast( bl : uInt; - bd : uInt; - tl : pInflate_huft; - td : pInflate_huft; - var s : inflate_blocks_state; - var z : z_stream) : int; - - -implementation - -uses - iminfutil; - - -{ Called with number of bytes left to write in window at least 258 - (the maximum string length) and number of input bytes available - at least ten. The ten bytes are six bytes for the longest length/ - distance pair plus four bytes for overloading the bit buffer. } - -function inflate_fast( bl : uInt; - bd : uInt; - tl : pInflate_huft; - td : pInflate_huft; - var s : inflate_blocks_state; - var z : z_stream) : int; - -var - t : pInflate_huft; { temporary pointer } - e : uInt; { extra bits or operation } - b : uLong; { bit buffer } - k : uInt; { bits in bit buffer } - p : pBytef; { input data pointer } - n : uInt; { bytes available there } - q : pBytef; { output window write pointer } - m : uInt; { bytes to end of window or read pointer } - ml : uInt; { mask for literal/length tree } - md : uInt; { mask for distance tree } - c : uInt; { bytes to copy } - d : uInt; { distance back to copy from } - r : pBytef; { copy source pointer } -begin - { load input, output, bit values (macro LOAD) } - p := z.next_in; - n := z.avail_in; - b := s.bitb; - k := s.bitk; - q := s.write; - if ptr2int(q) < ptr2int(s.read) then - m := uInt(ptr2int(s.read)-ptr2int(q)-1) - else - m := uInt(ptr2int(s.zend)-ptr2int(q)); - - { initialize masks } - ml := inflate_mask[bl]; - md := inflate_mask[bd]; - - { do until not enough input or output space for fast loop } - repeat { assume called with (m >= 258) and (n >= 10) } - { get literal/length code } - {GRABBITS(20);} { max bits for literal/length code } - while (k < 20) do - begin - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - - t := @(huft_ptr(tl)^[uInt(b) and ml]); - - e := t^.exop; - if (e = 0) then - begin - {DUMPBITS(t^.bits);} - b := b shr t^.bits; - Dec(k, t^.bits); - {$IFDEF DEBUG} - if (t^.base >= $20) and (t^.base < $7f) then - Tracevv('inflate: * literal '+AnsiChar(t^.base)) - else - Tracevv('inflate: * literal '+ IntToStr(t^.base)); - {$ENDIF} - q^ := Byte(t^.base); - Inc(q); - Dec(m); - continue; - end; - repeat - {DUMPBITS(t^.bits);} - b := b shr t^.bits; - Dec(k, t^.bits); - - if (e and 16 <> 0) then - begin - { get extra bits for length } - e := e and 15; - c := t^.base + (uInt(b) and inflate_mask[e]); - {DUMPBITS(e);} - b := b shr e; - Dec(k, e); - {$IFDEF DEBUG} - Tracevv('inflate: * length ' + IntToStr(c)); - {$ENDIF} - { decode distance base of block to copy } - {GRABBITS(15);} { max bits for distance code } - while (k < 15) do - begin - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - - t := @huft_ptr(td)^[uInt(b) and md]; - e := t^.exop; - repeat - {DUMPBITS(t^.bits);} - b := b shr t^.bits; - Dec(k, t^.bits); - - if (e and 16 <> 0) then - begin - { get extra bits to add to distance base } - e := e and 15; - {GRABBITS(e);} { get extra bits (up to 13) } - while (k < e) do - begin - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - - d := t^.base + (uInt(b) and inflate_mask[e]); - {DUMPBITS(e);} - b := b shr e; - Dec(k, e); - - {$IFDEF DEBUG} - Tracevv('inflate: * distance '+IntToStr(d)); - {$ENDIF} - { do the copy } - Dec(m, c); - if (uInt(ptr2int(q) - ptr2int(s.window)) >= d) then { offset before dest } - begin { just copy } - r := q; - Dec(r, d); - q^ := r^; Inc(q); Inc(r); Dec(c); { minimum count is three, } - q^ := r^; Inc(q); Inc(r); Dec(c); { so unroll loop a little } - end - else { else offset after destination } - begin - e := d - uInt(ptr2int(q) - ptr2int(s.window)); { bytes from offset to end } - r := s.zend; - Dec(r, e); { pointer to offset } - if (c > e) then { if source crosses, } - begin - Dec(c, e); { copy to end of window } - repeat - q^ := r^; - Inc(q); - Inc(r); - Dec(e); - until (e=0); - r := s.window; { copy rest from start of window } - end; - end; - repeat { copy all or what's left } - q^ := r^; - Inc(q); - Inc(r); - Dec(c); - until (c = 0); - break; - end - else - if (e and 64 = 0) then - begin - Inc(t, t^.base + (uInt(b) and inflate_mask[e])); - e := t^.exop; - end - else - begin - z.msg := 'invalid distance code'; - {UNGRAB} - c := z.avail_in-n; - if (k shr 3) < c then - c := k shr 3; - Inc(n, c); - Dec(p, c); - Dec(k, c shl 3); - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - - inflate_fast := Z_DATA_ERROR; - exit; - end; - until FALSE; - break; - end; - if (e and 64 = 0) then - begin - {t += t->base; - e = (t += ((uInt)b & inflate_mask[e]))->exop;} - - Inc(t, t^.base + (uInt(b) and inflate_mask[e])); - e := t^.exop; - if (e = 0) then - begin - {DUMPBITS(t^.bits);} - b := b shr t^.bits; - Dec(k, t^.bits); - - {$IFDEF DEBUG} - if (t^.base >= $20) and (t^.base < $7f) then - Tracevv('inflate: * literal '+AnsiChar(t^.base)) - else - Tracevv('inflate: * literal '+IntToStr(t^.base)); - {$ENDIF} - q^ := Byte(t^.base); - Inc(q); - Dec(m); - break; - end; - end - else - if (e and 32 <> 0) then - begin - {$IFDEF DEBUG} - Tracevv('inflate: * end of block'); - {$ENDIF} - {UNGRAB} - c := z.avail_in-n; - if (k shr 3) < c then - c := k shr 3; - Inc(n, c); - Dec(p, c); - Dec(k, c shl 3); - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_fast := Z_STREAM_END; - exit; - end - else - begin - z.msg := 'invalid literal/length code'; - {UNGRAB} - c := z.avail_in-n; - if (k shr 3) < c then - c := k shr 3; - Inc(n, c); - Dec(p, c); - Dec(k, c shl 3); - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_fast := Z_DATA_ERROR; - exit; - end; - until FALSE; - until (m < 258) or (n < 10); - - { not enough input or output--restore pointers and return } - {UNGRAB} - c := z.avail_in-n; - if (k shr 3) < c then - c := k shr 3; - Inc(n, c); - Dec(p, c); - Dec(k, c shl 3); - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); - z.next_in := p; - s.write := q; - inflate_fast := Z_OK; -end; - -end. +Unit iminffast; + +{ + inffast.h and + inffast.c -- process literals and length/distance pairs fast + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + + +interface + +{$I imzconf.inc} + +uses + {$ifdef DEBUG} + SysUtils, strutils, + {$ENDIF} + imzutil, impaszlib; + +function inflate_fast( bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var s : inflate_blocks_state; + var z : z_stream) : int; + + +implementation + +uses + iminfutil; + + +{ Called with number of bytes left to write in window at least 258 + (the maximum string length) and number of input bytes available + at least ten. The ten bytes are six bytes for the longest length/ + distance pair plus four bytes for overloading the bit buffer. } + +function inflate_fast( bl : uInt; + bd : uInt; + tl : pInflate_huft; + td : pInflate_huft; + var s : inflate_blocks_state; + var z : z_stream) : int; + +var + t : pInflate_huft; { temporary pointer } + e : uInt; { extra bits or operation } + b : uLong; { bit buffer } + k : uInt; { bits in bit buffer } + p : pBytef; { input data pointer } + n : uInt; { bytes available there } + q : pBytef; { output window write pointer } + m : uInt; { bytes to end of window or read pointer } + ml : uInt; { mask for literal/length tree } + md : uInt; { mask for distance tree } + c : uInt; { bytes to copy } + d : uInt; { distance back to copy from } + r : pBytef; { copy source pointer } +begin + { load input, output, bit values (macro LOAD) } + p := z.next_in; + n := z.avail_in; + b := s.bitb; + k := s.bitk; + q := s.write; + if ptr2int(q) < ptr2int(s.read) then + m := uInt(ptr2int(s.read)-ptr2int(q)-1) + else + m := uInt(ptr2int(s.zend)-ptr2int(q)); + + { initialize masks } + ml := inflate_mask[bl]; + md := inflate_mask[bd]; + + { do until not enough input or output space for fast loop } + repeat { assume called with (m >= 258) and (n >= 10) } + { get literal/length code } + {GRABBITS(20);} { max bits for literal/length code } + while (k < 20) do + begin + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := @(huft_ptr(tl)^[uInt(b) and ml]); + + e := t^.exop; + if (e = 0) then + begin + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + {$IFDEF DEBUG} + if (t^.base >= $20) and (t^.base < $7f) then + Tracevv('inflate: * literal '+AnsiChar(t^.base)) + else + Tracevv('inflate: * literal '+ IntToStr(t^.base)); + {$ENDIF} + q^ := Byte(t^.base); + Inc(q); + Dec(m); + continue; + end; + repeat + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + if (e and 16 <> 0) then + begin + { get extra bits for length } + e := e and 15; + c := t^.base + (uInt(b) and inflate_mask[e]); + {DUMPBITS(e);} + b := b shr e; + Dec(k, e); + {$IFDEF DEBUG} + Tracevv('inflate: * length ' + IntToStr(c)); + {$ENDIF} + { decode distance base of block to copy } + {GRABBITS(15);} { max bits for distance code } + while (k < 15) do + begin + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + t := @huft_ptr(td)^[uInt(b) and md]; + e := t^.exop; + repeat + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + if (e and 16 <> 0) then + begin + { get extra bits to add to distance base } + e := e and 15; + {GRABBITS(e);} { get extra bits (up to 13) } + while (k < e) do + begin + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + + d := t^.base + (uInt(b) and inflate_mask[e]); + {DUMPBITS(e);} + b := b shr e; + Dec(k, e); + + {$IFDEF DEBUG} + Tracevv('inflate: * distance '+IntToStr(d)); + {$ENDIF} + { do the copy } + Dec(m, c); + if (uInt(ptr2int(q) - ptr2int(s.window)) >= d) then { offset before dest } + begin { just copy } + r := q; + Dec(r, d); + q^ := r^; Inc(q); Inc(r); Dec(c); { minimum count is three, } + q^ := r^; Inc(q); Inc(r); Dec(c); { so unroll loop a little } + end + else { else offset after destination } + begin + e := d - uInt(ptr2int(q) - ptr2int(s.window)); { bytes from offset to end } + r := s.zend; + Dec(r, e); { pointer to offset } + if (c > e) then { if source crosses, } + begin + Dec(c, e); { copy to end of window } + repeat + q^ := r^; + Inc(q); + Inc(r); + Dec(e); + until (e=0); + r := s.window; { copy rest from start of window } + end; + end; + repeat { copy all or what's left } + q^ := r^; + Inc(q); + Inc(r); + Dec(c); + until (c = 0); + break; + end + else + if (e and 64 = 0) then + begin + Inc(t, t^.base + (uInt(b) and inflate_mask[e])); + e := t^.exop; + end + else + begin + z.msg := 'invalid distance code'; + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + + inflate_fast := Z_DATA_ERROR; + exit; + end; + until FALSE; + break; + end; + if (e and 64 = 0) then + begin + {t += t->base; + e = (t += ((uInt)b & inflate_mask[e]))->exop;} + + Inc(t, t^.base + (uInt(b) and inflate_mask[e])); + e := t^.exop; + if (e = 0) then + begin + {DUMPBITS(t^.bits);} + b := b shr t^.bits; + Dec(k, t^.bits); + + {$IFDEF DEBUG} + if (t^.base >= $20) and (t^.base < $7f) then + Tracevv('inflate: * literal '+AnsiChar(t^.base)) + else + Tracevv('inflate: * literal '+IntToStr(t^.base)); + {$ENDIF} + q^ := Byte(t^.base); + Inc(q); + Dec(m); + break; + end; + end + else + if (e and 32 <> 0) then + begin + {$IFDEF DEBUG} + Tracevv('inflate: * end of block'); + {$ENDIF} + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_fast := Z_STREAM_END; + exit; + end + else + begin + z.msg := 'invalid literal/length code'; + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_fast := Z_DATA_ERROR; + exit; + end; + until FALSE; + until (m < 258) or (n < 10); + + { not enough input or output--restore pointers and return } + {UNGRAB} + c := z.avail_in-n; + if (k shr 3) < c then + c := k shr 3; + Inc(n, c); + Dec(p, c); + Dec(k, c shl 3); + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, ptr2int(p)-ptr2int(z.next_in)); + z.next_in := p; + s.write := q; + inflate_fast := Z_OK; +end; + +end. diff --git a/Imaging/ZLib/iminftrees.pas b/Imaging/ZLib/iminftrees.pas index 6949a63..94278af 100644 --- a/Imaging/ZLib/iminftrees.pas +++ b/Imaging/ZLib/iminftrees.pas @@ -1,781 +1,781 @@ -Unit iminftrees; - -{ inftrees.h -- header to use inftrees.c - inftrees.c -- generate Huffman trees for efficient decoding - Copyright (C) 1995-1998 Mark Adler - - WARNING: this file should *not* be used by applications. It is - part of the implementation of the compression library and is - subject to change. - - Pascal tranlastion - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - -Interface - -{$I imzconf.inc} - -uses - imzutil, impaszlib; - - -{ Maximum size of dynamic tree. The maximum found in a long but non- - exhaustive search was 1004 huft structures (850 for length/literals - and 154 for distances, the latter actually the result of an - exhaustive search). The actual maximum is not known, but the - value below is more than safe. } -const - MANY = 1440; - - -{$ifdef DEBUG} -var - inflate_hufts : uInt; -{$endif} - -function inflate_trees_bits( - var c : array of uIntf; { 19 code lengths } - var bb : uIntf; { bits tree desired/actual depth } - var tb : pinflate_huft; { bits tree result } - var hp : array of Inflate_huft; { space for trees } - var z : z_stream { for messages } - ) : int; - -function inflate_trees_dynamic( - nl : uInt; { number of literal/length codes } - nd : uInt; { number of distance codes } - var c : Array of uIntf; { that many (total) code lengths } - var bl : uIntf; { literal desired/actual bit depth } - var bd : uIntf; { distance desired/actual bit depth } -var tl : pInflate_huft; { literal/length tree result } -var td : pInflate_huft; { distance tree result } -var hp : array of Inflate_huft; { space for trees } -var z : z_stream { for messages } - ) : int; - -function inflate_trees_fixed ( - var bl : uInt; { literal desired/actual bit depth } - var bd : uInt; { distance desired/actual bit depth } - var tl : pInflate_huft; { literal/length tree result } - var td : pInflate_huft; { distance tree result } - var z : z_stream { for memory allocation } - ) : int; - - -implementation - -const - inflate_copyright = 'inflate 1.1.2 Copyright 1995-1998 Mark Adler'; - -{ - If you use the zlib library in a product, an acknowledgment is welcome - in the documentation of your product. If for some reason you cannot - include such an acknowledgment, I would appreciate that you keep this - copyright string in the executable of your product. -} - - -const -{ Tables for deflate from PKZIP's appnote.txt. } - cplens : Array [0..30] Of uInt { Copy lengths for literal codes 257..285 } - = (3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, - 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0); - { actually lengths - 2; also see note #13 above about 258 } - - invalid_code = 112; - - cplext : Array [0..30] Of uInt { Extra bits for literal codes 257..285 } - = (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, - 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, invalid_code, invalid_code); - - cpdist : Array [0..29] Of uInt { Copy offsets for distance codes 0..29 } - = (1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, - 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, - 8193, 12289, 16385, 24577); - - cpdext : Array [0..29] Of uInt { Extra bits for distance codes } - = (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, - 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, - 12, 12, 13, 13); - -{ Huffman code decoding is performed using a multi-level table lookup. - The fastest way to decode is to simply build a lookup table whose - size is determined by the longest code. However, the time it takes - to build this table can also be a factor if the data being decoded - is not very long. The most common codes are necessarily the - shortest codes, so those codes dominate the decoding time, and hence - the speed. The idea is you can have a shorter table that decodes the - shorter, more probable codes, and then point to subsidiary tables for - the longer codes. The time it costs to decode the longer codes is - then traded against the time it takes to make longer tables. - - This results of this trade are in the variables lbits and dbits - below. lbits is the number of bits the first level table for literal/ - length codes can decode in one step, and dbits is the same thing for - the distance codes. Subsequent tables are also less than or equal to - those sizes. These values may be adjusted either when all of the - codes are shorter than that, in which case the longest code length in - bits is used, or when the shortest code is *longer* than the requested - table size, in which case the length of the shortest code in bits is - used. - - There are two different values for the two tables, since they code a - different number of possibilities each. The literal/length table - codes 286 possible values, or in a flat code, a little over eight - bits. The distance table codes 30 possible values, or a little less - than five bits, flat. The optimum values for speed end up being - about one bit more than those, so lbits is 8+1 and dbits is 5+1. - The optimum values may differ though from machine to machine, and - possibly even between compilers. Your mileage may vary. } - - -{ If BMAX needs to be larger than 16, then h and x[] should be uLong. } -const - BMAX = 15; { maximum bit length of any code } - -{$DEFINE USE_PTR} - -function huft_build( -var b : array of uIntf; { code lengths in bits (all assumed <= BMAX) } - n : uInt; { number of codes (assumed <= N_MAX) } - s : uInt; { number of simple-valued codes (0..s-1) } -const d : array of uIntf; { list of base values for non-simple codes } -{ array of word } -const e : array of uIntf; { list of extra bits for non-simple codes } -{ array of byte } - t : ppInflate_huft; { result: starting table } -var m : uIntf; { maximum lookup bits, returns actual } -var hp : array of inflate_huft; { space for trees } -var hn : uInt; { hufts used in space } -var v : array of uIntf { working area: values in order of bit length } - ) : int; -{ Given a list of code lengths and a maximum table size, make a set of - tables to decode that set of codes. Return Z_OK on success, Z_BUF_ERROR - if the given code set is incomplete (the tables are still built in this - case), Z_DATA_ERROR if the input is invalid (an over-subscribed set of - lengths), or Z_MEM_ERROR if not enough memory. } -Var - a : uInt; { counter for codes of length k } - c : Array [0..BMAX] Of uInt; { bit length count table } - f : uInt; { i repeats in table every f entries } - g : int; { maximum code length } - h : int; { table level } - i : uInt; {register} { counter, current code } - j : uInt; {register} { counter } - k : Int; {register} { number of bits in current code } - l : int; { bits per table (returned in m) } - mask : uInt; { (1 shl w) - 1, to avoid cc -O bug on HP } - p : ^uIntf; {register} { pointer into c[], b[], or v[] } - q : pInflate_huft; { points to current table } - r : inflate_huft; { table entry for structure assignment } - u : Array [0..BMAX-1] Of pInflate_huft; { table stack } - w : int; {register} { bits before this table = (l*h) } - x : Array [0..BMAX] Of uInt; { bit offsets, then code stack } - {$IFDEF USE_PTR} - xp : puIntf; { pointer into x } - {$ELSE} - xp : uInt; - {$ENDIF} - y : int; { number of dummy codes added } - z : uInt; { number of entries in current table } -Begin - { Generate counts for each bit length } - FillChar(c,SizeOf(c),0) ; { clear c[] } - - for i := 0 to n-1 do - Inc (c[b[i]]); { assume all entries <= BMAX } - - If (c[0] = n) Then { null input--all zero length codes } - Begin - t^ := pInflate_huft(NIL); - m := 0 ; - huft_build := Z_OK ; - Exit; - End ; - - { Find minimum and maximum length, bound [m] by those } - l := m; - for j:=1 To BMAX do - if (c[j] <> 0) then - break; - k := j ; { minimum code length } - if (uInt(l) < j) then - l := j; - for i := BMAX downto 1 do - if (c[i] <> 0) then - break ; - g := i ; { maximum code length } - if (uInt(l) > i) then - l := i; - m := l; - - { Adjust last length count to fill out codes, if needed } - y := 1 shl j ; - while (j < i) do - begin - Dec(y, c[j]) ; - if (y < 0) then - begin - huft_build := Z_DATA_ERROR; { bad input: more codes than bits } - exit; - end ; - Inc(j) ; - y := y shl 1 - end; - Dec (y, c[i]) ; - if (y < 0) then - begin - huft_build := Z_DATA_ERROR; { bad input: more codes than bits } - exit; - end; - Inc(c[i], y); - - { Generate starting offsets into the value table FOR each length } - {$IFDEF USE_PTR} - x[1] := 0; - j := 0; - - p := @c[1]; - xp := @x[2]; - - dec(i); { note that i = g from above } - WHILE (i > 0) DO - BEGIN - inc(j, p^); - xp^ := j; - inc(p); - inc(xp); - dec(i); - END; - {$ELSE} - x[1] := 0; - j := 0 ; - for i := 1 to g do - begin - x[i] := j; - Inc(j, c[i]); - end; - {$ENDIF} - - { Make a table of values in order of bit lengths } - for i := 0 to n-1 do - begin - j := b[i]; - if (j <> 0) then - begin - v[ x[j] ] := i; - Inc(x[j]); - end; - end; - n := x[g]; { set n to length of v } - - { Generate the Huffman codes and for each, make the table entries } - i := 0 ; - x[0] := 0 ; { first Huffman code is zero } - p := Addr(v) ; { grab values in bit order } - h := -1 ; { no tables yet--level -1 } - w := -l ; { bits decoded = (l*h) } - - u[0] := pInflate_huft(NIL); { just to keep compilers happy } - q := pInflate_huft(NIL); { ditto } - z := 0 ; { ditto } - - { go through the bit lengths (k already is bits in shortest code) } - while (k <= g) Do - begin - a := c[k] ; - while (a<>0) Do - begin - Dec (a) ; - { here i is the Huffman code of length k bits for value p^ } - { make tables up to required level } - while (k > w + l) do - begin - - Inc (h) ; - Inc (w, l); { add bits already decoded } - { previous table always l bits } - { compute minimum size table less than or equal to l bits } - - { table size upper limit } - z := g - w; - If (z > uInt(l)) Then - z := l; - - { try a k-w bit table } - j := k - w; - f := 1 shl j; - if (f > a+1) Then { too few codes for k-w bit table } - begin - Dec(f, a+1); { deduct codes from patterns left } - {$IFDEF USE_PTR} - xp := Addr(c[k]); - - if (j < z) then - begin - Inc(j); - while (j < z) do - begin { try smaller tables up to z bits } - f := f shl 1; - Inc (xp) ; - If (f <= xp^) Then - break; { enough codes to use up j bits } - Dec(f, xp^); { else deduct codes from patterns } - Inc(j); - end; - end; - {$ELSE} - xp := k; - - if (j < z) then - begin - Inc (j) ; - While (j < z) Do - begin { try smaller tables up to z bits } - f := f * 2; - Inc (xp) ; - if (f <= c[xp]) then - Break ; { enough codes to use up j bits } - Dec (f, c[xp]) ; { else deduct codes from patterns } - Inc (j); - end; - end; - {$ENDIF} - end; - - z := 1 shl j; { table entries for j-bit table } - - { allocate new table } - if (hn + z > MANY) then { (note: doesn't matter for fixed) } - begin - huft_build := Z_MEM_ERROR; { not enough memory } - exit; - end; - - q := @hp[hn]; - u[h] := q; - Inc(hn, z); - - { connect to last table, if there is one } - if (h <> 0) then - begin - x[h] := i; { save pattern for backing up } - r.bits := Byte(l); { bits to dump before this table } - r.exop := Byte(j); { bits in this table } - j := i shr (w - l); - {r.base := uInt( q - u[h-1] -j);} { offset to this table } - r.base := (ptr2int(q) - ptr2int(u[h-1]) ) div sizeof(q^) - j; - huft_Ptr(u[h-1])^[j] := r; { connect to last table } - end - else - t^ := q; { first table is returned result } - end; - - { set up table entry in r } - r.bits := Byte(k - w); - - { C-code: if (p >= v + n) - see ZUTIL.PAS for comments } - - if ptr2int(p)>=ptr2int(@(v[n])) then { also works under DPMI ?? } - r.exop := 128 + 64 { out of values--invalid code } - else - if (p^ < s) then - begin - if (p^ < 256) then { 256 is end-of-block code } - r.exop := 0 - Else - r.exop := 32 + 64; { EOB_code; } - r.base := p^; { simple code is just the value } - Inc(p); - end - Else - begin - r.exop := Byte(e[p^-s] + 16 + 64); { non-simple--look up in lists } - r.base := d[p^-s]; - Inc (p); - end ; - - { fill code-like entries with r } - f := 1 shl (k - w); - j := i shr w; - while (j < z) do - begin - huft_Ptr(q)^[j] := r; - Inc(j, f); - end; - - { backwards increment the k-bit code i } - j := 1 shl (k-1) ; - while (i and j) <> 0 do - begin - i := i xor j; { bitwise exclusive or } - j := j shr 1 - end ; - i := i xor j; - - { backup over finished tables } - mask := (1 shl w) - 1; { needed on HP, cc -O bug } - while ((i and mask) <> x[h]) do - begin - Dec(h); { don't need to update q } - Dec(w, l); - mask := (1 shl w) - 1; - end; - - end; - - Inc(k); - end; - - { Return Z_BUF_ERROR if we were given an incomplete table } - if (y <> 0) And (g <> 1) then - huft_build := Z_BUF_ERROR - else - huft_build := Z_OK; -end; { huft_build} - - -function inflate_trees_bits( - var c : array of uIntf; { 19 code lengths } - var bb : uIntf; { bits tree desired/actual depth } - var tb : pinflate_huft; { bits tree result } - var hp : array of Inflate_huft; { space for trees } - var z : z_stream { for messages } - ) : int; -var - r : int; - hn : uInt; { hufts used in space } - v : PuIntArray; { work area for huft_build } -begin - hn := 0; - v := PuIntArray( ZALLOC(z, 19, sizeof(uInt)) ); - if (v = Z_NULL) then - begin - inflate_trees_bits := Z_MEM_ERROR; - exit; - end; - - r := huft_build(c, 19, 19, cplens, cplext, - {puIntf(Z_NULL), puIntf(Z_NULL),} - @tb, bb, hp, hn, v^); - if (r = Z_DATA_ERROR) then - z.msg := 'oversubscribed dynamic bit lengths tree' - else - if (r = Z_BUF_ERROR) or (bb = 0) then - begin - z.msg := 'incomplete dynamic bit lengths tree'; - r := Z_DATA_ERROR; - end; - ZFREE(z, v); - inflate_trees_bits := r; -end; - - -function inflate_trees_dynamic( - nl : uInt; { number of literal/length codes } - nd : uInt; { number of distance codes } - var c : Array of uIntf; { that many (total) code lengths } - var bl : uIntf; { literal desired/actual bit depth } - var bd : uIntf; { distance desired/actual bit depth } -var tl : pInflate_huft; { literal/length tree result } -var td : pInflate_huft; { distance tree result } -var hp : array of Inflate_huft; { space for trees } -var z : z_stream { for messages } - ) : int; -var - r : int; - hn : uInt; { hufts used in space } - v : PuIntArray; { work area for huft_build } -begin - hn := 0; - { allocate work area } - v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) ); - if (v = Z_NULL) then - begin - inflate_trees_dynamic := Z_MEM_ERROR; - exit; - end; - - { build literal/length tree } - r := huft_build(c, nl, 257, cplens, cplext, @tl, bl, hp, hn, v^); - if (r <> Z_OK) or (bl = 0) then - begin - if (r = Z_DATA_ERROR) then - z.msg := 'oversubscribed literal/length tree' - else - if (r <> Z_MEM_ERROR) then - begin - z.msg := 'incomplete literal/length tree'; - r := Z_DATA_ERROR; - end; - - ZFREE(z, v); - inflate_trees_dynamic := r; - exit; - end; - - { build distance tree } - r := huft_build(puIntArray(@c[nl])^, nd, 0, - cpdist, cpdext, @td, bd, hp, hn, v^); - if (r <> Z_OK) or ((bd = 0) and (nl > 257)) then - begin - if (r = Z_DATA_ERROR) then - z.msg := 'oversubscribed literal/length tree' - else - if (r = Z_BUF_ERROR) then - begin -{$ifdef PKZIP_BUG_WORKAROUND} - r := Z_OK; - end; -{$else} - z.msg := 'incomplete literal/length tree'; - r := Z_DATA_ERROR; - end - else - if (r <> Z_MEM_ERROR) then - begin - z.msg := 'empty distance tree with lengths'; - r := Z_DATA_ERROR; - end; - ZFREE(z, v); - inflate_trees_dynamic := r; - exit; -{$endif} - end; - - { done } - ZFREE(z, v); - inflate_trees_dynamic := Z_OK; -end; - -{$UNDEF BUILDFIXED} - -{ build fixed tables only once--keep them here } -{$IFNDEF BUILDFIXED} -{ locals } -var - fixed_built : Boolean = false; -const - FIXEDH = 544; { number of hufts used by fixed tables } -var - fixed_mem : array[0..FIXEDH-1] of inflate_huft; - fixed_bl : uInt; - fixed_bd : uInt; - fixed_tl : pInflate_huft; - fixed_td : pInflate_huft; - -{$ELSE} - -{ inffixed.h -- table for decoding fixed codes } - -{local} -const - fixed_bl = uInt(9); -{local} -const - fixed_bd = uInt(5); -{local} -const - fixed_tl : array [0..288-1] of inflate_huft = ( - Exop, { number of extra bits or operation } - bits : Byte; { number of bits in this code or subcode } - {pad : uInt;} { pad structure to a power of 2 (4 bytes for } - { 16-bit, 8 bytes for 32-bit int's) } - base : uInt; { literal, length base, or distance base } - { or table offset } - - ((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115), ((82,7),31), - ((0,8),112), ((0,8),48), ((0,9),192), ((80,7),10), ((0,8),96), - ((0,8),32), ((0,9),160), ((0,8),0), ((0,8),128), ((0,8),64), - ((0,9),224), ((80,7),6), ((0,8),88), ((0,8),24), ((0,9),144), - ((83,7),59), ((0,8),120), ((0,8),56), ((0,9),208), ((81,7),17), - ((0,8),104), ((0,8),40), ((0,9),176), ((0,8),8), ((0,8),136), - ((0,8),72), ((0,9),240), ((80,7),4), ((0,8),84), ((0,8),20), - ((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52), ((0,9),200), - ((81,7),13), ((0,8),100), ((0,8),36), ((0,9),168), ((0,8),4), - ((0,8),132), ((0,8),68), ((0,9),232), ((80,7),8), ((0,8),92), - ((0,8),28), ((0,9),152), ((84,7),83), ((0,8),124), ((0,8),60), - ((0,9),216), ((82,7),23), ((0,8),108), ((0,8),44), ((0,9),184), - ((0,8),12), ((0,8),140), ((0,8),76), ((0,9),248), ((80,7),3), - ((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35), ((0,8),114), - ((0,8),50), ((0,9),196), ((81,7),11), ((0,8),98), ((0,8),34), - ((0,9),164), ((0,8),2), ((0,8),130), ((0,8),66), ((0,9),228), - ((80,7),7), ((0,8),90), ((0,8),26), ((0,9),148), ((84,7),67), - ((0,8),122), ((0,8),58), ((0,9),212), ((82,7),19), ((0,8),106), - ((0,8),42), ((0,9),180), ((0,8),10), ((0,8),138), ((0,8),74), - ((0,9),244), ((80,7),5), ((0,8),86), ((0,8),22), ((192,8),0), - ((83,7),51), ((0,8),118), ((0,8),54), ((0,9),204), ((81,7),15), - ((0,8),102), ((0,8),38), ((0,9),172), ((0,8),6), ((0,8),134), - ((0,8),70), ((0,9),236), ((80,7),9), ((0,8),94), ((0,8),30), - ((0,9),156), ((84,7),99), ((0,8),126), ((0,8),62), ((0,9),220), - ((82,7),27), ((0,8),110), ((0,8),46), ((0,9),188), ((0,8),14), - ((0,8),142), ((0,8),78), ((0,9),252), ((96,7),256), ((0,8),81), - ((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113), ((0,8),49), - ((0,9),194), ((80,7),10), ((0,8),97), ((0,8),33), ((0,9),162), - ((0,8),1), ((0,8),129), ((0,8),65), ((0,9),226), ((80,7),6), - ((0,8),89), ((0,8),25), ((0,9),146), ((83,7),59), ((0,8),121), - ((0,8),57), ((0,9),210), ((81,7),17), ((0,8),105), ((0,8),41), - ((0,9),178), ((0,8),9), ((0,8),137), ((0,8),73), ((0,9),242), - ((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258), ((83,7),43), - ((0,8),117), ((0,8),53), ((0,9),202), ((81,7),13), ((0,8),101), - ((0,8),37), ((0,9),170), ((0,8),5), ((0,8),133), ((0,8),69), - ((0,9),234), ((80,7),8), ((0,8),93), ((0,8),29), ((0,9),154), - ((84,7),83), ((0,8),125), ((0,8),61), ((0,9),218), ((82,7),23), - ((0,8),109), ((0,8),45), ((0,9),186), ((0,8),13), ((0,8),141), - ((0,8),77), ((0,9),250), ((80,7),3), ((0,8),83), ((0,8),19), - ((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51), ((0,9),198), - ((81,7),11), ((0,8),99), ((0,8),35), ((0,9),166), ((0,8),3), - ((0,8),131), ((0,8),67), ((0,9),230), ((80,7),7), ((0,8),91), - ((0,8),27), ((0,9),150), ((84,7),67), ((0,8),123), ((0,8),59), - ((0,9),214), ((82,7),19), ((0,8),107), ((0,8),43), ((0,9),182), - ((0,8),11), ((0,8),139), ((0,8),75), ((0,9),246), ((80,7),5), - ((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51), ((0,8),119), - ((0,8),55), ((0,9),206), ((81,7),15), ((0,8),103), ((0,8),39), - ((0,9),174), ((0,8),7), ((0,8),135), ((0,8),71), ((0,9),238), - ((80,7),9), ((0,8),95), ((0,8),31), ((0,9),158), ((84,7),99), - ((0,8),127), ((0,8),63), ((0,9),222), ((82,7),27), ((0,8),111), - ((0,8),47), ((0,9),190), ((0,8),15), ((0,8),143), ((0,8),79), - ((0,9),254), ((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115), - ((82,7),31), ((0,8),112), ((0,8),48), ((0,9),193), ((80,7),10), - ((0,8),96), ((0,8),32), ((0,9),161), ((0,8),0), ((0,8),128), - ((0,8),64), ((0,9),225), ((80,7),6), ((0,8),88), ((0,8),24), - ((0,9),145), ((83,7),59), ((0,8),120), ((0,8),56), ((0,9),209), - ((81,7),17), ((0,8),104), ((0,8),40), ((0,9),177), ((0,8),8), - ((0,8),136), ((0,8),72), ((0,9),241), ((80,7),4), ((0,8),84), - ((0,8),20), ((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52), - ((0,9),201), ((81,7),13), ((0,8),100), ((0,8),36), ((0,9),169), - ((0,8),4), ((0,8),132), ((0,8),68), ((0,9),233), ((80,7),8), - ((0,8),92), ((0,8),28), ((0,9),153), ((84,7),83), ((0,8),124), - ((0,8),60), ((0,9),217), ((82,7),23), ((0,8),108), ((0,8),44), - ((0,9),185), ((0,8),12), ((0,8),140), ((0,8),76), ((0,9),249), - ((80,7),3), ((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35), - ((0,8),114), ((0,8),50), ((0,9),197), ((81,7),11), ((0,8),98), - ((0,8),34), ((0,9),165), ((0,8),2), ((0,8),130), ((0,8),66), - ((0,9),229), ((80,7),7), ((0,8),90), ((0,8),26), ((0,9),149), - ((84,7),67), ((0,8),122), ((0,8),58), ((0,9),213), ((82,7),19), - ((0,8),106), ((0,8),42), ((0,9),181), ((0,8),10), ((0,8),138), - ((0,8),74), ((0,9),245), ((80,7),5), ((0,8),86), ((0,8),22), - ((192,8),0), ((83,7),51), ((0,8),118), ((0,8),54), ((0,9),205), - ((81,7),15), ((0,8),102), ((0,8),38), ((0,9),173), ((0,8),6), - ((0,8),134), ((0,8),70), ((0,9),237), ((80,7),9), ((0,8),94), - ((0,8),30), ((0,9),157), ((84,7),99), ((0,8),126), ((0,8),62), - ((0,9),221), ((82,7),27), ((0,8),110), ((0,8),46), ((0,9),189), - ((0,8),14), ((0,8),142), ((0,8),78), ((0,9),253), ((96,7),256), - ((0,8),81), ((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113), - ((0,8),49), ((0,9),195), ((80,7),10), ((0,8),97), ((0,8),33), - ((0,9),163), ((0,8),1), ((0,8),129), ((0,8),65), ((0,9),227), - ((80,7),6), ((0,8),89), ((0,8),25), ((0,9),147), ((83,7),59), - ((0,8),121), ((0,8),57), ((0,9),211), ((81,7),17), ((0,8),105), - ((0,8),41), ((0,9),179), ((0,8),9), ((0,8),137), ((0,8),73), - ((0,9),243), ((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258), - ((83,7),43), ((0,8),117), ((0,8),53), ((0,9),203), ((81,7),13), - ((0,8),101), ((0,8),37), ((0,9),171), ((0,8),5), ((0,8),133), - ((0,8),69), ((0,9),235), ((80,7),8), ((0,8),93), ((0,8),29), - ((0,9),155), ((84,7),83), ((0,8),125), ((0,8),61), ((0,9),219), - ((82,7),23), ((0,8),109), ((0,8),45), ((0,9),187), ((0,8),13), - ((0,8),141), ((0,8),77), ((0,9),251), ((80,7),3), ((0,8),83), - ((0,8),19), ((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51), - ((0,9),199), ((81,7),11), ((0,8),99), ((0,8),35), ((0,9),167), - ((0,8),3), ((0,8),131), ((0,8),67), ((0,9),231), ((80,7),7), - ((0,8),91), ((0,8),27), ((0,9),151), ((84,7),67), ((0,8),123), - ((0,8),59), ((0,9),215), ((82,7),19), ((0,8),107), ((0,8),43), - ((0,9),183), ((0,8),11), ((0,8),139), ((0,8),75), ((0,9),247), - ((80,7),5), ((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51), - ((0,8),119), ((0,8),55), ((0,9),207), ((81,7),15), ((0,8),103), - ((0,8),39), ((0,9),175), ((0,8),7), ((0,8),135), ((0,8),71), - ((0,9),239), ((80,7),9), ((0,8),95), ((0,8),31), ((0,9),159), - ((84,7),99), ((0,8),127), ((0,8),63), ((0,9),223), ((82,7),27), - ((0,8),111), ((0,8),47), ((0,9),191), ((0,8),15), ((0,8),143), - ((0,8),79), ((0,9),255) - ); - -{local} -const - fixed_td : array[0..32-1] of inflate_huft = ( -(Exop:80;bits:5;base:1), (Exop:87;bits:5;base:257), (Exop:83;bits:5;base:17), -(Exop:91;bits:5;base:4097), (Exop:81;bits:5;base), (Exop:89;bits:5;base:1025), -(Exop:85;bits:5;base:65), (Exop:93;bits:5;base:16385), (Exop:80;bits:5;base:3), -(Exop:88;bits:5;base:513), (Exop:84;bits:5;base:33), (Exop:92;bits:5;base:8193), -(Exop:82;bits:5;base:9), (Exop:90;bits:5;base:2049), (Exop:86;bits:5;base:129), -(Exop:192;bits:5;base:24577), (Exop:80;bits:5;base:2), (Exop:87;bits:5;base:385), -(Exop:83;bits:5;base:25), (Exop:91;bits:5;base:6145), (Exop:81;bits:5;base:7), -(Exop:89;bits:5;base:1537), (Exop:85;bits:5;base:97), (Exop:93;bits:5;base:24577), -(Exop:80;bits:5;base:4), (Exop:88;bits:5;base:769), (Exop:84;bits:5;base:49), -(Exop:92;bits:5;base:12289), (Exop:82;bits:5;base:13), (Exop:90;bits:5;base:3073), -(Exop:86;bits:5;base:193), (Exop:192;bits:5;base:24577) - ); -{$ENDIF} - -function inflate_trees_fixed( -var bl : uInt; { literal desired/actual bit depth } -var bd : uInt; { distance desired/actual bit depth } -var tl : pInflate_huft; { literal/length tree result } -var td : pInflate_huft; { distance tree result } -var z : z_stream { for memory allocation } - ) : int; -type - pFixed_table = ^fixed_table; - fixed_table = array[0..288-1] of uIntf; -var - k : int; { temporary variable } - c : pFixed_table; { length list for huft_build } - v : PuIntArray; { work area for huft_build } -var - f : uInt; { number of hufts used in fixed_mem } -begin - { build fixed tables if not already (multiple overlapped executions ok) } - if not fixed_built then - begin - f := 0; - - { allocate memory } - c := pFixed_table( ZALLOC(z, 288, sizeof(uInt)) ); - if (c = Z_NULL) then - begin - inflate_trees_fixed := Z_MEM_ERROR; - exit; - end; - v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) ); - if (v = Z_NULL) then - begin - ZFREE(z, c); - inflate_trees_fixed := Z_MEM_ERROR; - exit; - end; - - { literal table } - for k := 0 to Pred(144) do - c^[k] := 8; - for k := 144 to Pred(256) do - c^[k] := 9; - for k := 256 to Pred(280) do - c^[k] := 7; - for k := 280 to Pred(288) do - c^[k] := 8; - fixed_bl := 9; - huft_build(c^, 288, 257, cplens, cplext, @fixed_tl, fixed_bl, - fixed_mem, f, v^); - - { distance table } - for k := 0 to Pred(30) do - c^[k] := 5; - fixed_bd := 5; - huft_build(c^, 30, 0, cpdist, cpdext, @fixed_td, fixed_bd, - fixed_mem, f, v^); - - { done } - ZFREE(z, v); - ZFREE(z, c); - fixed_built := True; - end; - bl := fixed_bl; - bd := fixed_bd; - tl := fixed_tl; - td := fixed_td; - inflate_trees_fixed := Z_OK; -end; { inflate_trees_fixed } - - +Unit iminftrees; + +{ inftrees.h -- header to use inftrees.c + inftrees.c -- generate Huffman trees for efficient decoding + Copyright (C) 1995-1998 Mark Adler + + WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +Interface + +{$I imzconf.inc} + +uses + imzutil, impaszlib; + + +{ Maximum size of dynamic tree. The maximum found in a long but non- + exhaustive search was 1004 huft structures (850 for length/literals + and 154 for distances, the latter actually the result of an + exhaustive search). The actual maximum is not known, but the + value below is more than safe. } +const + MANY = 1440; + + +{$ifdef DEBUG} +var + inflate_hufts : uInt; +{$endif} + +function inflate_trees_bits( + var c : array of uIntf; { 19 code lengths } + var bb : uIntf; { bits tree desired/actual depth } + var tb : pinflate_huft; { bits tree result } + var hp : array of Inflate_huft; { space for trees } + var z : z_stream { for messages } + ) : int; + +function inflate_trees_dynamic( + nl : uInt; { number of literal/length codes } + nd : uInt; { number of distance codes } + var c : Array of uIntf; { that many (total) code lengths } + var bl : uIntf; { literal desired/actual bit depth } + var bd : uIntf; { distance desired/actual bit depth } +var tl : pInflate_huft; { literal/length tree result } +var td : pInflate_huft; { distance tree result } +var hp : array of Inflate_huft; { space for trees } +var z : z_stream { for messages } + ) : int; + +function inflate_trees_fixed ( + var bl : uInt; { literal desired/actual bit depth } + var bd : uInt; { distance desired/actual bit depth } + var tl : pInflate_huft; { literal/length tree result } + var td : pInflate_huft; { distance tree result } + var z : z_stream { for memory allocation } + ) : int; + + +implementation + +const + inflate_copyright = 'inflate 1.1.2 Copyright 1995-1998 Mark Adler'; + +{ + If you use the zlib library in a product, an acknowledgment is welcome + in the documentation of your product. If for some reason you cannot + include such an acknowledgment, I would appreciate that you keep this + copyright string in the executable of your product. +} + + +const +{ Tables for deflate from PKZIP's appnote.txt. } + cplens : Array [0..30] Of uInt { Copy lengths for literal codes 257..285 } + = (3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, + 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0); + { actually lengths - 2; also see note #13 above about 258 } + + invalid_code = 112; + + cplext : Array [0..30] Of uInt { Extra bits for literal codes 257..285 } + = (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, + 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, invalid_code, invalid_code); + + cpdist : Array [0..29] Of uInt { Copy offsets for distance codes 0..29 } + = (1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, + 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, + 8193, 12289, 16385, 24577); + + cpdext : Array [0..29] Of uInt { Extra bits for distance codes } + = (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, + 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, + 12, 12, 13, 13); + +{ Huffman code decoding is performed using a multi-level table lookup. + The fastest way to decode is to simply build a lookup table whose + size is determined by the longest code. However, the time it takes + to build this table can also be a factor if the data being decoded + is not very long. The most common codes are necessarily the + shortest codes, so those codes dominate the decoding time, and hence + the speed. The idea is you can have a shorter table that decodes the + shorter, more probable codes, and then point to subsidiary tables for + the longer codes. The time it costs to decode the longer codes is + then traded against the time it takes to make longer tables. + + This results of this trade are in the variables lbits and dbits + below. lbits is the number of bits the first level table for literal/ + length codes can decode in one step, and dbits is the same thing for + the distance codes. Subsequent tables are also less than or equal to + those sizes. These values may be adjusted either when all of the + codes are shorter than that, in which case the longest code length in + bits is used, or when the shortest code is *longer* than the requested + table size, in which case the length of the shortest code in bits is + used. + + There are two different values for the two tables, since they code a + different number of possibilities each. The literal/length table + codes 286 possible values, or in a flat code, a little over eight + bits. The distance table codes 30 possible values, or a little less + than five bits, flat. The optimum values for speed end up being + about one bit more than those, so lbits is 8+1 and dbits is 5+1. + The optimum values may differ though from machine to machine, and + possibly even between compilers. Your mileage may vary. } + + +{ If BMAX needs to be larger than 16, then h and x[] should be uLong. } +const + BMAX = 15; { maximum bit length of any code } + +{$DEFINE USE_PTR} + +function huft_build( +var b : array of uIntf; { code lengths in bits (all assumed <= BMAX) } + n : uInt; { number of codes (assumed <= N_MAX) } + s : uInt; { number of simple-valued codes (0..s-1) } +const d : array of uIntf; { list of base values for non-simple codes } +{ array of word } +const e : array of uIntf; { list of extra bits for non-simple codes } +{ array of byte } + t : ppInflate_huft; { result: starting table } +var m : uIntf; { maximum lookup bits, returns actual } +var hp : array of inflate_huft; { space for trees } +var hn : uInt; { hufts used in space } +var v : array of uIntf { working area: values in order of bit length } + ) : int; +{ Given a list of code lengths and a maximum table size, make a set of + tables to decode that set of codes. Return Z_OK on success, Z_BUF_ERROR + if the given code set is incomplete (the tables are still built in this + case), Z_DATA_ERROR if the input is invalid (an over-subscribed set of + lengths), or Z_MEM_ERROR if not enough memory. } +Var + a : uInt; { counter for codes of length k } + c : Array [0..BMAX] Of uInt; { bit length count table } + f : uInt; { i repeats in table every f entries } + g : int; { maximum code length } + h : int; { table level } + i : uInt; {register} { counter, current code } + j : uInt; {register} { counter } + k : Int; {register} { number of bits in current code } + l : int; { bits per table (returned in m) } + mask : uInt; { (1 shl w) - 1, to avoid cc -O bug on HP } + p : ^uIntf; {register} { pointer into c[], b[], or v[] } + q : pInflate_huft; { points to current table } + r : inflate_huft; { table entry for structure assignment } + u : Array [0..BMAX-1] Of pInflate_huft; { table stack } + w : int; {register} { bits before this table = (l*h) } + x : Array [0..BMAX] Of uInt; { bit offsets, then code stack } + {$IFDEF USE_PTR} + xp : puIntf; { pointer into x } + {$ELSE} + xp : uInt; + {$ENDIF} + y : int; { number of dummy codes added } + z : uInt; { number of entries in current table } +Begin + { Generate counts for each bit length } + FillChar(c,SizeOf(c),0) ; { clear c[] } + + for i := 0 to n-1 do + Inc (c[b[i]]); { assume all entries <= BMAX } + + If (c[0] = n) Then { null input--all zero length codes } + Begin + t^ := pInflate_huft(NIL); + m := 0 ; + huft_build := Z_OK ; + Exit; + End ; + + { Find minimum and maximum length, bound [m] by those } + l := m; + for j:=1 To BMAX do + if (c[j] <> 0) then + break; + k := j ; { minimum code length } + if (uInt(l) < j) then + l := j; + for i := BMAX downto 1 do + if (c[i] <> 0) then + break ; + g := i ; { maximum code length } + if (uInt(l) > i) then + l := i; + m := l; + + { Adjust last length count to fill out codes, if needed } + y := 1 shl j ; + while (j < i) do + begin + Dec(y, c[j]) ; + if (y < 0) then + begin + huft_build := Z_DATA_ERROR; { bad input: more codes than bits } + exit; + end ; + Inc(j) ; + y := y shl 1 + end; + Dec (y, c[i]) ; + if (y < 0) then + begin + huft_build := Z_DATA_ERROR; { bad input: more codes than bits } + exit; + end; + Inc(c[i], y); + + { Generate starting offsets into the value table FOR each length } + {$IFDEF USE_PTR} + x[1] := 0; + j := 0; + + p := @c[1]; + xp := @x[2]; + + dec(i); { note that i = g from above } + WHILE (i > 0) DO + BEGIN + inc(j, p^); + xp^ := j; + inc(p); + inc(xp); + dec(i); + END; + {$ELSE} + x[1] := 0; + j := 0 ; + for i := 1 to g do + begin + x[i] := j; + Inc(j, c[i]); + end; + {$ENDIF} + + { Make a table of values in order of bit lengths } + for i := 0 to n-1 do + begin + j := b[i]; + if (j <> 0) then + begin + v[ x[j] ] := i; + Inc(x[j]); + end; + end; + n := x[g]; { set n to length of v } + + { Generate the Huffman codes and for each, make the table entries } + i := 0 ; + x[0] := 0 ; { first Huffman code is zero } + p := Addr(v) ; { grab values in bit order } + h := -1 ; { no tables yet--level -1 } + w := -l ; { bits decoded = (l*h) } + + u[0] := pInflate_huft(NIL); { just to keep compilers happy } + q := pInflate_huft(NIL); { ditto } + z := 0 ; { ditto } + + { go through the bit lengths (k already is bits in shortest code) } + while (k <= g) Do + begin + a := c[k] ; + while (a<>0) Do + begin + Dec (a) ; + { here i is the Huffman code of length k bits for value p^ } + { make tables up to required level } + while (k > w + l) do + begin + + Inc (h) ; + Inc (w, l); { add bits already decoded } + { previous table always l bits } + { compute minimum size table less than or equal to l bits } + + { table size upper limit } + z := g - w; + If (z > uInt(l)) Then + z := l; + + { try a k-w bit table } + j := k - w; + f := 1 shl j; + if (f > a+1) Then { too few codes for k-w bit table } + begin + Dec(f, a+1); { deduct codes from patterns left } + {$IFDEF USE_PTR} + xp := Addr(c[k]); + + if (j < z) then + begin + Inc(j); + while (j < z) do + begin { try smaller tables up to z bits } + f := f shl 1; + Inc (xp) ; + If (f <= xp^) Then + break; { enough codes to use up j bits } + Dec(f, xp^); { else deduct codes from patterns } + Inc(j); + end; + end; + {$ELSE} + xp := k; + + if (j < z) then + begin + Inc (j) ; + While (j < z) Do + begin { try smaller tables up to z bits } + f := f * 2; + Inc (xp) ; + if (f <= c[xp]) then + Break ; { enough codes to use up j bits } + Dec (f, c[xp]) ; { else deduct codes from patterns } + Inc (j); + end; + end; + {$ENDIF} + end; + + z := 1 shl j; { table entries for j-bit table } + + { allocate new table } + if (hn + z > MANY) then { (note: doesn't matter for fixed) } + begin + huft_build := Z_MEM_ERROR; { not enough memory } + exit; + end; + + q := @hp[hn]; + u[h] := q; + Inc(hn, z); + + { connect to last table, if there is one } + if (h <> 0) then + begin + x[h] := i; { save pattern for backing up } + r.bits := Byte(l); { bits to dump before this table } + r.exop := Byte(j); { bits in this table } + j := i shr (w - l); + {r.base := uInt( q - u[h-1] -j);} { offset to this table } + r.base := (ptr2int(q) - ptr2int(u[h-1]) ) div sizeof(q^) - j; + huft_Ptr(u[h-1])^[j] := r; { connect to last table } + end + else + t^ := q; { first table is returned result } + end; + + { set up table entry in r } + r.bits := Byte(k - w); + + { C-code: if (p >= v + n) - see ZUTIL.PAS for comments } + + if ptr2int(p)>=ptr2int(@(v[n])) then { also works under DPMI ?? } + r.exop := 128 + 64 { out of values--invalid code } + else + if (p^ < s) then + begin + if (p^ < 256) then { 256 is end-of-block code } + r.exop := 0 + Else + r.exop := 32 + 64; { EOB_code; } + r.base := p^; { simple code is just the value } + Inc(p); + end + Else + begin + r.exop := Byte(e[p^-s] + 16 + 64); { non-simple--look up in lists } + r.base := d[p^-s]; + Inc (p); + end ; + + { fill code-like entries with r } + f := 1 shl (k - w); + j := i shr w; + while (j < z) do + begin + huft_Ptr(q)^[j] := r; + Inc(j, f); + end; + + { backwards increment the k-bit code i } + j := 1 shl (k-1) ; + while (i and j) <> 0 do + begin + i := i xor j; { bitwise exclusive or } + j := j shr 1 + end ; + i := i xor j; + + { backup over finished tables } + mask := (1 shl w) - 1; { needed on HP, cc -O bug } + while ((i and mask) <> x[h]) do + begin + Dec(h); { don't need to update q } + Dec(w, l); + mask := (1 shl w) - 1; + end; + + end; + + Inc(k); + end; + + { Return Z_BUF_ERROR if we were given an incomplete table } + if (y <> 0) And (g <> 1) then + huft_build := Z_BUF_ERROR + else + huft_build := Z_OK; +end; { huft_build} + + +function inflate_trees_bits( + var c : array of uIntf; { 19 code lengths } + var bb : uIntf; { bits tree desired/actual depth } + var tb : pinflate_huft; { bits tree result } + var hp : array of Inflate_huft; { space for trees } + var z : z_stream { for messages } + ) : int; +var + r : int; + hn : uInt; { hufts used in space } + v : PuIntArray; { work area for huft_build } +begin + hn := 0; + v := PuIntArray( ZALLOC(z, 19, sizeof(uInt)) ); + if (v = Z_NULL) then + begin + inflate_trees_bits := Z_MEM_ERROR; + exit; + end; + + r := huft_build(c, 19, 19, cplens, cplext, + {puIntf(Z_NULL), puIntf(Z_NULL),} + @tb, bb, hp, hn, v^); + if (r = Z_DATA_ERROR) then + z.msg := 'oversubscribed dynamic bit lengths tree' + else + if (r = Z_BUF_ERROR) or (bb = 0) then + begin + z.msg := 'incomplete dynamic bit lengths tree'; + r := Z_DATA_ERROR; + end; + ZFREE(z, v); + inflate_trees_bits := r; +end; + + +function inflate_trees_dynamic( + nl : uInt; { number of literal/length codes } + nd : uInt; { number of distance codes } + var c : Array of uIntf; { that many (total) code lengths } + var bl : uIntf; { literal desired/actual bit depth } + var bd : uIntf; { distance desired/actual bit depth } +var tl : pInflate_huft; { literal/length tree result } +var td : pInflate_huft; { distance tree result } +var hp : array of Inflate_huft; { space for trees } +var z : z_stream { for messages } + ) : int; +var + r : int; + hn : uInt; { hufts used in space } + v : PuIntArray; { work area for huft_build } +begin + hn := 0; + { allocate work area } + v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) ); + if (v = Z_NULL) then + begin + inflate_trees_dynamic := Z_MEM_ERROR; + exit; + end; + + { build literal/length tree } + r := huft_build(c, nl, 257, cplens, cplext, @tl, bl, hp, hn, v^); + if (r <> Z_OK) or (bl = 0) then + begin + if (r = Z_DATA_ERROR) then + z.msg := 'oversubscribed literal/length tree' + else + if (r <> Z_MEM_ERROR) then + begin + z.msg := 'incomplete literal/length tree'; + r := Z_DATA_ERROR; + end; + + ZFREE(z, v); + inflate_trees_dynamic := r; + exit; + end; + + { build distance tree } + r := huft_build(puIntArray(@c[nl])^, nd, 0, + cpdist, cpdext, @td, bd, hp, hn, v^); + if (r <> Z_OK) or ((bd = 0) and (nl > 257)) then + begin + if (r = Z_DATA_ERROR) then + z.msg := 'oversubscribed literal/length tree' + else + if (r = Z_BUF_ERROR) then + begin +{$ifdef PKZIP_BUG_WORKAROUND} + r := Z_OK; + end; +{$else} + z.msg := 'incomplete literal/length tree'; + r := Z_DATA_ERROR; + end + else + if (r <> Z_MEM_ERROR) then + begin + z.msg := 'empty distance tree with lengths'; + r := Z_DATA_ERROR; + end; + ZFREE(z, v); + inflate_trees_dynamic := r; + exit; +{$endif} + end; + + { done } + ZFREE(z, v); + inflate_trees_dynamic := Z_OK; +end; + +{$UNDEF BUILDFIXED} + +{ build fixed tables only once--keep them here } +{$IFNDEF BUILDFIXED} +{ locals } +var + fixed_built : Boolean = false; +const + FIXEDH = 544; { number of hufts used by fixed tables } +var + fixed_mem : array[0..FIXEDH-1] of inflate_huft; + fixed_bl : uInt; + fixed_bd : uInt; + fixed_tl : pInflate_huft; + fixed_td : pInflate_huft; + +{$ELSE} + +{ inffixed.h -- table for decoding fixed codes } + +{local} +const + fixed_bl = uInt(9); +{local} +const + fixed_bd = uInt(5); +{local} +const + fixed_tl : array [0..288-1] of inflate_huft = ( + Exop, { number of extra bits or operation } + bits : Byte; { number of bits in this code or subcode } + {pad : uInt;} { pad structure to a power of 2 (4 bytes for } + { 16-bit, 8 bytes for 32-bit int's) } + base : uInt; { literal, length base, or distance base } + { or table offset } + + ((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115), ((82,7),31), + ((0,8),112), ((0,8),48), ((0,9),192), ((80,7),10), ((0,8),96), + ((0,8),32), ((0,9),160), ((0,8),0), ((0,8),128), ((0,8),64), + ((0,9),224), ((80,7),6), ((0,8),88), ((0,8),24), ((0,9),144), + ((83,7),59), ((0,8),120), ((0,8),56), ((0,9),208), ((81,7),17), + ((0,8),104), ((0,8),40), ((0,9),176), ((0,8),8), ((0,8),136), + ((0,8),72), ((0,9),240), ((80,7),4), ((0,8),84), ((0,8),20), + ((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52), ((0,9),200), + ((81,7),13), ((0,8),100), ((0,8),36), ((0,9),168), ((0,8),4), + ((0,8),132), ((0,8),68), ((0,9),232), ((80,7),8), ((0,8),92), + ((0,8),28), ((0,9),152), ((84,7),83), ((0,8),124), ((0,8),60), + ((0,9),216), ((82,7),23), ((0,8),108), ((0,8),44), ((0,9),184), + ((0,8),12), ((0,8),140), ((0,8),76), ((0,9),248), ((80,7),3), + ((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35), ((0,8),114), + ((0,8),50), ((0,9),196), ((81,7),11), ((0,8),98), ((0,8),34), + ((0,9),164), ((0,8),2), ((0,8),130), ((0,8),66), ((0,9),228), + ((80,7),7), ((0,8),90), ((0,8),26), ((0,9),148), ((84,7),67), + ((0,8),122), ((0,8),58), ((0,9),212), ((82,7),19), ((0,8),106), + ((0,8),42), ((0,9),180), ((0,8),10), ((0,8),138), ((0,8),74), + ((0,9),244), ((80,7),5), ((0,8),86), ((0,8),22), ((192,8),0), + ((83,7),51), ((0,8),118), ((0,8),54), ((0,9),204), ((81,7),15), + ((0,8),102), ((0,8),38), ((0,9),172), ((0,8),6), ((0,8),134), + ((0,8),70), ((0,9),236), ((80,7),9), ((0,8),94), ((0,8),30), + ((0,9),156), ((84,7),99), ((0,8),126), ((0,8),62), ((0,9),220), + ((82,7),27), ((0,8),110), ((0,8),46), ((0,9),188), ((0,8),14), + ((0,8),142), ((0,8),78), ((0,9),252), ((96,7),256), ((0,8),81), + ((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113), ((0,8),49), + ((0,9),194), ((80,7),10), ((0,8),97), ((0,8),33), ((0,9),162), + ((0,8),1), ((0,8),129), ((0,8),65), ((0,9),226), ((80,7),6), + ((0,8),89), ((0,8),25), ((0,9),146), ((83,7),59), ((0,8),121), + ((0,8),57), ((0,9),210), ((81,7),17), ((0,8),105), ((0,8),41), + ((0,9),178), ((0,8),9), ((0,8),137), ((0,8),73), ((0,9),242), + ((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258), ((83,7),43), + ((0,8),117), ((0,8),53), ((0,9),202), ((81,7),13), ((0,8),101), + ((0,8),37), ((0,9),170), ((0,8),5), ((0,8),133), ((0,8),69), + ((0,9),234), ((80,7),8), ((0,8),93), ((0,8),29), ((0,9),154), + ((84,7),83), ((0,8),125), ((0,8),61), ((0,9),218), ((82,7),23), + ((0,8),109), ((0,8),45), ((0,9),186), ((0,8),13), ((0,8),141), + ((0,8),77), ((0,9),250), ((80,7),3), ((0,8),83), ((0,8),19), + ((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51), ((0,9),198), + ((81,7),11), ((0,8),99), ((0,8),35), ((0,9),166), ((0,8),3), + ((0,8),131), ((0,8),67), ((0,9),230), ((80,7),7), ((0,8),91), + ((0,8),27), ((0,9),150), ((84,7),67), ((0,8),123), ((0,8),59), + ((0,9),214), ((82,7),19), ((0,8),107), ((0,8),43), ((0,9),182), + ((0,8),11), ((0,8),139), ((0,8),75), ((0,9),246), ((80,7),5), + ((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51), ((0,8),119), + ((0,8),55), ((0,9),206), ((81,7),15), ((0,8),103), ((0,8),39), + ((0,9),174), ((0,8),7), ((0,8),135), ((0,8),71), ((0,9),238), + ((80,7),9), ((0,8),95), ((0,8),31), ((0,9),158), ((84,7),99), + ((0,8),127), ((0,8),63), ((0,9),222), ((82,7),27), ((0,8),111), + ((0,8),47), ((0,9),190), ((0,8),15), ((0,8),143), ((0,8),79), + ((0,9),254), ((96,7),256), ((0,8),80), ((0,8),16), ((84,8),115), + ((82,7),31), ((0,8),112), ((0,8),48), ((0,9),193), ((80,7),10), + ((0,8),96), ((0,8),32), ((0,9),161), ((0,8),0), ((0,8),128), + ((0,8),64), ((0,9),225), ((80,7),6), ((0,8),88), ((0,8),24), + ((0,9),145), ((83,7),59), ((0,8),120), ((0,8),56), ((0,9),209), + ((81,7),17), ((0,8),104), ((0,8),40), ((0,9),177), ((0,8),8), + ((0,8),136), ((0,8),72), ((0,9),241), ((80,7),4), ((0,8),84), + ((0,8),20), ((85,8),227), ((83,7),43), ((0,8),116), ((0,8),52), + ((0,9),201), ((81,7),13), ((0,8),100), ((0,8),36), ((0,9),169), + ((0,8),4), ((0,8),132), ((0,8),68), ((0,9),233), ((80,7),8), + ((0,8),92), ((0,8),28), ((0,9),153), ((84,7),83), ((0,8),124), + ((0,8),60), ((0,9),217), ((82,7),23), ((0,8),108), ((0,8),44), + ((0,9),185), ((0,8),12), ((0,8),140), ((0,8),76), ((0,9),249), + ((80,7),3), ((0,8),82), ((0,8),18), ((85,8),163), ((83,7),35), + ((0,8),114), ((0,8),50), ((0,9),197), ((81,7),11), ((0,8),98), + ((0,8),34), ((0,9),165), ((0,8),2), ((0,8),130), ((0,8),66), + ((0,9),229), ((80,7),7), ((0,8),90), ((0,8),26), ((0,9),149), + ((84,7),67), ((0,8),122), ((0,8),58), ((0,9),213), ((82,7),19), + ((0,8),106), ((0,8),42), ((0,9),181), ((0,8),10), ((0,8),138), + ((0,8),74), ((0,9),245), ((80,7),5), ((0,8),86), ((0,8),22), + ((192,8),0), ((83,7),51), ((0,8),118), ((0,8),54), ((0,9),205), + ((81,7),15), ((0,8),102), ((0,8),38), ((0,9),173), ((0,8),6), + ((0,8),134), ((0,8),70), ((0,9),237), ((80,7),9), ((0,8),94), + ((0,8),30), ((0,9),157), ((84,7),99), ((0,8),126), ((0,8),62), + ((0,9),221), ((82,7),27), ((0,8),110), ((0,8),46), ((0,9),189), + ((0,8),14), ((0,8),142), ((0,8),78), ((0,9),253), ((96,7),256), + ((0,8),81), ((0,8),17), ((85,8),131), ((82,7),31), ((0,8),113), + ((0,8),49), ((0,9),195), ((80,7),10), ((0,8),97), ((0,8),33), + ((0,9),163), ((0,8),1), ((0,8),129), ((0,8),65), ((0,9),227), + ((80,7),6), ((0,8),89), ((0,8),25), ((0,9),147), ((83,7),59), + ((0,8),121), ((0,8),57), ((0,9),211), ((81,7),17), ((0,8),105), + ((0,8),41), ((0,9),179), ((0,8),9), ((0,8),137), ((0,8),73), + ((0,9),243), ((80,7),4), ((0,8),85), ((0,8),21), ((80,8),258), + ((83,7),43), ((0,8),117), ((0,8),53), ((0,9),203), ((81,7),13), + ((0,8),101), ((0,8),37), ((0,9),171), ((0,8),5), ((0,8),133), + ((0,8),69), ((0,9),235), ((80,7),8), ((0,8),93), ((0,8),29), + ((0,9),155), ((84,7),83), ((0,8),125), ((0,8),61), ((0,9),219), + ((82,7),23), ((0,8),109), ((0,8),45), ((0,9),187), ((0,8),13), + ((0,8),141), ((0,8),77), ((0,9),251), ((80,7),3), ((0,8),83), + ((0,8),19), ((85,8),195), ((83,7),35), ((0,8),115), ((0,8),51), + ((0,9),199), ((81,7),11), ((0,8),99), ((0,8),35), ((0,9),167), + ((0,8),3), ((0,8),131), ((0,8),67), ((0,9),231), ((80,7),7), + ((0,8),91), ((0,8),27), ((0,9),151), ((84,7),67), ((0,8),123), + ((0,8),59), ((0,9),215), ((82,7),19), ((0,8),107), ((0,8),43), + ((0,9),183), ((0,8),11), ((0,8),139), ((0,8),75), ((0,9),247), + ((80,7),5), ((0,8),87), ((0,8),23), ((192,8),0), ((83,7),51), + ((0,8),119), ((0,8),55), ((0,9),207), ((81,7),15), ((0,8),103), + ((0,8),39), ((0,9),175), ((0,8),7), ((0,8),135), ((0,8),71), + ((0,9),239), ((80,7),9), ((0,8),95), ((0,8),31), ((0,9),159), + ((84,7),99), ((0,8),127), ((0,8),63), ((0,9),223), ((82,7),27), + ((0,8),111), ((0,8),47), ((0,9),191), ((0,8),15), ((0,8),143), + ((0,8),79), ((0,9),255) + ); + +{local} +const + fixed_td : array[0..32-1] of inflate_huft = ( +(Exop:80;bits:5;base:1), (Exop:87;bits:5;base:257), (Exop:83;bits:5;base:17), +(Exop:91;bits:5;base:4097), (Exop:81;bits:5;base), (Exop:89;bits:5;base:1025), +(Exop:85;bits:5;base:65), (Exop:93;bits:5;base:16385), (Exop:80;bits:5;base:3), +(Exop:88;bits:5;base:513), (Exop:84;bits:5;base:33), (Exop:92;bits:5;base:8193), +(Exop:82;bits:5;base:9), (Exop:90;bits:5;base:2049), (Exop:86;bits:5;base:129), +(Exop:192;bits:5;base:24577), (Exop:80;bits:5;base:2), (Exop:87;bits:5;base:385), +(Exop:83;bits:5;base:25), (Exop:91;bits:5;base:6145), (Exop:81;bits:5;base:7), +(Exop:89;bits:5;base:1537), (Exop:85;bits:5;base:97), (Exop:93;bits:5;base:24577), +(Exop:80;bits:5;base:4), (Exop:88;bits:5;base:769), (Exop:84;bits:5;base:49), +(Exop:92;bits:5;base:12289), (Exop:82;bits:5;base:13), (Exop:90;bits:5;base:3073), +(Exop:86;bits:5;base:193), (Exop:192;bits:5;base:24577) + ); +{$ENDIF} + +function inflate_trees_fixed( +var bl : uInt; { literal desired/actual bit depth } +var bd : uInt; { distance desired/actual bit depth } +var tl : pInflate_huft; { literal/length tree result } +var td : pInflate_huft; { distance tree result } +var z : z_stream { for memory allocation } + ) : int; +type + pFixed_table = ^fixed_table; + fixed_table = array[0..288-1] of uIntf; +var + k : int; { temporary variable } + c : pFixed_table; { length list for huft_build } + v : PuIntArray; { work area for huft_build } +var + f : uInt; { number of hufts used in fixed_mem } +begin + { build fixed tables if not already (multiple overlapped executions ok) } + if not fixed_built then + begin + f := 0; + + { allocate memory } + c := pFixed_table( ZALLOC(z, 288, sizeof(uInt)) ); + if (c = Z_NULL) then + begin + inflate_trees_fixed := Z_MEM_ERROR; + exit; + end; + v := PuIntArray( ZALLOC(z, 288, sizeof(uInt)) ); + if (v = Z_NULL) then + begin + ZFREE(z, c); + inflate_trees_fixed := Z_MEM_ERROR; + exit; + end; + + { literal table } + for k := 0 to Pred(144) do + c^[k] := 8; + for k := 144 to Pred(256) do + c^[k] := 9; + for k := 256 to Pred(280) do + c^[k] := 7; + for k := 280 to Pred(288) do + c^[k] := 8; + fixed_bl := 9; + huft_build(c^, 288, 257, cplens, cplext, @fixed_tl, fixed_bl, + fixed_mem, f, v^); + + { distance table } + for k := 0 to Pred(30) do + c^[k] := 5; + fixed_bd := 5; + huft_build(c^, 30, 0, cpdist, cpdext, @fixed_td, fixed_bd, + fixed_mem, f, v^); + + { done } + ZFREE(z, v); + ZFREE(z, c); + fixed_built := True; + end; + bl := fixed_bl; + bd := fixed_bd; + tl := fixed_tl; + td := fixed_td; + inflate_trees_fixed := Z_OK; +end; { inflate_trees_fixed } + + end. \ No newline at end of file diff --git a/Imaging/ZLib/iminfutil.pas b/Imaging/ZLib/iminfutil.pas index 384f0d3..d5364f0 100644 --- a/Imaging/ZLib/iminfutil.pas +++ b/Imaging/ZLib/iminfutil.pas @@ -1,222 +1,222 @@ -Unit iminfutil; - -{ types and macros common to blocks and codes - Copyright (C) 1995-1998 Mark Adler - - WARNING: this file should *not* be used by applications. It is - part of the implementation of the compression library and is - subject to change. - - Pascal tranlastion - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - -interface - -{$I imzconf.inc} - -uses - imzutil, impaszlib; - -{ copy as much as possible from the sliding window to the output area } -function inflate_flush(var s : inflate_blocks_state; - var z : z_stream; - r : int) : int; - -{ And'ing with mask[n] masks the lower n bits } -const - inflate_mask : array[0..17-1] of uInt = ( - $0000, - $0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff, - $01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff); - -{procedure GRABBITS(j : int);} -{procedure DUMPBITS(j : int);} -{procedure NEEDBITS(j : int);} - -implementation - -{ macros for bit input with no checking and for returning unused bytes } -procedure GRABBITS(j : int); -begin - {while (k < j) do - begin - Dec(z^.avail_in); - Inc(z^.total_in); - b := b or (uLong(z^.next_in^) shl k); - Inc(z^.next_in); - Inc(k, 8); - end;} -end; - -procedure DUMPBITS(j : int); -begin - {b := b shr j; - Dec(k, j);} -end; - -procedure NEEDBITS(j : int); -begin - (* - while (k < j) do - begin - {NEEDBYTE;} - if (n <> 0) then - r :=Z_OK - else - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, LongInt(p)-LongInt(z.next_in)); - z.next_in := p; - s.write := q; - result := inflate_flush(s,z,r); - exit; - end; - Dec(n); - b := b or (uLong(p^) shl k); - Inc(p); - Inc(k, 8); - end; - *) -end; - -procedure NEEDOUT; -begin - (* - if (m = 0) then - begin - {WRAP} - if (q = s.zend) and (s.read <> s.window) then - begin - q := s.window; - if LongInt(q) < LongInt(s.read) then - m := uInt(LongInt(s.read)-LongInt(q)-1) - else - m := uInt(LongInt(s.zend)-LongInt(q)); - end; - - if (m = 0) then - begin - {FLUSH} - s.write := q; - r := inflate_flush(s,z,r); - q := s.write; - if LongInt(q) < LongInt(s.read) then - m := uInt(LongInt(s.read)-LongInt(q)-1) - else - m := uInt(LongInt(s.zend)-LongInt(q)); - - {WRAP} - if (q = s.zend) and (s.read <> s.window) then - begin - q := s.window; - if LongInt(q) < LongInt(s.read) then - m := uInt(LongInt(s.read)-LongInt(q)-1) - else - m := uInt(LongInt(s.zend)-LongInt(q)); - end; - - if (m = 0) then - begin - {UPDATE} - s.bitb := b; - s.bitk := k; - z.avail_in := n; - Inc(z.total_in, LongInt(p)-LongInt(z.next_in)); - z.next_in := p; - s.write := q; - result := inflate_flush(s,z,r); - exit; - end; - end; - end; - r := Z_OK; - *) -end; - -{ copy as much as possible from the sliding window to the output area } -function inflate_flush(var s : inflate_blocks_state; - var z : z_stream; - r : int) : int; -var - n : uInt; - p : pBytef; - q : pBytef; -begin - { local copies of source and destination pointers } - p := z.next_out; - q := s.read; - - { compute number of bytes to copy as far as end of window } - if ptr2int(q) <= ptr2int(s.write) then - n := uInt(ptr2int(s.write) - ptr2int(q)) - else - n := uInt(ptr2int(s.zend) - ptr2int(q)); - if (n > z.avail_out) then - n := z.avail_out; - if (n <> 0) and (r = Z_BUF_ERROR) then - r := Z_OK; - - { update counters } - Dec(z.avail_out, n); - Inc(z.total_out, n); - - - { update check information } - if Assigned(s.checkfn) then - begin - s.check := s.checkfn(s.check, q, n); - z.adler := s.check; - end; - - { copy as far as end of window } - zmemcpy(p, q, n); - Inc(p, n); - Inc(q, n); - - { see if more to copy at beginning of window } - if (q = s.zend) then - begin - { wrap pointers } - q := s.window; - if (s.write = s.zend) then - s.write := s.window; - - { compute bytes to copy } - n := uInt(ptr2int(s.write) - ptr2int(q)); - if (n > z.avail_out) then - n := z.avail_out; - if (n <> 0) and (r = Z_BUF_ERROR) then - r := Z_OK; - - { update counters } - Dec( z.avail_out, n); - Inc( z.total_out, n); - - { update check information } - if Assigned(s.checkfn) then - begin - s.check := s.checkfn(s.check, q, n); - z.adler := s.check; - end; - - { copy } - zmemcpy(p, q, n); - Inc(p, n); - Inc(q, n); - end; - - - { update pointers } - z.next_out := p; - s.read := q; - - { done } - inflate_flush := r; -end; - -end. +Unit iminfutil; + +{ types and macros common to blocks and codes + Copyright (C) 1995-1998 Mark Adler + + WARNING: this file should *not* be used by applications. It is + part of the implementation of the compression library and is + subject to change. + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I imzconf.inc} + +uses + imzutil, impaszlib; + +{ copy as much as possible from the sliding window to the output area } +function inflate_flush(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; + +{ And'ing with mask[n] masks the lower n bits } +const + inflate_mask : array[0..17-1] of uInt = ( + $0000, + $0001, $0003, $0007, $000f, $001f, $003f, $007f, $00ff, + $01ff, $03ff, $07ff, $0fff, $1fff, $3fff, $7fff, $ffff); + +{procedure GRABBITS(j : int);} +{procedure DUMPBITS(j : int);} +{procedure NEEDBITS(j : int);} + +implementation + +{ macros for bit input with no checking and for returning unused bytes } +procedure GRABBITS(j : int); +begin + {while (k < j) do + begin + Dec(z^.avail_in); + Inc(z^.total_in); + b := b or (uLong(z^.next_in^) shl k); + Inc(z^.next_in); + Inc(k, 8); + end;} +end; + +procedure DUMPBITS(j : int); +begin + {b := b shr j; + Dec(k, j);} +end; + +procedure NEEDBITS(j : int); +begin + (* + while (k < j) do + begin + {NEEDBYTE;} + if (n <> 0) then + r :=Z_OK + else + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, LongInt(p)-LongInt(z.next_in)); + z.next_in := p; + s.write := q; + result := inflate_flush(s,z,r); + exit; + end; + Dec(n); + b := b or (uLong(p^) shl k); + Inc(p); + Inc(k, 8); + end; + *) +end; + +procedure NEEDOUT; +begin + (* + if (m = 0) then + begin + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if LongInt(q) < LongInt(s.read) then + m := uInt(LongInt(s.read)-LongInt(q)-1) + else + m := uInt(LongInt(s.zend)-LongInt(q)); + end; + + if (m = 0) then + begin + {FLUSH} + s.write := q; + r := inflate_flush(s,z,r); + q := s.write; + if LongInt(q) < LongInt(s.read) then + m := uInt(LongInt(s.read)-LongInt(q)-1) + else + m := uInt(LongInt(s.zend)-LongInt(q)); + + {WRAP} + if (q = s.zend) and (s.read <> s.window) then + begin + q := s.window; + if LongInt(q) < LongInt(s.read) then + m := uInt(LongInt(s.read)-LongInt(q)-1) + else + m := uInt(LongInt(s.zend)-LongInt(q)); + end; + + if (m = 0) then + begin + {UPDATE} + s.bitb := b; + s.bitk := k; + z.avail_in := n; + Inc(z.total_in, LongInt(p)-LongInt(z.next_in)); + z.next_in := p; + s.write := q; + result := inflate_flush(s,z,r); + exit; + end; + end; + end; + r := Z_OK; + *) +end; + +{ copy as much as possible from the sliding window to the output area } +function inflate_flush(var s : inflate_blocks_state; + var z : z_stream; + r : int) : int; +var + n : uInt; + p : pBytef; + q : pBytef; +begin + { local copies of source and destination pointers } + p := z.next_out; + q := s.read; + + { compute number of bytes to copy as far as end of window } + if ptr2int(q) <= ptr2int(s.write) then + n := uInt(ptr2int(s.write) - ptr2int(q)) + else + n := uInt(ptr2int(s.zend) - ptr2int(q)); + if (n > z.avail_out) then + n := z.avail_out; + if (n <> 0) and (r = Z_BUF_ERROR) then + r := Z_OK; + + { update counters } + Dec(z.avail_out, n); + Inc(z.total_out, n); + + + { update check information } + if Assigned(s.checkfn) then + begin + s.check := s.checkfn(s.check, q, n); + z.adler := s.check; + end; + + { copy as far as end of window } + zmemcpy(p, q, n); + Inc(p, n); + Inc(q, n); + + { see if more to copy at beginning of window } + if (q = s.zend) then + begin + { wrap pointers } + q := s.window; + if (s.write = s.zend) then + s.write := s.window; + + { compute bytes to copy } + n := uInt(ptr2int(s.write) - ptr2int(q)); + if (n > z.avail_out) then + n := z.avail_out; + if (n <> 0) and (r = Z_BUF_ERROR) then + r := Z_OK; + + { update counters } + Dec( z.avail_out, n); + Inc( z.total_out, n); + + { update check information } + if Assigned(s.checkfn) then + begin + s.check := s.checkfn(s.check, q, n); + z.adler := s.check; + end; + + { copy } + zmemcpy(p, q, n); + Inc(p, n); + Inc(q, n); + end; + + + { update pointers } + z.next_out := p; + s.read := q; + + { done } + inflate_flush := r; +end; + +end. diff --git a/Imaging/ZLib/impaszlib.pas b/Imaging/ZLib/impaszlib.pas index 555634c..400c650 100644 --- a/Imaging/ZLib/impaszlib.pas +++ b/Imaging/ZLib/impaszlib.pas @@ -1,520 +1,520 @@ -Unit impaszlib; - - -{ Original: - zlib.h -- interface of the 'zlib' general purpose compression library - version 1.1.0, Feb 24th, 1998 - - Copyright (C) 1995-1998 Jean-loup Gailly and Mark Adler - - This software is provided 'as-is', without any express or implied - warranty. In no event will the authors be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - Jean-loup Gailly Mark Adler - jloup@gzip.org madler@alumni.caltech.edu - - - The data format used by the zlib library is described by RFCs (Request for - Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt - (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format). - - - Pascal tranlastion - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - -interface - -{$I imzconf.inc} - -uses - imzutil; - -{ zconf.h -- configuration of the zlib compression library } -{ zutil.c -- target dependent utility functions for the compression library } - -{ The 'zlib' compression library provides in-memory compression and - decompression functions, including integrity checks of the uncompressed - data. This version of the library supports only one compression method - (deflation) but other algorithms will be added later and will have the same - stream interface. - - Compression can be done in a single step if the buffers are large - enough (for example if an input file is mmap'ed), or can be done by - repeated calls of the compression function. In the latter case, the - application must provide more input and/or consume the output - (providing more output space) before each call. - - The library also supports reading and writing files in gzip (.gz) format - with an interface similar to that of stdio. - - The library does not install any signal handler. The decoder checks - the consistency of the compressed data, so the library should never - crash even in case of corrupted input. } - - - -{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more - than 64k bytes at a time (needed on systems with 16-bit int). } - -{ Maximum value for memLevel in deflateInit2 } -const - MAX_MEM_LEVEL = 9; - DEF_MEM_LEVEL = 8; { if MAX_MEM_LEVEL > 8 } - -{ Maximum value for windowBits in deflateInit2 and inflateInit2 } -const - MAX_WBITS = 15; { 32K LZ77 window } - -{ default windowBits for decompression. MAX_WBITS is for compression only } -const - DEF_WBITS = MAX_WBITS; - -{ The memory requirements for deflate are (in bytes): - 1 shl (windowBits+2) + 1 shl (memLevel+9) - that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values) - plus a few kilobytes for small objects. For example, if you want to reduce - the default memory requirements from 256K to 128K, compile with - DMAX_WBITS=14 DMAX_MEM_LEVEL=7 - Of course this will generally degrade compression (there's no free lunch). - - The memory requirements for inflate are (in bytes) 1 shl windowBits - that is, 32K for windowBits=15 (default value) plus a few kilobytes - for small objects. } - - -{ Huffman code lookup table entry--this entry is four bytes for machines - that have 16-bit pointers (e.g. PC's in the small or medium model). } - -type - pInflate_huft = ^inflate_huft; - inflate_huft = Record - Exop, { number of extra bits or operation } - bits : Byte; { number of bits in this code or subcode } - {pad : uInt;} { pad structure to a power of 2 (4 bytes for } - { 16-bit, 8 bytes for 32-bit int's) } - base : uInt; { literal, length base, or distance base } - { or table offset } - End; - -type - huft_field = Array[0..(MaxInt div SizeOf(inflate_huft))-1] of inflate_huft; - huft_ptr = ^huft_field; -type - ppInflate_huft = ^pInflate_huft; - -type - inflate_codes_mode = ( { waiting for "i:"=input, "o:"=output, "x:"=nothing } - START, { x: set up for LEN } - LEN, { i: get length/literal/eob next } - LENEXT, { i: getting length extra (have base) } - DIST, { i: get distance next } - DISTEXT, { i: getting distance extra } - COPY, { o: copying bytes in window, waiting for space } - LIT, { o: got literal, waiting for output space } - WASH, { o: got eob, possibly still output waiting } - ZEND, { x: got eob and all data flushed } - BADCODE); { x: got error } - -{ inflate codes private state } -type - pInflate_codes_state = ^inflate_codes_state; - inflate_codes_state = record - - mode : inflate_codes_mode; { current inflate_codes mode } - - { mode dependent information } - len : uInt; - sub : record { submode } - Case Byte of - 0:(code : record { if LEN or DIST, where in tree } - tree : pInflate_huft; { pointer into tree } - need : uInt; { bits needed } - end); - 1:(lit : uInt); { if LIT, literal } - 2:(copy: record { if EXT or COPY, where and how much } - get : uInt; { bits to get for extra } - dist : uInt; { distance back to copy from } - end); - end; - - { mode independent information } - lbits : Byte; { ltree bits decoded per branch } - dbits : Byte; { dtree bits decoder per branch } - ltree : pInflate_huft; { literal/length/eob tree } - dtree : pInflate_huft; { distance tree } - end; - -type - check_func = function(check : uLong; - buf : pBytef; - {const buf : array of byte;} - len : uInt) : uLong; -type - inflate_block_mode = - (ZTYPE, { get type bits (3, including end bit) } - LENS, { get lengths for stored } - STORED, { processing stored block } - TABLE, { get table lengths } - BTREE, { get bit lengths tree for a dynamic block } - DTREE, { get length, distance trees for a dynamic block } - CODES, { processing fixed or dynamic block } - DRY, { output remaining window bytes } - BLKDONE, { finished last block, done } - BLKBAD); { got a data error--stuck here } - -type - pInflate_blocks_state = ^inflate_blocks_state; - -{ inflate blocks semi-private state } - inflate_blocks_state = record - - mode : inflate_block_mode; { current inflate_block mode } - - { mode dependent information } - sub : record { submode } - case Byte of - 0:(left : uInt); { if STORED, bytes left to copy } - 1:(trees : record { if DTREE, decoding info for trees } - table : uInt; { table lengths (14 bits) } - index : uInt; { index into blens (or border) } - blens : PuIntArray; { bit lengths of codes } - bb : uInt; { bit length tree depth } - tb : pInflate_huft; { bit length decoding tree } - end); - 2:(decode : record { if CODES, current state } - tl : pInflate_huft; - td : pInflate_huft; { trees to free } - codes : pInflate_codes_state; - end); - end; - last : boolean; { true if this block is the last block } - - { mode independent information } - bitk : uInt; { bits in bit buffer } - bitb : uLong; { bit buffer } - hufts : huft_ptr; {pInflate_huft;} { single malloc for tree space } - window : pBytef; { sliding window } - zend : pBytef; { one byte after sliding window } - read : pBytef; { window read pointer } - write : pBytef; { window write pointer } - checkfn : check_func; { check function } - check : uLong; { check on output } - end; - -type - inflate_mode = ( - METHOD, { waiting for method byte } - FLAG, { waiting for flag byte } - DICT4, { four dictionary check bytes to go } - DICT3, { three dictionary check bytes to go } - DICT2, { two dictionary check bytes to go } - DICT1, { one dictionary check byte to go } - DICT0, { waiting for inflateSetDictionary } - BLOCKS, { decompressing blocks } - CHECK4, { four check bytes to go } - CHECK3, { three check bytes to go } - CHECK2, { two check bytes to go } - CHECK1, { one check byte to go } - DONE, { finished check, done } - BAD); { got an error--stay here } - -{ inflate private state } -type - pInternal_state = ^internal_state; { or point to a deflate_state record } - internal_state = record - - mode : inflate_mode; { current inflate mode } - - { mode dependent information } - sub : record { submode } - case byte of - 0:(method : uInt); { if FLAGS, method byte } - 1:(check : record { if CHECK, check values to compare } - was : uLong; { computed check value } - need : uLong; { stream check value } - end); - 2:(marker : uInt); { if BAD, inflateSync's marker bytes count } - end; - - { mode independent information } - nowrap : boolean; { flag for no wrapper } - wbits : uInt; { log2(window size) (8..15, defaults to 15) } - blocks : pInflate_blocks_state; { current inflate_blocks state } - end; - -type - alloc_func = function(opaque : voidpf; items : uInt; size : uInt) : voidpf; - free_func = procedure(opaque : voidpf; address : voidpf); - -type - z_streamp = ^z_stream; - z_stream = record - next_in : pBytef; { next input byte } - avail_in : uInt; { number of bytes available at next_in } - total_in : uLong; { total nb of input bytes read so far } - - next_out : pBytef; { next output byte should be put there } - avail_out : uInt; { remaining free space at next_out } - total_out : uLong; { total nb of bytes output so far } - - msg : string[255]; { last error message, '' if no error } - state : pInternal_state; { not visible by applications } - - zalloc : alloc_func; { used to allocate the internal state } - zfree : free_func; { used to free the internal state } - opaque : voidpf; { private data object passed to zalloc and zfree } - - data_type : int; { best guess about the data type: ascii or binary } - adler : uLong; { adler32 value of the uncompressed data } - reserved : uLong; { reserved for future use } - end; - - -{ The application must update next_in and avail_in when avail_in has - dropped to zero. It must update next_out and avail_out when avail_out - has dropped to zero. The application must initialize zalloc, zfree and - opaque before calling the init function. All other fields are set by the - compression library and must not be updated by the application. - - The opaque value provided by the application will be passed as the first - parameter for calls of zalloc and zfree. This can be useful for custom - memory management. The compression library attaches no meaning to the - opaque value. - - zalloc must return Z_NULL if there is not enough memory for the object. - On 16-bit systems, the functions zalloc and zfree must be able to allocate - exactly 65536 bytes, but will not be required to allocate more than this - if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS, - pointers returned by zalloc for objects of exactly 65536 bytes *must* - have their offset normalized to zero. The default allocation function - provided by this library ensures this (see zutil.c). To reduce memory - requirements and avoid any allocation of 64K objects, at the expense of - compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h). - - The fields total_in and total_out can be used for statistics or - progress reports. After compression, total_in holds the total size of - the uncompressed data and may be saved for use in the decompressor - (particularly if the decompressor wants to decompress everything in - a single step). } - -const { constants } - Z_NO_FLUSH = 0; - Z_PARTIAL_FLUSH = 1; - Z_SYNC_FLUSH = 2; - Z_FULL_FLUSH = 3; - Z_FINISH = 4; -{ Allowed flush values; see deflate() below for details } - - 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); -{ Return codes for the compression/decompression functions. Negative - values are errors, positive values are used for special but normal events.} - - Z_NO_COMPRESSION = 0; - Z_BEST_SPEED = 1; - Z_BEST_COMPRESSION = 9; - Z_DEFAULT_COMPRESSION = (-1); -{ compression levels } - - Z_FILTERED = 1; - Z_HUFFMAN_ONLY = 2; - Z_DEFAULT_STRATEGY = 0; -{ compression strategy; see deflateInit2() below for details } - - Z_BINARY = 0; - Z_ASCII = 1; - Z_UNKNOWN = 2; -{ Possible values of the data_type field } - - Z_DEFLATED = 8; -{ The deflate compression method (the only one supported in this version) } - - Z_NULL = NIL; { for initializing zalloc, zfree, opaque } - - {$IFDEF GZIO} -var - errno : int; - {$ENDIF} - - { common constants } - - -{ The three kinds of block type } -const - STORED_BLOCK = 0; - STATIC_TREES = 1; - DYN_TREES = 2; -{ The minimum and maximum match lengths } -const - MIN_MATCH = 3; - MAX_MATCH = 258; - -const - PRESET_DICT = $20; { preset dictionary flag in zlib header } - - - {$IFDEF DEBUG} - procedure Assert(cond : boolean; msg : AnsiString); - {$ENDIF} - - procedure Trace(x : AnsiString); - procedure Tracev(x : AnsiString); - procedure Tracevv(x : AnsiString); - procedure Tracevvv(x : AnsiString); - procedure Tracec(c : boolean; x : AnsiString); - procedure Tracecv(c : boolean; x : AnsiString); - -function zlibVersion : AnsiString; -{ The application can compare zlibVersion and ZLIB_VERSION for consistency. - If the first character differs, the library code actually used is - not compatible with the zlib.h header file used by the application. - This check is automatically made by deflateInit and inflateInit. } - -function zError(err : int) : AnsiString; -function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf; -procedure ZFREE (var strm : z_stream; ptr : voidpf); -procedure TRY_FREE (var strm : z_stream; ptr : voidpf); - -const - ZLIB_VERSION : string[10] = '1.1.2'; - -const - z_errbase = Z_NEED_DICT; - z_errmsg : Array[0..9] of string[21] = { indexed by 2-zlib_error } - ('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) } - ''); -const - z_verbose : int = 1; - -function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: AnsiString; - Stream_size: LongInt): LongInt; -function inflateInit_(var Stream: z_stream; const Version: AnsiString; - Stream_size: Longint): LongInt; - -{$IFDEF DEBUG} -procedure z_error (m : string); -{$ENDIF} - -implementation - -uses - imzdeflate, imzinflate; - -function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: AnsiString; - Stream_size: LongInt): LongInt; -begin - Result := imzdeflate.deflateInit_(@Stream, Level, Version, Stream_size); -end; - -function inflateInit_(var Stream: z_stream; const Version: AnsiString; - Stream_size: Longint): LongInt; -begin - Result := imzinflate.inflateInit_(@Stream, Version, Stream_size); -end; - -function zError(err : int) : AnsiString; -begin - zError := z_errmsg[Z_NEED_DICT-err]; -end; - -function zlibVersion : AnsiString; -begin - zlibVersion := ZLIB_VERSION; -end; - -procedure z_error (m : AnsiString); -begin - WriteLn(output, m); - Write('Zlib - Halt...'); - ReadLn; - Halt(1); -end; - -procedure Assert(cond : boolean; msg : AnsiString); -begin - if not cond then - z_error(msg); -end; - -procedure Trace(x : AnsiString); -begin - WriteLn(x); -end; - -procedure Tracev(x : AnsiString); -begin - if (z_verbose>0) then - WriteLn(x); -end; - -procedure Tracevv(x : AnsiString); -begin - if (z_verbose>1) then - WriteLn(x); -end; - -procedure Tracevvv(x : AnsiString); -begin - if (z_verbose>2) then - WriteLn(x); -end; - -procedure Tracec(c : boolean; x : AnsiString); -begin - if (z_verbose>0) and (c) then - WriteLn(x); -end; - -procedure Tracecv(c : boolean; x : AnsiString); -begin - if (z_verbose>1) and c then - WriteLn(x); -end; - -function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf; -begin - ZALLOC := strm.zalloc(strm.opaque, items, size); -end; - -procedure ZFREE (var strm : z_stream; ptr : voidpf); -begin - strm.zfree(strm.opaque, ptr); -end; - -procedure TRY_FREE (var strm : z_stream; ptr : voidpf); -begin - {if @strm <> Z_NULL then} - strm.zfree(strm.opaque, ptr); -end; - -end. +Unit impaszlib; + + +{ Original: + zlib.h -- interface of the 'zlib' general purpose compression library + version 1.1.0, Feb 24th, 1998 + + Copyright (C) 1995-1998 Jean-loup Gailly and Mark Adler + + This software is provided 'as-is', without any express or implied + warranty. In no event will the authors be held liable for any damages + arising from the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software + in a product, an acknowledgment in the product documentation would be + appreciated but is not required. + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + 3. This notice may not be removed or altered from any source distribution. + + Jean-loup Gailly Mark Adler + jloup@gzip.org madler@alumni.caltech.edu + + + The data format used by the zlib library is described by RFCs (Request for + Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt + (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format). + + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I imzconf.inc} + +uses + imzutil; + +{ zconf.h -- configuration of the zlib compression library } +{ zutil.c -- target dependent utility functions for the compression library } + +{ The 'zlib' compression library provides in-memory compression and + decompression functions, including integrity checks of the uncompressed + data. This version of the library supports only one compression method + (deflation) but other algorithms will be added later and will have the same + stream interface. + + Compression can be done in a single step if the buffers are large + enough (for example if an input file is mmap'ed), or can be done by + repeated calls of the compression function. In the latter case, the + application must provide more input and/or consume the output + (providing more output space) before each call. + + The library also supports reading and writing files in gzip (.gz) format + with an interface similar to that of stdio. + + The library does not install any signal handler. The decoder checks + the consistency of the compressed data, so the library should never + crash even in case of corrupted input. } + + + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{ Maximum value for memLevel in deflateInit2 } +const + MAX_MEM_LEVEL = 9; + DEF_MEM_LEVEL = 8; { if MAX_MEM_LEVEL > 8 } + +{ Maximum value for windowBits in deflateInit2 and inflateInit2 } +const + MAX_WBITS = 15; { 32K LZ77 window } + +{ default windowBits for decompression. MAX_WBITS is for compression only } +const + DEF_WBITS = MAX_WBITS; + +{ The memory requirements for deflate are (in bytes): + 1 shl (windowBits+2) + 1 shl (memLevel+9) + that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values) + plus a few kilobytes for small objects. For example, if you want to reduce + the default memory requirements from 256K to 128K, compile with + DMAX_WBITS=14 DMAX_MEM_LEVEL=7 + Of course this will generally degrade compression (there's no free lunch). + + The memory requirements for inflate are (in bytes) 1 shl windowBits + that is, 32K for windowBits=15 (default value) plus a few kilobytes + for small objects. } + + +{ Huffman code lookup table entry--this entry is four bytes for machines + that have 16-bit pointers (e.g. PC's in the small or medium model). } + +type + pInflate_huft = ^inflate_huft; + inflate_huft = Record + Exop, { number of extra bits or operation } + bits : Byte; { number of bits in this code or subcode } + {pad : uInt;} { pad structure to a power of 2 (4 bytes for } + { 16-bit, 8 bytes for 32-bit int's) } + base : uInt; { literal, length base, or distance base } + { or table offset } + End; + +type + huft_field = Array[0..(MaxInt div SizeOf(inflate_huft))-1] of inflate_huft; + huft_ptr = ^huft_field; +type + ppInflate_huft = ^pInflate_huft; + +type + inflate_codes_mode = ( { waiting for "i:"=input, "o:"=output, "x:"=nothing } + START, { x: set up for LEN } + LEN, { i: get length/literal/eob next } + LENEXT, { i: getting length extra (have base) } + DIST, { i: get distance next } + DISTEXT, { i: getting distance extra } + COPY, { o: copying bytes in window, waiting for space } + LIT, { o: got literal, waiting for output space } + WASH, { o: got eob, possibly still output waiting } + ZEND, { x: got eob and all data flushed } + BADCODE); { x: got error } + +{ inflate codes private state } +type + pInflate_codes_state = ^inflate_codes_state; + inflate_codes_state = record + + mode : inflate_codes_mode; { current inflate_codes mode } + + { mode dependent information } + len : uInt; + sub : record { submode } + Case Byte of + 0:(code : record { if LEN or DIST, where in tree } + tree : pInflate_huft; { pointer into tree } + need : uInt; { bits needed } + end); + 1:(lit : uInt); { if LIT, literal } + 2:(copy: record { if EXT or COPY, where and how much } + get : uInt; { bits to get for extra } + dist : uInt; { distance back to copy from } + end); + end; + + { mode independent information } + lbits : Byte; { ltree bits decoded per branch } + dbits : Byte; { dtree bits decoder per branch } + ltree : pInflate_huft; { literal/length/eob tree } + dtree : pInflate_huft; { distance tree } + end; + +type + check_func = function(check : uLong; + buf : pBytef; + {const buf : array of byte;} + len : uInt) : uLong; +type + inflate_block_mode = + (ZTYPE, { get type bits (3, including end bit) } + LENS, { get lengths for stored } + STORED, { processing stored block } + TABLE, { get table lengths } + BTREE, { get bit lengths tree for a dynamic block } + DTREE, { get length, distance trees for a dynamic block } + CODES, { processing fixed or dynamic block } + DRY, { output remaining window bytes } + BLKDONE, { finished last block, done } + BLKBAD); { got a data error--stuck here } + +type + pInflate_blocks_state = ^inflate_blocks_state; + +{ inflate blocks semi-private state } + inflate_blocks_state = record + + mode : inflate_block_mode; { current inflate_block mode } + + { mode dependent information } + sub : record { submode } + case Byte of + 0:(left : uInt); { if STORED, bytes left to copy } + 1:(trees : record { if DTREE, decoding info for trees } + table : uInt; { table lengths (14 bits) } + index : uInt; { index into blens (or border) } + blens : PuIntArray; { bit lengths of codes } + bb : uInt; { bit length tree depth } + tb : pInflate_huft; { bit length decoding tree } + end); + 2:(decode : record { if CODES, current state } + tl : pInflate_huft; + td : pInflate_huft; { trees to free } + codes : pInflate_codes_state; + end); + end; + last : boolean; { true if this block is the last block } + + { mode independent information } + bitk : uInt; { bits in bit buffer } + bitb : uLong; { bit buffer } + hufts : huft_ptr; {pInflate_huft;} { single malloc for tree space } + window : pBytef; { sliding window } + zend : pBytef; { one byte after sliding window } + read : pBytef; { window read pointer } + write : pBytef; { window write pointer } + checkfn : check_func; { check function } + check : uLong; { check on output } + end; + +type + inflate_mode = ( + METHOD, { waiting for method byte } + FLAG, { waiting for flag byte } + DICT4, { four dictionary check bytes to go } + DICT3, { three dictionary check bytes to go } + DICT2, { two dictionary check bytes to go } + DICT1, { one dictionary check byte to go } + DICT0, { waiting for inflateSetDictionary } + BLOCKS, { decompressing blocks } + CHECK4, { four check bytes to go } + CHECK3, { three check bytes to go } + CHECK2, { two check bytes to go } + CHECK1, { one check byte to go } + DONE, { finished check, done } + BAD); { got an error--stay here } + +{ inflate private state } +type + pInternal_state = ^internal_state; { or point to a deflate_state record } + internal_state = record + + mode : inflate_mode; { current inflate mode } + + { mode dependent information } + sub : record { submode } + case byte of + 0:(method : uInt); { if FLAGS, method byte } + 1:(check : record { if CHECK, check values to compare } + was : uLong; { computed check value } + need : uLong; { stream check value } + end); + 2:(marker : uInt); { if BAD, inflateSync's marker bytes count } + end; + + { mode independent information } + nowrap : boolean; { flag for no wrapper } + wbits : uInt; { log2(window size) (8..15, defaults to 15) } + blocks : pInflate_blocks_state; { current inflate_blocks state } + end; + +type + alloc_func = function(opaque : voidpf; items : uInt; size : uInt) : voidpf; + free_func = procedure(opaque : voidpf; address : voidpf); + +type + z_streamp = ^z_stream; + z_stream = record + next_in : pBytef; { next input byte } + avail_in : uInt; { number of bytes available at next_in } + total_in : uLong; { total nb of input bytes read so far } + + next_out : pBytef; { next output byte should be put there } + avail_out : uInt; { remaining free space at next_out } + total_out : uLong; { total nb of bytes output so far } + + msg : string[255]; { last error message, '' if no error } + state : pInternal_state; { not visible by applications } + + zalloc : alloc_func; { used to allocate the internal state } + zfree : free_func; { used to free the internal state } + opaque : voidpf; { private data object passed to zalloc and zfree } + + data_type : int; { best guess about the data type: ascii or binary } + adler : uLong; { adler32 value of the uncompressed data } + reserved : uLong; { reserved for future use } + end; + + +{ The application must update next_in and avail_in when avail_in has + dropped to zero. It must update next_out and avail_out when avail_out + has dropped to zero. The application must initialize zalloc, zfree and + opaque before calling the init function. All other fields are set by the + compression library and must not be updated by the application. + + The opaque value provided by the application will be passed as the first + parameter for calls of zalloc and zfree. This can be useful for custom + memory management. The compression library attaches no meaning to the + opaque value. + + zalloc must return Z_NULL if there is not enough memory for the object. + On 16-bit systems, the functions zalloc and zfree must be able to allocate + exactly 65536 bytes, but will not be required to allocate more than this + if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS, + pointers returned by zalloc for objects of exactly 65536 bytes *must* + have their offset normalized to zero. The default allocation function + provided by this library ensures this (see zutil.c). To reduce memory + requirements and avoid any allocation of 64K objects, at the expense of + compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h). + + The fields total_in and total_out can be used for statistics or + progress reports. After compression, total_in holds the total size of + the uncompressed data and may be saved for use in the decompressor + (particularly if the decompressor wants to decompress everything in + a single step). } + +const { constants } + Z_NO_FLUSH = 0; + Z_PARTIAL_FLUSH = 1; + Z_SYNC_FLUSH = 2; + Z_FULL_FLUSH = 3; + Z_FINISH = 4; +{ Allowed flush values; see deflate() below for details } + + 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); +{ Return codes for the compression/decompression functions. Negative + values are errors, positive values are used for special but normal events.} + + Z_NO_COMPRESSION = 0; + Z_BEST_SPEED = 1; + Z_BEST_COMPRESSION = 9; + Z_DEFAULT_COMPRESSION = (-1); +{ compression levels } + + Z_FILTERED = 1; + Z_HUFFMAN_ONLY = 2; + Z_DEFAULT_STRATEGY = 0; +{ compression strategy; see deflateInit2() below for details } + + Z_BINARY = 0; + Z_ASCII = 1; + Z_UNKNOWN = 2; +{ Possible values of the data_type field } + + Z_DEFLATED = 8; +{ The deflate compression method (the only one supported in this version) } + + Z_NULL = NIL; { for initializing zalloc, zfree, opaque } + + {$IFDEF GZIO} +var + errno : int; + {$ENDIF} + + { common constants } + + +{ The three kinds of block type } +const + STORED_BLOCK = 0; + STATIC_TREES = 1; + DYN_TREES = 2; +{ The minimum and maximum match lengths } +const + MIN_MATCH = 3; + MAX_MATCH = 258; + +const + PRESET_DICT = $20; { preset dictionary flag in zlib header } + + + {$IFDEF DEBUG} + procedure Assert(cond : boolean; msg : AnsiString); + {$ENDIF} + + procedure Trace(x : AnsiString); + procedure Tracev(x : AnsiString); + procedure Tracevv(x : AnsiString); + procedure Tracevvv(x : AnsiString); + procedure Tracec(c : boolean; x : AnsiString); + procedure Tracecv(c : boolean; x : AnsiString); + +function zlibVersion : AnsiString; +{ The application can compare zlibVersion and ZLIB_VERSION for consistency. + If the first character differs, the library code actually used is + not compatible with the zlib.h header file used by the application. + This check is automatically made by deflateInit and inflateInit. } + +function zError(err : int) : AnsiString; +function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf; +procedure ZFREE (var strm : z_stream; ptr : voidpf); +procedure TRY_FREE (var strm : z_stream; ptr : voidpf); + +const + ZLIB_VERSION : string[10] = '1.1.2'; + +const + z_errbase = Z_NEED_DICT; + z_errmsg : Array[0..9] of string[21] = { indexed by 2-zlib_error } + ('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) } + ''); +const + z_verbose : int = 1; + +function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: AnsiString; + Stream_size: LongInt): LongInt; +function inflateInit_(var Stream: z_stream; const Version: AnsiString; + Stream_size: Longint): LongInt; + +{$IFDEF DEBUG} +procedure z_error (m : string); +{$ENDIF} + +implementation + +uses + imzdeflate, imzinflate; + +function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: AnsiString; + Stream_size: LongInt): LongInt; +begin + Result := imzdeflate.deflateInit_(@Stream, Level, Version, Stream_size); +end; + +function inflateInit_(var Stream: z_stream; const Version: AnsiString; + Stream_size: Longint): LongInt; +begin + Result := imzinflate.inflateInit_(@Stream, Version, Stream_size); +end; + +function zError(err : int) : AnsiString; +begin + zError := z_errmsg[Z_NEED_DICT-err]; +end; + +function zlibVersion : AnsiString; +begin + zlibVersion := ZLIB_VERSION; +end; + +procedure z_error (m : AnsiString); +begin + WriteLn(output, m); + Write('Zlib - Halt...'); + ReadLn; + Halt(1); +end; + +procedure Assert(cond : boolean; msg : AnsiString); +begin + if not cond then + z_error(msg); +end; + +procedure Trace(x : AnsiString); +begin + WriteLn(x); +end; + +procedure Tracev(x : AnsiString); +begin + if (z_verbose>0) then + WriteLn(x); +end; + +procedure Tracevv(x : AnsiString); +begin + if (z_verbose>1) then + WriteLn(x); +end; + +procedure Tracevvv(x : AnsiString); +begin + if (z_verbose>2) then + WriteLn(x); +end; + +procedure Tracec(c : boolean; x : AnsiString); +begin + if (z_verbose>0) and (c) then + WriteLn(x); +end; + +procedure Tracecv(c : boolean; x : AnsiString); +begin + if (z_verbose>1) and c then + WriteLn(x); +end; + +function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf; +begin + ZALLOC := strm.zalloc(strm.opaque, items, size); +end; + +procedure ZFREE (var strm : z_stream; ptr : voidpf); +begin + strm.zfree(strm.opaque, ptr); +end; + +procedure TRY_FREE (var strm : z_stream; ptr : voidpf); +begin + {if @strm <> Z_NULL then} + strm.zfree(strm.opaque, ptr); +end; + +end. diff --git a/Imaging/ZLib/imtrees.pas b/Imaging/ZLib/imtrees.pas index 04c0ebf..0b421e8 100644 --- a/Imaging/ZLib/imtrees.pas +++ b/Imaging/ZLib/imtrees.pas @@ -1,2249 +1,2249 @@ -Unit imtrees; - -{$T-} -{$define ORG_DEBUG} -{ - trees.c -- output deflated data using Huffman coding - Copyright (C) 1995-1998 Jean-loup Gailly - - Pascal tranlastion - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - -{ - * ALGORITHM - * - * The "deflation" process uses several Huffman trees. The more - * common source values are represented by shorter bit sequences. - * - * Each code tree is stored in a compressed form which is itself - * a Huffman encoding of the lengths of all the code strings (in - * ascending order by source values). The actual code strings are - * reconstructed from the lengths in the inflate process, as described - * in the deflate specification. - * - * REFERENCES - * - * Deutsch, L.P.,"'Deflate' Compressed Data Format Specification". - * Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc - * - * Storer, James A. - * Data Compression: Methods and Theory, pp. 49-50. - * Computer Science Press, 1988. ISBN 0-7167-8156-5. - * - * Sedgewick, R. - * Algorithms, p290. - * Addison-Wesley, 1983. ISBN 0-201-06672-6. - } - -interface - -{$I imzconf.inc} - -uses - {$ifdef DEBUG} - SysUtils, strutils, - {$ENDIF} - imzutil, impaszlib; - -{ =========================================================================== - Internal compression state. } - -const - LENGTH_CODES = 29; -{ number of length codes, not counting the special END_BLOCK code } - - LITERALS = 256; -{ number of literal bytes 0..255 } - - L_CODES = (LITERALS+1+LENGTH_CODES); -{ number of Literal or Length codes, including the END_BLOCK code } - - D_CODES = 30; -{ number of distance codes } - - BL_CODES = 19; -{ number of codes used to transfer the bit lengths } - - HEAP_SIZE = (2*L_CODES+1); -{ maximum heap size } - - MAX_BITS = 15; -{ All codes must not exceed MAX_BITS bits } - -const - INIT_STATE = 42; - BUSY_STATE = 113; - FINISH_STATE = 666; -{ Stream status } - - -{ Data structure describing a single value and its code string. } -type - ct_data_ptr = ^ct_data; - ct_data = record - fc : record - case byte of - 0:(freq : ush); { frequency count } - 1:(code : ush); { bit string } - end; - dl : record - case byte of - 0:(dad : ush); { father node in Huffman tree } - 1:(len : ush); { length of bit string } - end; - end; - -{ Freq = fc.freq - Code = fc.code - Dad = dl.dad - Len = dl.len } - -type - ltree_type = array[0..HEAP_SIZE-1] of ct_data; { literal and length tree } - dtree_type = array[0..2*D_CODES+1-1] of ct_data; { distance tree } - htree_type = array[0..2*BL_CODES+1-1] of ct_data; { Huffman tree for bit lengths } - { generic tree type } - tree_type = array[0..(MaxInt div SizeOf(ct_data))-1] of ct_data; - - tree_ptr = ^tree_type; - ltree_ptr = ^ltree_type; - dtree_ptr = ^dtree_type; - htree_ptr = ^htree_type; - - -type - static_tree_desc_ptr = ^static_tree_desc; - static_tree_desc = - record - {const} static_tree : tree_ptr; { static tree or NIL } - {const} extra_bits : pzIntfArray; { extra bits for each code or NIL } - extra_base : int; { base index for extra_bits } - elems : int; { max number of elements in the tree } - max_length : int; { max bit length for the codes } - end; - - tree_desc_ptr = ^tree_desc; - tree_desc = record - dyn_tree : tree_ptr; { the dynamic tree } - max_code : int; { largest code with non zero frequency } - stat_desc : static_tree_desc_ptr; { the corresponding static tree } - end; - -type - Pos = ush; - Posf = Pos; {FAR} - IPos = uInt; - - pPosf = ^Posf; - - zPosfArray = array[0..(MaxInt div SizeOf(Posf))-1] of Posf; - pzPosfArray = ^zPosfArray; - -{ A Pos is an index in the character window. We use short instead of int to - save space in the various tables. IPos is used only for parameter passing.} - -type - deflate_state_ptr = ^deflate_state; - deflate_state = record - strm : z_streamp; { pointer back to this zlib stream } - status : int; { as the name implies } - pending_buf : pzByteArray; { output still pending } - pending_buf_size : ulg; { size of pending_buf } - pending_out : pBytef; { next pending byte to output to the stream } - pending : int; { nb of bytes in the pending buffer } - noheader : int; { suppress zlib header and adler32 } - data_type : Byte; { UNKNOWN, BINARY or ASCII } - method : Byte; { STORED (for zip only) or DEFLATED } - last_flush : int; { value of flush param for previous deflate call } - - { used by deflate.pas: } - - w_size : uInt; { LZ77 window size (32K by default) } - w_bits : uInt; { log2(w_size) (8..16) } - w_mask : uInt; { w_size - 1 } - - window : pzByteArray; - { Sliding window. Input bytes are read into the second half of the window, - and move to the first half later to keep a dictionary of at least wSize - bytes. With this organization, matches are limited to a distance of - wSize-MAX_MATCH bytes, but this ensures that IO is always - performed with a length multiple of the block size. Also, it limits - the window size to 64K, which is quite useful on MSDOS. - To do: use the user input buffer as sliding window. } - - window_size : ulg; - { Actual size of window: 2*wSize, except when the user input buffer - is directly used as sliding window. } - - prev : pzPosfArray; - { Link to older string with same hash index. To limit the size of this - array to 64K, this link is maintained only for the last 32K strings. - An index in this array is thus a window index modulo 32K. } - - head : pzPosfArray; { Heads of the hash chains or NIL. } - - ins_h : uInt; { hash index of string to be inserted } - hash_size : uInt; { number of elements in hash table } - hash_bits : uInt; { log2(hash_size) } - hash_mask : uInt; { hash_size-1 } - - hash_shift : uInt; - { Number of bits by which ins_h must be shifted at each input - step. It must be such that after MIN_MATCH steps, the oldest - byte no longer takes part in the hash key, that is: - hash_shift * MIN_MATCH >= hash_bits } - - block_start : long; - { Window position at the beginning of the current output block. Gets - negative when the window is moved backwards. } - - match_length : uInt; { length of best match } - prev_match : IPos; { previous match } - match_available : boolean; { set if previous match exists } - strstart : uInt; { start of string to insert } - match_start : uInt; { start of matching string } - lookahead : uInt; { number of valid bytes ahead in window } - - prev_length : uInt; - { Length of the best match at previous step. Matches not greater than this - are discarded. This is used in the lazy match evaluation. } - - max_chain_length : uInt; - { To speed up deflation, hash chains are never searched beyond this - length. A higher limit improves compression ratio but degrades the - speed. } - - { moved to the end because Borland Pascal won't accept the following: - max_lazy_match : uInt; - max_insert_length : uInt absolute max_lazy_match; - } - - level : int; { compression level (1..9) } - strategy : int; { favor or force Huffman coding} - - good_match : uInt; - { Use a faster search when the previous match is longer than this } - - nice_match : int; { Stop searching when current match exceeds this } - - { used by trees.pas: } - { Didn't use ct_data typedef below to supress compiler warning } - dyn_ltree : ltree_type; { literal and length tree } - dyn_dtree : dtree_type; { distance tree } - bl_tree : htree_type; { Huffman tree for bit lengths } - - l_desc : tree_desc; { desc. for literal tree } - d_desc : tree_desc; { desc. for distance tree } - bl_desc : tree_desc; { desc. for bit length tree } - - bl_count : array[0..MAX_BITS+1-1] of ush; - { number of codes at each bit length for an optimal tree } - - heap : array[0..2*L_CODES+1-1] of int; { heap used to build the Huffman trees } - heap_len : int; { number of elements in the heap } - heap_max : int; { element of largest frequency } - { The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used. - The same heap array is used to build all trees. } - - depth : array[0..2*L_CODES+1-1] of uch; - { Depth of each subtree used as tie breaker for trees of equal frequency } - - - l_buf : puchfArray; { buffer for literals or lengths } - - lit_bufsize : uInt; - { Size of match buffer for literals/lengths. There are 4 reasons for - limiting lit_bufsize to 64K: - - frequencies can be kept in 16 bit counters - - if compression is not successful for the first block, all input - data is still in the window so we can still emit a stored block even - when input comes from standard input. (This can also be done for - all blocks if lit_bufsize is not greater than 32K.) - - if compression is not successful for a file smaller than 64K, we can - even emit a stored file instead of a stored block (saving 5 bytes). - This is applicable only for zip (not gzip or zlib). - - creating new Huffman trees less frequently may not provide fast - adaptation to changes in the input data statistics. (Take for - example a binary file with poorly compressible code followed by - a highly compressible string table.) Smaller buffer sizes give - fast adaptation but have of course the overhead of transmitting - trees more frequently. - - I can't count above 4 } - - - last_lit : uInt; { running index in l_buf } - - d_buf : pushfArray; - { Buffer for distances. To simplify the code, d_buf and l_buf have - the same number of elements. To use different lengths, an extra flag - array would be necessary. } - - opt_len : ulg; { bit length of current block with optimal trees } - static_len : ulg; { bit length of current block with static trees } - compressed_len : ulg; { total bit length of compressed file } - matches : uInt; { number of string matches in current block } - last_eob_len : int; { bit length of EOB code for last block } - -{$ifdef DEBUG} - bits_sent : ulg; { bit length of the compressed data } -{$endif} - - bi_buf : ush; - { Output buffer. bits are inserted starting at the bottom (least - significant bits). } - - bi_valid : int; - { Number of valid bits in bi_buf. All bits above the last valid bit - are always zero. } - - case byte of - 0:(max_lazy_match : uInt); - { Attempt to find a better match only when the current match is strictly - smaller than this value. This mechanism is used only for compression - levels >= 4. } - - 1:(max_insert_length : uInt); - { Insert new strings in the hash table only if the match length is not - greater than this length. This saves time but degrades compression. - max_insert_length is used only for compression levels <= 3. } - end; - -procedure _tr_init (var s : deflate_state); - -function _tr_tally (var s : deflate_state; - dist : unsigned; - lc : unsigned) : boolean; - -function _tr_flush_block (var s : deflate_state; - buf : pcharf; - stored_len : ulg; - eof : boolean) : ulg; - -procedure _tr_align(var s : deflate_state); - -procedure _tr_stored_block(var s : deflate_state; - buf : pcharf; - stored_len : ulg; - eof : boolean); - -implementation - -{ #define GEN_TREES_H } - -{$ifndef GEN_TREES_H} -{ header created automatically with -DGEN_TREES_H } - -const - DIST_CODE_LEN = 512; { see definition of array dist_code below } - -{ The static literal tree. Since the bit lengths are imposed, there is no - need for the L_CODES extra codes used during heap construction. However - The codes 286 and 287 are needed to build a canonical tree (see _tr_init - below). } -var - static_ltree : array[0..L_CODES+2-1] of ct_data = ( -{ fc:(freq, code) dl:(dad,len) } -(fc:(freq: 12);dl:(len: 8)), (fc:(freq:140);dl:(len: 8)), (fc:(freq: 76);dl:(len: 8)), -(fc:(freq:204);dl:(len: 8)), (fc:(freq: 44);dl:(len: 8)), (fc:(freq:172);dl:(len: 8)), -(fc:(freq:108);dl:(len: 8)), (fc:(freq:236);dl:(len: 8)), (fc:(freq: 28);dl:(len: 8)), -(fc:(freq:156);dl:(len: 8)), (fc:(freq: 92);dl:(len: 8)), (fc:(freq:220);dl:(len: 8)), -(fc:(freq: 60);dl:(len: 8)), (fc:(freq:188);dl:(len: 8)), (fc:(freq:124);dl:(len: 8)), -(fc:(freq:252);dl:(len: 8)), (fc:(freq: 2);dl:(len: 8)), (fc:(freq:130);dl:(len: 8)), -(fc:(freq: 66);dl:(len: 8)), (fc:(freq:194);dl:(len: 8)), (fc:(freq: 34);dl:(len: 8)), -(fc:(freq:162);dl:(len: 8)), (fc:(freq: 98);dl:(len: 8)), (fc:(freq:226);dl:(len: 8)), -(fc:(freq: 18);dl:(len: 8)), (fc:(freq:146);dl:(len: 8)), (fc:(freq: 82);dl:(len: 8)), -(fc:(freq:210);dl:(len: 8)), (fc:(freq: 50);dl:(len: 8)), (fc:(freq:178);dl:(len: 8)), -(fc:(freq:114);dl:(len: 8)), (fc:(freq:242);dl:(len: 8)), (fc:(freq: 10);dl:(len: 8)), -(fc:(freq:138);dl:(len: 8)), (fc:(freq: 74);dl:(len: 8)), (fc:(freq:202);dl:(len: 8)), -(fc:(freq: 42);dl:(len: 8)), (fc:(freq:170);dl:(len: 8)), (fc:(freq:106);dl:(len: 8)), -(fc:(freq:234);dl:(len: 8)), (fc:(freq: 26);dl:(len: 8)), (fc:(freq:154);dl:(len: 8)), -(fc:(freq: 90);dl:(len: 8)), (fc:(freq:218);dl:(len: 8)), (fc:(freq: 58);dl:(len: 8)), -(fc:(freq:186);dl:(len: 8)), (fc:(freq:122);dl:(len: 8)), (fc:(freq:250);dl:(len: 8)), -(fc:(freq: 6);dl:(len: 8)), (fc:(freq:134);dl:(len: 8)), (fc:(freq: 70);dl:(len: 8)), -(fc:(freq:198);dl:(len: 8)), (fc:(freq: 38);dl:(len: 8)), (fc:(freq:166);dl:(len: 8)), -(fc:(freq:102);dl:(len: 8)), (fc:(freq:230);dl:(len: 8)), (fc:(freq: 22);dl:(len: 8)), -(fc:(freq:150);dl:(len: 8)), (fc:(freq: 86);dl:(len: 8)), (fc:(freq:214);dl:(len: 8)), -(fc:(freq: 54);dl:(len: 8)), (fc:(freq:182);dl:(len: 8)), (fc:(freq:118);dl:(len: 8)), -(fc:(freq:246);dl:(len: 8)), (fc:(freq: 14);dl:(len: 8)), (fc:(freq:142);dl:(len: 8)), -(fc:(freq: 78);dl:(len: 8)), (fc:(freq:206);dl:(len: 8)), (fc:(freq: 46);dl:(len: 8)), -(fc:(freq:174);dl:(len: 8)), (fc:(freq:110);dl:(len: 8)), (fc:(freq:238);dl:(len: 8)), -(fc:(freq: 30);dl:(len: 8)), (fc:(freq:158);dl:(len: 8)), (fc:(freq: 94);dl:(len: 8)), -(fc:(freq:222);dl:(len: 8)), (fc:(freq: 62);dl:(len: 8)), (fc:(freq:190);dl:(len: 8)), -(fc:(freq:126);dl:(len: 8)), (fc:(freq:254);dl:(len: 8)), (fc:(freq: 1);dl:(len: 8)), -(fc:(freq:129);dl:(len: 8)), (fc:(freq: 65);dl:(len: 8)), (fc:(freq:193);dl:(len: 8)), -(fc:(freq: 33);dl:(len: 8)), (fc:(freq:161);dl:(len: 8)), (fc:(freq: 97);dl:(len: 8)), -(fc:(freq:225);dl:(len: 8)), (fc:(freq: 17);dl:(len: 8)), (fc:(freq:145);dl:(len: 8)), -(fc:(freq: 81);dl:(len: 8)), (fc:(freq:209);dl:(len: 8)), (fc:(freq: 49);dl:(len: 8)), -(fc:(freq:177);dl:(len: 8)), (fc:(freq:113);dl:(len: 8)), (fc:(freq:241);dl:(len: 8)), -(fc:(freq: 9);dl:(len: 8)), (fc:(freq:137);dl:(len: 8)), (fc:(freq: 73);dl:(len: 8)), -(fc:(freq:201);dl:(len: 8)), (fc:(freq: 41);dl:(len: 8)), (fc:(freq:169);dl:(len: 8)), -(fc:(freq:105);dl:(len: 8)), (fc:(freq:233);dl:(len: 8)), (fc:(freq: 25);dl:(len: 8)), -(fc:(freq:153);dl:(len: 8)), (fc:(freq: 89);dl:(len: 8)), (fc:(freq:217);dl:(len: 8)), -(fc:(freq: 57);dl:(len: 8)), (fc:(freq:185);dl:(len: 8)), (fc:(freq:121);dl:(len: 8)), -(fc:(freq:249);dl:(len: 8)), (fc:(freq: 5);dl:(len: 8)), (fc:(freq:133);dl:(len: 8)), -(fc:(freq: 69);dl:(len: 8)), (fc:(freq:197);dl:(len: 8)), (fc:(freq: 37);dl:(len: 8)), -(fc:(freq:165);dl:(len: 8)), (fc:(freq:101);dl:(len: 8)), (fc:(freq:229);dl:(len: 8)), -(fc:(freq: 21);dl:(len: 8)), (fc:(freq:149);dl:(len: 8)), (fc:(freq: 85);dl:(len: 8)), -(fc:(freq:213);dl:(len: 8)), (fc:(freq: 53);dl:(len: 8)), (fc:(freq:181);dl:(len: 8)), -(fc:(freq:117);dl:(len: 8)), (fc:(freq:245);dl:(len: 8)), (fc:(freq: 13);dl:(len: 8)), -(fc:(freq:141);dl:(len: 8)), (fc:(freq: 77);dl:(len: 8)), (fc:(freq:205);dl:(len: 8)), -(fc:(freq: 45);dl:(len: 8)), (fc:(freq:173);dl:(len: 8)), (fc:(freq:109);dl:(len: 8)), -(fc:(freq:237);dl:(len: 8)), (fc:(freq: 29);dl:(len: 8)), (fc:(freq:157);dl:(len: 8)), -(fc:(freq: 93);dl:(len: 8)), (fc:(freq:221);dl:(len: 8)), (fc:(freq: 61);dl:(len: 8)), -(fc:(freq:189);dl:(len: 8)), (fc:(freq:125);dl:(len: 8)), (fc:(freq:253);dl:(len: 8)), -(fc:(freq: 19);dl:(len: 9)), (fc:(freq:275);dl:(len: 9)), (fc:(freq:147);dl:(len: 9)), -(fc:(freq:403);dl:(len: 9)), (fc:(freq: 83);dl:(len: 9)), (fc:(freq:339);dl:(len: 9)), -(fc:(freq:211);dl:(len: 9)), (fc:(freq:467);dl:(len: 9)), (fc:(freq: 51);dl:(len: 9)), -(fc:(freq:307);dl:(len: 9)), (fc:(freq:179);dl:(len: 9)), (fc:(freq:435);dl:(len: 9)), -(fc:(freq:115);dl:(len: 9)), (fc:(freq:371);dl:(len: 9)), (fc:(freq:243);dl:(len: 9)), -(fc:(freq:499);dl:(len: 9)), (fc:(freq: 11);dl:(len: 9)), (fc:(freq:267);dl:(len: 9)), -(fc:(freq:139);dl:(len: 9)), (fc:(freq:395);dl:(len: 9)), (fc:(freq: 75);dl:(len: 9)), -(fc:(freq:331);dl:(len: 9)), (fc:(freq:203);dl:(len: 9)), (fc:(freq:459);dl:(len: 9)), -(fc:(freq: 43);dl:(len: 9)), (fc:(freq:299);dl:(len: 9)), (fc:(freq:171);dl:(len: 9)), -(fc:(freq:427);dl:(len: 9)), (fc:(freq:107);dl:(len: 9)), (fc:(freq:363);dl:(len: 9)), -(fc:(freq:235);dl:(len: 9)), (fc:(freq:491);dl:(len: 9)), (fc:(freq: 27);dl:(len: 9)), -(fc:(freq:283);dl:(len: 9)), (fc:(freq:155);dl:(len: 9)), (fc:(freq:411);dl:(len: 9)), -(fc:(freq: 91);dl:(len: 9)), (fc:(freq:347);dl:(len: 9)), (fc:(freq:219);dl:(len: 9)), -(fc:(freq:475);dl:(len: 9)), (fc:(freq: 59);dl:(len: 9)), (fc:(freq:315);dl:(len: 9)), -(fc:(freq:187);dl:(len: 9)), (fc:(freq:443);dl:(len: 9)), (fc:(freq:123);dl:(len: 9)), -(fc:(freq:379);dl:(len: 9)), (fc:(freq:251);dl:(len: 9)), (fc:(freq:507);dl:(len: 9)), -(fc:(freq: 7);dl:(len: 9)), (fc:(freq:263);dl:(len: 9)), (fc:(freq:135);dl:(len: 9)), -(fc:(freq:391);dl:(len: 9)), (fc:(freq: 71);dl:(len: 9)), (fc:(freq:327);dl:(len: 9)), -(fc:(freq:199);dl:(len: 9)), (fc:(freq:455);dl:(len: 9)), (fc:(freq: 39);dl:(len: 9)), -(fc:(freq:295);dl:(len: 9)), (fc:(freq:167);dl:(len: 9)), (fc:(freq:423);dl:(len: 9)), -(fc:(freq:103);dl:(len: 9)), (fc:(freq:359);dl:(len: 9)), (fc:(freq:231);dl:(len: 9)), -(fc:(freq:487);dl:(len: 9)), (fc:(freq: 23);dl:(len: 9)), (fc:(freq:279);dl:(len: 9)), -(fc:(freq:151);dl:(len: 9)), (fc:(freq:407);dl:(len: 9)), (fc:(freq: 87);dl:(len: 9)), -(fc:(freq:343);dl:(len: 9)), (fc:(freq:215);dl:(len: 9)), (fc:(freq:471);dl:(len: 9)), -(fc:(freq: 55);dl:(len: 9)), (fc:(freq:311);dl:(len: 9)), (fc:(freq:183);dl:(len: 9)), -(fc:(freq:439);dl:(len: 9)), (fc:(freq:119);dl:(len: 9)), (fc:(freq:375);dl:(len: 9)), -(fc:(freq:247);dl:(len: 9)), (fc:(freq:503);dl:(len: 9)), (fc:(freq: 15);dl:(len: 9)), -(fc:(freq:271);dl:(len: 9)), (fc:(freq:143);dl:(len: 9)), (fc:(freq:399);dl:(len: 9)), -(fc:(freq: 79);dl:(len: 9)), (fc:(freq:335);dl:(len: 9)), (fc:(freq:207);dl:(len: 9)), -(fc:(freq:463);dl:(len: 9)), (fc:(freq: 47);dl:(len: 9)), (fc:(freq:303);dl:(len: 9)), -(fc:(freq:175);dl:(len: 9)), (fc:(freq:431);dl:(len: 9)), (fc:(freq:111);dl:(len: 9)), -(fc:(freq:367);dl:(len: 9)), (fc:(freq:239);dl:(len: 9)), (fc:(freq:495);dl:(len: 9)), -(fc:(freq: 31);dl:(len: 9)), (fc:(freq:287);dl:(len: 9)), (fc:(freq:159);dl:(len: 9)), -(fc:(freq:415);dl:(len: 9)), (fc:(freq: 95);dl:(len: 9)), (fc:(freq:351);dl:(len: 9)), -(fc:(freq:223);dl:(len: 9)), (fc:(freq:479);dl:(len: 9)), (fc:(freq: 63);dl:(len: 9)), -(fc:(freq:319);dl:(len: 9)), (fc:(freq:191);dl:(len: 9)), (fc:(freq:447);dl:(len: 9)), -(fc:(freq:127);dl:(len: 9)), (fc:(freq:383);dl:(len: 9)), (fc:(freq:255);dl:(len: 9)), -(fc:(freq:511);dl:(len: 9)), (fc:(freq: 0);dl:(len: 7)), (fc:(freq: 64);dl:(len: 7)), -(fc:(freq: 32);dl:(len: 7)), (fc:(freq: 96);dl:(len: 7)), (fc:(freq: 16);dl:(len: 7)), -(fc:(freq: 80);dl:(len: 7)), (fc:(freq: 48);dl:(len: 7)), (fc:(freq:112);dl:(len: 7)), -(fc:(freq: 8);dl:(len: 7)), (fc:(freq: 72);dl:(len: 7)), (fc:(freq: 40);dl:(len: 7)), -(fc:(freq:104);dl:(len: 7)), (fc:(freq: 24);dl:(len: 7)), (fc:(freq: 88);dl:(len: 7)), -(fc:(freq: 56);dl:(len: 7)), (fc:(freq:120);dl:(len: 7)), (fc:(freq: 4);dl:(len: 7)), -(fc:(freq: 68);dl:(len: 7)), (fc:(freq: 36);dl:(len: 7)), (fc:(freq:100);dl:(len: 7)), -(fc:(freq: 20);dl:(len: 7)), (fc:(freq: 84);dl:(len: 7)), (fc:(freq: 52);dl:(len: 7)), -(fc:(freq:116);dl:(len: 7)), (fc:(freq: 3);dl:(len: 8)), (fc:(freq:131);dl:(len: 8)), -(fc:(freq: 67);dl:(len: 8)), (fc:(freq:195);dl:(len: 8)), (fc:(freq: 35);dl:(len: 8)), -(fc:(freq:163);dl:(len: 8)), (fc:(freq: 99);dl:(len: 8)), (fc:(freq:227);dl:(len: 8)) -); - - -{ The static distance tree. (Actually a trivial tree since all lens use - 5 bits.) } - static_dtree : array[0..D_CODES-1] of ct_data = ( -(fc:(freq: 0); dl:(len:5)), (fc:(freq:16); dl:(len:5)), (fc:(freq: 8); dl:(len:5)), -(fc:(freq:24); dl:(len:5)), (fc:(freq: 4); dl:(len:5)), (fc:(freq:20); dl:(len:5)), -(fc:(freq:12); dl:(len:5)), (fc:(freq:28); dl:(len:5)), (fc:(freq: 2); dl:(len:5)), -(fc:(freq:18); dl:(len:5)), (fc:(freq:10); dl:(len:5)), (fc:(freq:26); dl:(len:5)), -(fc:(freq: 6); dl:(len:5)), (fc:(freq:22); dl:(len:5)), (fc:(freq:14); dl:(len:5)), -(fc:(freq:30); dl:(len:5)), (fc:(freq: 1); dl:(len:5)), (fc:(freq:17); dl:(len:5)), -(fc:(freq: 9); dl:(len:5)), (fc:(freq:25); dl:(len:5)), (fc:(freq: 5); dl:(len:5)), -(fc:(freq:21); dl:(len:5)), (fc:(freq:13); dl:(len:5)), (fc:(freq:29); dl:(len:5)), -(fc:(freq: 3); dl:(len:5)), (fc:(freq:19); dl:(len:5)), (fc:(freq:11); dl:(len:5)), -(fc:(freq:27); dl:(len:5)), (fc:(freq: 7); dl:(len:5)), (fc:(freq:23); dl:(len:5)) -); - -{ Distance codes. The first 256 values correspond to the distances - 3 .. 258, the last 256 values correspond to the top 8 bits of - the 15 bit distances. } - _dist_code : array[0..DIST_CODE_LEN-1] of uch = ( - 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8, - 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10, -10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, -11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, -12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13, -13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, -13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, -14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, -14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, -14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, -15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, -15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, -15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17, -18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22, -23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, -24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, -26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, -26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, -27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, -27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, -28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, -28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, -28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, -29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, -29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, -29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29 -); - -{ length code for each normalized match length (0 == MIN_MATCH) } - _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch = ( - 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12, -13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16, -17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19, -19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, -21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22, -22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23, -23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, -24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, -25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, -25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26, -26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, -26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, -27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28 -); - - -{ First normalized length for each code (0 = MIN_MATCH) } - base_length : array[0..LENGTH_CODES-1] of int = ( -0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56, -64, 80, 96, 112, 128, 160, 192, 224, 0 -); - - -{ First normalized distance for each code (0 = distance of 1) } - base_dist : array[0..D_CODES-1] of int = ( - 0, 1, 2, 3, 4, 6, 8, 12, 16, 24, - 32, 48, 64, 96, 128, 192, 256, 384, 512, 768, - 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576 -); -{$endif} - -{ Output a byte on the stream. - IN assertion: there is enough room in pending_buf. -macro put_byte(s, c) -begin - s^.pending_buf^[s^.pending] := (c); - Inc(s^.pending); -end -} - -const - MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1); -{ Minimum amount of lookahead, except at the end of the input file. - See deflate.c for comments about the MIN_MATCH+1. } - -{macro d_code(dist) - if (dist) < 256 then - := _dist_code[dist] - else - := _dist_code[256+((dist) shr 7)]); - Mapping from a distance to a distance code. dist is the distance - 1 and - must not have side effects. _dist_code[256] and _dist_code[257] are never - used. } - -{$ifndef ORG_DEBUG} -{ Inline versions of _tr_tally for speed: } - -#if defined(GEN_TREES_H) || !defined(STDC) - extern uch _length_code[]; - extern uch _dist_code[]; -#else - extern const uch _length_code[]; - extern const uch _dist_code[]; -#endif - -macro _tr_tally_lit(s, c, flush) -var - cc : uch; -begin - cc := (c); - s^.d_buf[s^.last_lit] := 0; - s^.l_buf[s^.last_lit] := cc; - Inc(s^.last_lit); - Inc(s^.dyn_ltree[cc].fc.Freq); - flush := (s^.last_lit = s^.lit_bufsize-1); -end; - -macro _tr_tally_dist(s, distance, length, flush) \ -var - len : uch; - dist : ush; -begin - len := (length); - dist := (distance); - s^.d_buf[s^.last_lit] := dist; - s^.l_buf[s^.last_lit] = len; - Inc(s^.last_lit); - Dec(dist); - Inc(s^.dyn_ltree[_length_code[len]+LITERALS+1].fc.Freq); - Inc(s^.dyn_dtree[d_code(dist)].Freq); - flush := (s^.last_lit = s^.lit_bufsize-1); -end; - -{$endif} - -{ =========================================================================== - Constants } - -const - MAX_BL_BITS = 7; -{ Bit length codes must not exceed MAX_BL_BITS bits } - -const - END_BLOCK = 256; -{ end of block literal code } - -const - REP_3_6 = 16; -{ repeat previous bit length 3-6 times (2 bits of repeat count) } - -const - REPZ_3_10 = 17; -{ repeat a zero length 3-10 times (3 bits of repeat count) } - -const - REPZ_11_138 = 18; -{ repeat a zero length 11-138 times (7 bits of repeat count) } - -{local} -const - extra_lbits : array[0..LENGTH_CODES-1] of int - { extra bits for each length code } - = (0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,0); - -{local} -const - extra_dbits : array[0..D_CODES-1] of int - { extra bits for each distance code } - = (0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10,11,11,12,12,13,13); - -{local} -const - extra_blbits : array[0..BL_CODES-1] of int { extra bits for each bit length code } - = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7); - -{local} -const - bl_order : array[0..BL_CODES-1] of uch - = (16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15); -{ The lengths of the bit length codes are sent in order of decreasing - probability, to avoid transmitting the lengths for unused bit length codes. - } - -const - Buf_size = (8 * 2*sizeof(uch)); -{ Number of bits used within bi_buf. (bi_buf might be implemented on - more than 16 bits on some systems.) } - -{ =========================================================================== - Local data. These are initialized only once. } - - -{$ifdef GEN_TREES_H)} -{ non ANSI compilers may not accept trees.h } - -const - DIST_CODE_LEN = 512; { see definition of array dist_code below } - -{local} -var - static_ltree : array[0..L_CODES+2-1] of ct_data; -{ The static literal tree. Since the bit lengths are imposed, there is no - need for the L_CODES extra codes used during heap construction. However - The codes 286 and 287 are needed to build a canonical tree (see _tr_init - below). } - -{local} - static_dtree : array[0..D_CODES-1] of ct_data; -{ The static distance tree. (Actually a trivial tree since all codes use - 5 bits.) } - - _dist_code : array[0..DIST_CODE_LEN-1] of uch; -{ Distance codes. The first 256 values correspond to the distances - 3 .. 258, the last 256 values correspond to the top 8 bits of - the 15 bit distances. } - - _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch; -{ length code for each normalized match length (0 == MIN_MATCH) } - -{local} - base_length : array[0..LENGTH_CODES-1] of int; -{ First normalized length for each code (0 = MIN_MATCH) } - -{local} - base_dist : array[0..D_CODES-1] of int; -{ First normalized distance for each code (0 = distance of 1) } - -{$endif} { GEN_TREES_H } - -{local} -const - static_l_desc : static_tree_desc = - (static_tree: {tree_ptr}(@(static_ltree)); { pointer to array of ct_data } - extra_bits: {pzIntfArray}(@(extra_lbits)); { pointer to array of int } - extra_base: LITERALS+1; - elems: L_CODES; - max_length: MAX_BITS); - -{local} -const - static_d_desc : static_tree_desc = - (static_tree: {tree_ptr}(@(static_dtree)); - extra_bits: {pzIntfArray}(@(extra_dbits)); - extra_base : 0; - elems: D_CODES; - max_length: MAX_BITS); - -{local} -const - static_bl_desc : static_tree_desc = - (static_tree: {tree_ptr}(NIL); - extra_bits: {pzIntfArray}@(extra_blbits); - extra_base : 0; - elems: BL_CODES; - max_length: MAX_BL_BITS); - -(* =========================================================================== - Local (static) routines in this file. } - -procedure tr_static_init; -procedure init_block(var deflate_state); -procedure pqdownheap(var s : deflate_state; - var tree : ct_data; - k : int); -procedure gen_bitlen(var s : deflate_state; - var desc : tree_desc); -procedure gen_codes(var tree : ct_data; - max_code : int; - bl_count : pushf); -procedure build_tree(var s : deflate_state; - var desc : tree_desc); -procedure scan_tree(var s : deflate_state; - var tree : ct_data; - max_code : int); -procedure send_tree(var s : deflate_state; - var tree : ct_data; - max_code : int); -function build_bl_tree(var deflate_state) : int; -procedure send_all_trees(var deflate_state; - lcodes : int; - dcodes : int; - blcodes : int); -procedure compress_block(var s : deflate_state; - var ltree : ct_data; - var dtree : ct_data); -procedure set_data_type(var s : deflate_state); -function bi_reverse(value : unsigned; - length : int) : unsigned; -procedure bi_windup(var deflate_state); -procedure bi_flush(var deflate_state); -procedure copy_block(var deflate_state; - buf : pcharf; - len : unsigned; - header : int); -*) - -{$ifdef GEN_TREES_H} -{local} -procedure gen_trees_header; -{$endif} - -(* -{ =========================================================================== - Output a short LSB first on the stream. - IN assertion: there is enough room in pendingBuf. } - -macro put_short(s, w) -begin - {put_byte(s, (uch)((w) & 0xff));} - s.pending_buf^[s.pending] := uch((w) and $ff); - Inc(s.pending); - - {put_byte(s, (uch)((ush)(w) >> 8));} - s.pending_buf^[s.pending] := uch(ush(w) shr 8);; - Inc(s.pending); -end -*) - -{ =========================================================================== - Send a value on a given number of bits. - IN assertion: length <= 16 and value fits in length bits. } - -{$ifdef ORG_DEBUG} - -{local} -procedure send_bits(var s : deflate_state; - value : int; { value to send } - length : int); { number of bits } -begin - {$ifdef DEBUG} - Tracevv(' l '+IntToStr(length)+ ' v '+IntToStr(value)); - Assert((length > 0) and (length <= 15), 'invalid length'); - Inc(s.bits_sent, ulg(length)); - {$ENDIF} - - { If not enough room in bi_buf, use (valid) bits from bi_buf and - (16 - bi_valid) bits from value, leaving (width - (16-bi_valid)) - unused bits in value. } - {$IFOPT Q+} {$Q-} {$DEFINE NoOverflowCheck} {$ENDIF} - {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} - if (s.bi_valid > int(Buf_size) - length) then - begin - s.bi_buf := s.bi_buf or int(value shl s.bi_valid); - {put_short(s, s.bi_buf);} - s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); - Inc(s.pending); - s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; - Inc(s.pending); - - s.bi_buf := ush(value) shr (Buf_size - s.bi_valid); - Inc(s.bi_valid, length - Buf_size); - end - else - begin - s.bi_buf := s.bi_buf or int(value shl s.bi_valid); - Inc(s.bi_valid, length); - end; - {$IFDEF NoOverflowCheck} {$Q+} {$UNDEF NoOverflowCheck} {$ENDIF} - {$IFDEF NoRangeCheck} {$Q+} {$UNDEF NoRangeCheck} {$ENDIF} -end; - -{$else} { !DEBUG } - - -macro send_code(s, c, tree) -begin - send_bits(s, tree[c].Code, tree[c].Len); - { Send a code of the given tree. c and tree must not have side effects } -end - -macro send_bits(s, value, length) \ -begin int len := length;\ - if (s^.bi_valid > (int)Buf_size - len) begin\ - int val := value;\ - s^.bi_buf |= (val << s^.bi_valid);\ - {put_short(s, s.bi_buf);} - s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); - Inc(s.pending); - s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; - Inc(s.pending); - - s^.bi_buf := (ush)val >> (Buf_size - s^.bi_valid);\ - s^.bi_valid += len - Buf_size;\ - end else begin\ - s^.bi_buf |= (value) << s^.bi_valid;\ - s^.bi_valid += len;\ - end\ -end; -{$endif} { DEBUG } - -{ =========================================================================== - Reverse the first len bits of a code, using straightforward code (a faster - method would use a table) - IN assertion: 1 <= len <= 15 } - -{local} -function bi_reverse(code : unsigned; { the value to invert } - len : int) : unsigned; { its bit length } - -var - res : unsigned; {register} -begin - res := 0; - repeat - res := res or (code and 1); - code := code shr 1; - res := res shl 1; - Dec(len); - until (len <= 0); - bi_reverse := res shr 1; -end; - -{ =========================================================================== - Generate the codes for a given tree and bit counts (which need not be - optimal). - IN assertion: the array bl_count contains the bit length statistics for - the given tree and the field len is set for all tree elements. - OUT assertion: the field code is set for all tree elements of non - zero code length. } - -{local} -procedure gen_codes(tree : tree_ptr; { the tree to decorate } - max_code : int; { largest code with non zero frequency } - var bl_count : array of ushf); { number of codes at each bit length } - -var - next_code : array[0..MAX_BITS+1-1] of ush; { next code value for each bit length } - code : ush; { running code value } - bits : int; { bit index } - n : int; { code index } -var - len : int; -begin - code := 0; - - { The distribution counts are first used to generate the code values - without bit reversal. } - - for bits := 1 to MAX_BITS do - begin - code := ((code + bl_count[bits-1]) shl 1); - next_code[bits] := code; - end; - { Check that the bit counts in bl_count are consistent. The last code - must be all ones. } - - {$IFDEF DEBUG} - Assert (code + bl_count[MAX_BITS]-1 = (1 shl MAX_BITS)-1, - 'inconsistent bit counts'); - Tracev(#13'gen_codes: max_code '+IntToStr(max_code)); - {$ENDIF} - - for n := 0 to max_code do - begin - len := tree^[n].dl.Len; - if (len = 0) then - continue; - { Now reverse the bits } - tree^[n].fc.Code := bi_reverse(next_code[len], len); - Inc(next_code[len]); - {$ifdef DEBUG} - if (n>31) and (n<128) then - Tracecv(tree <> tree_ptr(@static_ltree), - (^M'n #'+IntToStr(n)+' '+AnsiChar(n)+' l '+IntToStr(len)+' c '+ - IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')')) - else - Tracecv(tree <> tree_ptr(@static_ltree), - (^M'n #'+IntToStr(n)+' l '+IntToStr(len)+' c '+ - IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')')); - {$ENDIF} - end; -end; - -{ =========================================================================== - Genererate the file trees.h describing the static trees. } -{$ifdef GEN_TREES_H} - -macro SEPARATOR(i, last, width) - if (i) = (last) then - ( ^M');'^M^M - else \ - if (i) mod (width) = (width)-1 then - ','^M - else - ', ' - -procedure gen_trees_header; -var - header : system.text; - i : int; -begin - system.assign(header, 'trees.inc'); - {$I-} - ReWrite(header); - {$I+} - Assert (IOresult <> 0, 'Can''t open trees.h'); - WriteLn(header, - '{ header created automatically with -DGEN_TREES_H }'^M); - - WriteLn(header, 'local const ct_data static_ltree[L_CODES+2] := ('); - for i := 0 to L_CODES+2-1 do - begin - WriteLn(header, '((%3u),(%3u))%s', static_ltree[i].Code, - static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5)); - end; - - WriteLn(header, 'local const ct_data static_dtree[D_CODES] := ('); - for i := 0 to D_CODES-1 do - begin - WriteLn(header, '((%2u),(%2u))%s', static_dtree[i].Code, - static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5)); - end; - - WriteLn(header, 'const uch _dist_code[DIST_CODE_LEN] := ('); - for i := 0 to DIST_CODE_LEN-1 do - begin - WriteLn(header, '%2u%s', _dist_code[i], - SEPARATOR(i, DIST_CODE_LEN-1, 20)); - end; - - WriteLn(header, 'const uch _length_code[MAX_MATCH-MIN_MATCH+1]= ('); - for i := 0 to MAX_MATCH-MIN_MATCH+1-1 do - begin - WriteLn(header, '%2u%s', _length_code[i], - SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20)); - end; - - WriteLn(header, 'local const int base_length[LENGTH_CODES] := ('); - for i := 0 to LENGTH_CODES-1 do - begin - WriteLn(header, '%1u%s', base_length[i], - SEPARATOR(i, LENGTH_CODES-1, 20)); - end; - - WriteLn(header, 'local const int base_dist[D_CODES] := ('); - for i := 0 to D_CODES-1 do - begin - WriteLn(header, '%5u%s', base_dist[i], - SEPARATOR(i, D_CODES-1, 10)); - end; - - close(header); -end; -{$endif} { GEN_TREES_H } - - -{ =========================================================================== - Initialize the various 'constant' tables. } - -{local} -procedure tr_static_init; - -{$ifdef GEN_TREES_H} -const - static_init_done : boolean = FALSE; -var - n : int; { iterates over tree elements } - bits : int; { bit counter } - length : int; { length value } - code : int; { code value } - dist : int; { distance index } - bl_count : array[0..MAX_BITS+1-1] of ush; - { number of codes at each bit length for an optimal tree } -begin - if (static_init_done) then - exit; - - { Initialize the mapping length (0..255) -> length code (0..28) } - length := 0; - for code := 0 to LENGTH_CODES-1-1 do - begin - base_length[code] := length; - for n := 0 to (1 shl extra_lbits[code])-1 do - begin - _length_code[length] := uch(code); - Inc(length); - end; - end; - Assert (length = 256, 'tr_static_init: length <> 256'); - { Note that the length 255 (match length 258) can be represented - in two different ways: code 284 + 5 bits or code 285, so we - overwrite length_code[255] to use the best encoding: } - - _length_code[length-1] := uch(code); - - { Initialize the mapping dist (0..32K) -> dist code (0..29) } - dist := 0; - for code := 0 to 16-1 do - begin - base_dist[code] := dist; - for n := 0 to (1 shl extra_dbits[code])-1 do - begin - _dist_code[dist] := uch(code); - Inc(dist); - end; - end; - Assert (dist = 256, 'tr_static_init: dist <> 256'); - dist := dist shr 7; { from now on, all distances are divided by 128 } - for code := 16 to D_CODES-1 do - begin - base_dist[code] := dist shl 7; - for n := 0 to (1 shl (extra_dbits[code]-7))-1 do - begin - _dist_code[256 + dist] := uch(code); - Inc(dist); - end; - end; - Assert (dist = 256, 'tr_static_init: 256+dist <> 512'); - - { Construct the codes of the static literal tree } - for bits := 0 to MAX_BITS do - bl_count[bits] := 0; - n := 0; - while (n <= 143) do - begin - static_ltree[n].dl.Len := 8; - Inc(n); - Inc(bl_count[8]); - end; - while (n <= 255) do - begin - static_ltree[n].dl.Len := 9; - Inc(n); - Inc(bl_count[9]); - end; - while (n <= 279) do - begin - static_ltree[n].dl.Len := 7; - Inc(n); - Inc(bl_count[7]); - end; - while (n <= 287) do - begin - static_ltree[n].dl.Len := 8; - Inc(n); - Inc(bl_count[8]); - end; - - { Codes 286 and 287 do not exist, but we must include them in the - tree construction to get a canonical Huffman tree (longest code - all ones) } - - gen_codes(tree_ptr(@static_ltree), L_CODES+1, bl_count); - - { The static distance tree is trivial: } - for n := 0 to D_CODES-1 do - begin - static_dtree[n].dl.Len := 5; - static_dtree[n].fc.Code := bi_reverse(unsigned(n), 5); - end; - static_init_done := TRUE; - - gen_trees_header; { save to include file } -{$else} -begin -{$endif} { GEN_TREES_H) } -end; - -{ =========================================================================== - Initialize a new block. } -{local} - -procedure init_block(var s : deflate_state); -var - n : int; { iterates over tree elements } -begin - { Initialize the trees. } - for n := 0 to L_CODES-1 do - s.dyn_ltree[n].fc.Freq := 0; - for n := 0 to D_CODES-1 do - s.dyn_dtree[n].fc.Freq := 0; - for n := 0 to BL_CODES-1 do - s.bl_tree[n].fc.Freq := 0; - - s.dyn_ltree[END_BLOCK].fc.Freq := 1; - s.static_len := Long(0); - s.opt_len := Long(0); - s.matches := 0; - s.last_lit := 0; -end; - -const - SMALLEST = 1; -{ Index within the heap array of least frequent node in the Huffman tree } - -{ =========================================================================== - Initialize the tree data structures for a new zlib stream. } -procedure _tr_init(var s : deflate_state); -begin - tr_static_init; - - s.compressed_len := Long(0); - - s.l_desc.dyn_tree := tree_ptr(@s.dyn_ltree); - s.l_desc.stat_desc := @static_l_desc; - - s.d_desc.dyn_tree := tree_ptr(@s.dyn_dtree); - s.d_desc.stat_desc := @static_d_desc; - - s.bl_desc.dyn_tree := tree_ptr(@s.bl_tree); - s.bl_desc.stat_desc := @static_bl_desc; - - s.bi_buf := 0; - s.bi_valid := 0; - s.last_eob_len := 8; { enough lookahead for inflate } -{$ifdef DEBUG} - s.bits_sent := Long(0); -{$endif} - - { Initialize the first block of the first file: } - init_block(s); -end; - -{ =========================================================================== - Remove the smallest element from the heap and recreate the heap with - one less element. Updates heap and heap_len. - -macro pqremove(s, tree, top) -begin - top := s.heap[SMALLEST]; - s.heap[SMALLEST] := s.heap[s.heap_len]; - Dec(s.heap_len); - pqdownheap(s, tree, SMALLEST); -end -} - -{ =========================================================================== - Compares to subtrees, using the tree depth as tie breaker when - the subtrees have equal frequency. This minimizes the worst case length. - -macro smaller(tree, n, m, depth) - ( (tree[n].Freq < tree[m].Freq) or - ((tree[n].Freq = tree[m].Freq) and (depth[n] <= depth[m])) ) -} - -{ =========================================================================== - Restore the heap property by moving down the tree starting at node k, - exchanging a node with the smallest of its two sons if necessary, stopping - when the heap property is re-established (each father smaller than its - two sons). } -{local} - -procedure pqdownheap(var s : deflate_state; - var tree : tree_type; { the tree to restore } - k : int); { node to move down } -var - v : int; - j : int; -begin - v := s.heap[k]; - j := k shl 1; { left son of k } - while (j <= s.heap_len) do - begin - { Set j to the smallest of the two sons: } - if (j < s.heap_len) and - {smaller(tree, s.heap[j+1], s.heap[j], s.depth)} - ( (tree[s.heap[j+1]].fc.Freq < tree[s.heap[j]].fc.Freq) or - ((tree[s.heap[j+1]].fc.Freq = tree[s.heap[j]].fc.Freq) and - (s.depth[s.heap[j+1]] <= s.depth[s.heap[j]])) ) then - begin - Inc(j); - end; - { Exit if v is smaller than both sons } - if {(smaller(tree, v, s.heap[j], s.depth))} - ( (tree[v].fc.Freq < tree[s.heap[j]].fc.Freq) or - ((tree[v].fc.Freq = tree[s.heap[j]].fc.Freq) and - (s.depth[v] <= s.depth[s.heap[j]])) ) then - break; - { Exchange v with the smallest son } - s.heap[k] := s.heap[j]; - k := j; - - { And continue down the tree, setting j to the left son of k } - j := j shl 1; - end; - s.heap[k] := v; -end; - -{ =========================================================================== - Compute the optimal bit lengths for a tree and update the total bit length - for the current block. - IN assertion: the fields freq and dad are set, heap[heap_max] and - above are the tree nodes sorted by increasing frequency. - OUT assertions: the field len is set to the optimal bit length, the - array bl_count contains the frequencies for each bit length. - The length opt_len is updated; static_len is also updated if stree is - not null. } - -{local} -procedure gen_bitlen(var s : deflate_state; - var desc : tree_desc); { the tree descriptor } -var - tree : tree_ptr; - max_code : int; - stree : tree_ptr; {const} - extra : pzIntfArray; {const} - base : int; - max_length : int; - h : int; { heap index } - n, m : int; { iterate over the tree elements } - bits : int; { bit length } - xbits : int; { extra bits } - f : ush; { frequency } - overflow : int; { number of elements with bit length too large } -begin - tree := desc.dyn_tree; - max_code := desc.max_code; - stree := desc.stat_desc^.static_tree; - extra := desc.stat_desc^.extra_bits; - base := desc.stat_desc^.extra_base; - max_length := desc.stat_desc^.max_length; - overflow := 0; - - for bits := 0 to MAX_BITS do - s.bl_count[bits] := 0; - - { In a first pass, compute the optimal bit lengths (which may - overflow in the case of the bit length tree). } - - tree^[s.heap[s.heap_max]].dl.Len := 0; { root of the heap } - - for h := s.heap_max+1 to HEAP_SIZE-1 do - begin - n := s.heap[h]; - bits := tree^[tree^[n].dl.Dad].dl.Len + 1; - if (bits > max_length) then - begin - bits := max_length; - Inc(overflow); - end; - tree^[n].dl.Len := ush(bits); - { We overwrite tree[n].dl.Dad which is no longer needed } - - if (n > max_code) then - continue; { not a leaf node } - - Inc(s.bl_count[bits]); - xbits := 0; - if (n >= base) then - xbits := extra^[n-base]; - f := tree^[n].fc.Freq; - Inc(s.opt_len, ulg(f) * (bits + xbits)); - if (stree <> NIL) then - Inc(s.static_len, ulg(f) * (stree^[n].dl.Len + xbits)); - end; - if (overflow = 0) then - exit; - {$ifdef DEBUG} - Tracev(^M'bit length overflow'); - {$endif} - { This happens for example on obj2 and pic of the Calgary corpus } - - { Find the first bit length which could increase: } - repeat - bits := max_length-1; - while (s.bl_count[bits] = 0) do - Dec(bits); - Dec(s.bl_count[bits]); { move one leaf down the tree } - Inc(s.bl_count[bits+1], 2); { move one overflow item as its brother } - Dec(s.bl_count[max_length]); - { The brother of the overflow item also moves one step up, - but this does not affect bl_count[max_length] } - - Dec(overflow, 2); - until (overflow <= 0); - - { Now recompute all bit lengths, scanning in increasing frequency. - h is still equal to HEAP_SIZE. (It is simpler to reconstruct all - lengths instead of fixing only the wrong ones. This idea is taken - from 'ar' written by Haruhiko Okumura.) } - h := HEAP_SIZE; { Delphi3: compiler warning w/o this } - for bits := max_length downto 1 do - begin - n := s.bl_count[bits]; - while (n <> 0) do - begin - Dec(h); - m := s.heap[h]; - if (m > max_code) then - continue; - if (tree^[m].dl.Len <> unsigned(bits)) then - begin - {$ifdef DEBUG} - Trace('code '+IntToStr(m)+' bits '+IntToStr(tree^[m].dl.Len) - +'.'+IntToStr(bits)); - {$ENDIF} - Inc(s.opt_len, (long(bits) - long(tree^[m].dl.Len)) - * long(tree^[m].fc.Freq) ); - tree^[m].dl.Len := ush(bits); - end; - Dec(n); - end; - end; -end; - -{ =========================================================================== - Construct one Huffman tree and assigns the code bit strings and lengths. - Update the total bit length for the current block. - IN assertion: the field freq is set for all tree elements. - OUT assertions: the fields len and code are set to the optimal bit length - and corresponding code. The length opt_len is updated; static_len is - also updated if stree is not null. The field max_code is set. } - -{local} -procedure build_tree(var s : deflate_state; - var desc : tree_desc); { the tree descriptor } - -var - tree : tree_ptr; - stree : tree_ptr; {const} - elems : int; - n, m : int; { iterate over heap elements } - max_code : int; { largest code with non zero frequency } - node : int; { new node being created } -begin - tree := desc.dyn_tree; - stree := desc.stat_desc^.static_tree; - elems := desc.stat_desc^.elems; - max_code := -1; - - { Construct the initial heap, with least frequent element in - heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1]. - heap[0] is not used. } - s.heap_len := 0; - s.heap_max := HEAP_SIZE; - - for n := 0 to elems-1 do - begin - if (tree^[n].fc.Freq <> 0) then - begin - max_code := n; - Inc(s.heap_len); - s.heap[s.heap_len] := n; - s.depth[n] := 0; - end - else - begin - tree^[n].dl.Len := 0; - end; - end; - - { The pkzip format requires that at least one distance code exists, - and that at least one bit should be sent even if there is only one - possible code. So to avoid special checks later on we force at least - two codes of non zero frequency. } - - while (s.heap_len < 2) do - begin - Inc(s.heap_len); - if (max_code < 2) then - begin - Inc(max_code); - s.heap[s.heap_len] := max_code; - node := max_code; - end - else - begin - s.heap[s.heap_len] := 0; - node := 0; - end; - tree^[node].fc.Freq := 1; - s.depth[node] := 0; - Dec(s.opt_len); - if (stree <> NIL) then - Dec(s.static_len, stree^[node].dl.Len); - { node is 0 or 1 so it does not have extra bits } - end; - desc.max_code := max_code; - - { The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree, - establish sub-heaps of increasing lengths: } - - for n := s.heap_len div 2 downto 1 do - pqdownheap(s, tree^, n); - - { Construct the Huffman tree by repeatedly combining the least two - frequent nodes. } - - node := elems; { next internal node of the tree } - repeat - {pqremove(s, tree, n);} { n := node of least frequency } - n := s.heap[SMALLEST]; - s.heap[SMALLEST] := s.heap[s.heap_len]; - Dec(s.heap_len); - pqdownheap(s, tree^, SMALLEST); - - m := s.heap[SMALLEST]; { m := node of next least frequency } - - Dec(s.heap_max); - s.heap[s.heap_max] := n; { keep the nodes sorted by frequency } - Dec(s.heap_max); - s.heap[s.heap_max] := m; - - { Create a new node father of n and m } - tree^[node].fc.Freq := tree^[n].fc.Freq + tree^[m].fc.Freq; - { maximum } - if (s.depth[n] >= s.depth[m]) then - s.depth[node] := uch (s.depth[n] + 1) - else - s.depth[node] := uch (s.depth[m] + 1); - - tree^[m].dl.Dad := ush(node); - tree^[n].dl.Dad := ush(node); -{$ifdef DUMP_BL_TREE} - if (tree = tree_ptr(@s.bl_tree)) then - begin - WriteLn(#13'node ',node,'(',tree^[node].fc.Freq,') sons ',n, - '(',tree^[n].fc.Freq,') ', m, '(',tree^[m].fc.Freq,')'); - end; -{$endif} - { and insert the new node in the heap } - s.heap[SMALLEST] := node; - Inc(node); - pqdownheap(s, tree^, SMALLEST); - - until (s.heap_len < 2); - - Dec(s.heap_max); - s.heap[s.heap_max] := s.heap[SMALLEST]; - - { At this point, the fields freq and dad are set. We can now - generate the bit lengths. } - - gen_bitlen(s, desc); - - { The field len is now set, we can generate the bit codes } - gen_codes (tree, max_code, s.bl_count); -end; - -{ =========================================================================== - Scan a literal or distance tree to determine the frequencies of the codes - in the bit length tree. } - -{local} -procedure scan_tree(var s : deflate_state; - var tree : array of ct_data; { the tree to be scanned } - max_code : int); { and its largest code of non zero frequency } -var - n : int; { iterates over all tree elements } - prevlen : int; { last emitted length } - curlen : int; { length of current code } - nextlen : int; { length of next code } - count : int; { repeat count of the current code } - max_count : int; { max repeat count } - min_count : int; { min repeat count } -begin - prevlen := -1; - nextlen := tree[0].dl.Len; - count := 0; - max_count := 7; - min_count := 4; - - if (nextlen = 0) then - begin - max_count := 138; - min_count := 3; - end; - tree[max_code+1].dl.Len := ush($ffff); { guard } - - for n := 0 to max_code do - begin - curlen := nextlen; - nextlen := tree[n+1].dl.Len; - Inc(count); - if (count < max_count) and (curlen = nextlen) then - continue - else - if (count < min_count) then - Inc(s.bl_tree[curlen].fc.Freq, count) - else - if (curlen <> 0) then - begin - if (curlen <> prevlen) then - Inc(s.bl_tree[curlen].fc.Freq); - Inc(s.bl_tree[REP_3_6].fc.Freq); - end - else - if (count <= 10) then - Inc(s.bl_tree[REPZ_3_10].fc.Freq) - else - Inc(s.bl_tree[REPZ_11_138].fc.Freq); - - count := 0; - prevlen := curlen; - if (nextlen = 0) then - begin - max_count := 138; - min_count := 3; - end - else - if (curlen = nextlen) then - begin - max_count := 6; - min_count := 3; - end - else - begin - max_count := 7; - min_count := 4; - end; - end; -end; - -{ =========================================================================== - Send a literal or distance tree in compressed form, using the codes in - bl_tree. } - -{local} -procedure send_tree(var s : deflate_state; - var tree : array of ct_data; { the tree to be scanned } - max_code : int); { and its largest code of non zero frequency } - -var - n : int; { iterates over all tree elements } - prevlen : int; { last emitted length } - curlen : int; { length of current code } - nextlen : int; { length of next code } - count : int; { repeat count of the current code } - max_count : int; { max repeat count } - min_count : int; { min repeat count } -begin - prevlen := -1; - nextlen := tree[0].dl.Len; - count := 0; - max_count := 7; - min_count := 4; - - { tree[max_code+1].dl.Len := -1; } { guard already set } - if (nextlen = 0) then - begin - max_count := 138; - min_count := 3; - end; - - for n := 0 to max_code do - begin - curlen := nextlen; - nextlen := tree[n+1].dl.Len; - Inc(count); - if (count < max_count) and (curlen = nextlen) then - continue - else - if (count < min_count) then - begin - repeat - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(curlen)); - {$ENDIF} - send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len); - Dec(count); - until (count = 0); - end - else - if (curlen <> 0) then - begin - if (curlen <> prevlen) then - begin - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(curlen)); - {$ENDIF} - send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len); - Dec(count); - end; - {$IFDEF DEBUG} - Assert((count >= 3) and (count <= 6), ' 3_6?'); - {$ENDIF} - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(REP_3_6)); - {$ENDIF} - send_bits(s, s.bl_tree[REP_3_6].fc.Code, s.bl_tree[REP_3_6].dl.Len); - send_bits(s, count-3, 2); - end - else - if (count <= 10) then - begin - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(REPZ_3_10)); - {$ENDIF} - send_bits(s, s.bl_tree[REPZ_3_10].fc.Code, s.bl_tree[REPZ_3_10].dl.Len); - send_bits(s, count-3, 3); - end - else - begin - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(REPZ_11_138)); - {$ENDIF} - send_bits(s, s.bl_tree[REPZ_11_138].fc.Code, s.bl_tree[REPZ_11_138].dl.Len); - send_bits(s, count-11, 7); - end; - count := 0; - prevlen := curlen; - if (nextlen = 0) then - begin - max_count := 138; - min_count := 3; - end - else - if (curlen = nextlen) then - begin - max_count := 6; - min_count := 3; - end - else - begin - max_count := 7; - min_count := 4; - end; - end; -end; - -{ =========================================================================== - Construct the Huffman tree for the bit lengths and return the index in - bl_order of the last bit length code to send. } - -{local} -function build_bl_tree(var s : deflate_state) : int; -var - max_blindex : int; { index of last bit length code of non zero freq } -begin - { Determine the bit length frequencies for literal and distance trees } - scan_tree(s, s.dyn_ltree, s.l_desc.max_code); - scan_tree(s, s.dyn_dtree, s.d_desc.max_code); - - { Build the bit length tree: } - build_tree(s, s.bl_desc); - { opt_len now includes the length of the tree representations, except - the lengths of the bit lengths codes and the 5+5+4 bits for the counts. } - - { Determine the number of bit length codes to send. The pkzip format - requires that at least 4 bit length codes be sent. (appnote.txt says - 3 but the actual value used is 4.) } - - for max_blindex := BL_CODES-1 downto 3 do - begin - if (s.bl_tree[bl_order[max_blindex]].dl.Len <> 0) then - break; - end; - { Update opt_len to include the bit length tree and counts } - Inc(s.opt_len, 3*(max_blindex+1) + 5+5+4); - {$ifdef DEBUG} - Tracev(^M'dyn trees: dyn %ld, stat %ld {s.opt_len, s.static_len}'); - {$ENDIF} - - build_bl_tree := max_blindex; -end; - -{ =========================================================================== - Send the header for a block using dynamic Huffman trees: the counts, the - lengths of the bit length codes, the literal tree and the distance tree. - IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4. } - -{local} -procedure send_all_trees(var s : deflate_state; - lcodes : int; - dcodes : int; - blcodes : int); { number of codes for each tree } -var - rank : int; { index in bl_order } -begin - {$IFDEF DEBUG} - Assert ((lcodes >= 257) and (dcodes >= 1) and (blcodes >= 4), - 'not enough codes'); - Assert ((lcodes <= L_CODES) and (dcodes <= D_CODES) - and (blcodes <= BL_CODES), 'too many codes'); - Tracev(^M'bl counts: '); - {$ENDIF} - send_bits(s, lcodes-257, 5); { not +255 as stated in appnote.txt } - send_bits(s, dcodes-1, 5); - send_bits(s, blcodes-4, 4); { not -3 as stated in appnote.txt } - for rank := 0 to blcodes-1 do - begin - {$ifdef DEBUG} - Tracev(^M'bl code '+IntToStr(bl_order[rank])); - {$ENDIF} - send_bits(s, s.bl_tree[bl_order[rank]].dl.Len, 3); - end; - {$ifdef DEBUG} - Tracev(^M'bl tree: sent '+IntToStr(s.bits_sent)); - {$ENDIF} - - send_tree(s, s.dyn_ltree, lcodes-1); { literal tree } - {$ifdef DEBUG} - Tracev(^M'lit tree: sent '+IntToStr(s.bits_sent)); - {$ENDIF} - - send_tree(s, s.dyn_dtree, dcodes-1); { distance tree } - {$ifdef DEBUG} - Tracev(^M'dist tree: sent '+IntToStr(s.bits_sent)); - {$ENDIF} -end; - -{ =========================================================================== - Flush the bit buffer and align the output on a byte boundary } - -{local} -procedure bi_windup(var s : deflate_state); -begin - if (s.bi_valid > 8) then - begin - {put_short(s, s.bi_buf);} - s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); - Inc(s.pending); - s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; - Inc(s.pending); - end - else - if (s.bi_valid > 0) then - begin - {put_byte(s, (Byte)s^.bi_buf);} - s.pending_buf^[s.pending] := Byte(s.bi_buf); - Inc(s.pending); - end; - s.bi_buf := 0; - s.bi_valid := 0; -{$ifdef DEBUG} - s.bits_sent := (s.bits_sent+7) and (not 7); -{$endif} -end; - -{ =========================================================================== - Copy a stored block, storing first the length and its - one's complement if requested. } - -{local} -procedure copy_block(var s : deflate_state; - buf : pcharf; { the input data } - len : unsigned; { its length } - header : boolean); { true if block header must be written } -begin - bi_windup(s); { align on byte boundary } - s.last_eob_len := 8; { enough lookahead for inflate } - - if (header) then - begin - {put_short(s, (ush)len);} - s.pending_buf^[s.pending] := uch(ush(len) and $ff); - Inc(s.pending); - s.pending_buf^[s.pending] := uch(ush(len) shr 8);; - Inc(s.pending); - {put_short(s, (ush)~len);} - s.pending_buf^[s.pending] := uch(ush(not len) and $ff); - Inc(s.pending); - s.pending_buf^[s.pending] := uch(ush(not len) shr 8);; - Inc(s.pending); - -{$ifdef DEBUG} - Inc(s.bits_sent, 2*16); -{$endif} - end; -{$ifdef DEBUG} - Inc(s.bits_sent, ulg(len shl 3)); -{$endif} - while (len <> 0) do - begin - Dec(len); - {put_byte(s, *buf++);} - s.pending_buf^[s.pending] := buf^; - Inc(buf); - Inc(s.pending); - end; -end; - - -{ =========================================================================== - Send a stored block } - -procedure _tr_stored_block(var s : deflate_state; - buf : pcharf; { input block } - stored_len : ulg; { length of input block } - eof : boolean); { true if this is the last block for a file } - -begin - send_bits(s, (STORED_BLOCK shl 1)+ord(eof), 3); { send block type } - s.compressed_len := (s.compressed_len + 3 + 7) and ulg(not Long(7)); - Inc(s.compressed_len, (stored_len + 4) shl 3); - - copy_block(s, buf, unsigned(stored_len), TRUE); { with header } -end; - -{ =========================================================================== - Flush the bit buffer, keeping at most 7 bits in it. } - -{local} -procedure bi_flush(var s : deflate_state); -begin - if (s.bi_valid = 16) then - begin - {put_short(s, s.bi_buf);} - s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); - Inc(s.pending); - s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; - Inc(s.pending); - - s.bi_buf := 0; - s.bi_valid := 0; - end - else - if (s.bi_valid >= 8) then - begin - {put_byte(s, (Byte)s^.bi_buf);} - s.pending_buf^[s.pending] := Byte(s.bi_buf); - Inc(s.pending); - - s.bi_buf := s.bi_buf shr 8; - Dec(s.bi_valid, 8); - end; -end; - - -{ =========================================================================== - Send one empty static block to give enough lookahead for inflate. - This takes 10 bits, of which 7 may remain in the bit buffer. - The current inflate code requires 9 bits of lookahead. If the - last two codes for the previous block (real code plus EOB) were coded - on 5 bits or less, inflate may have only 5+3 bits of lookahead to decode - the last real code. In this case we send two empty static blocks instead - of one. (There are no problems if the previous block is stored or fixed.) - To simplify the code, we assume the worst case of last real code encoded - on one bit only. } - -procedure _tr_align(var s : deflate_state); -begin - send_bits(s, STATIC_TREES shl 1, 3); - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(END_BLOCK)); - {$ENDIF} - send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len); - Inc(s.compressed_len, Long(10)); { 3 for block type, 7 for EOB } - bi_flush(s); - { Of the 10 bits for the empty block, we have already sent - (10 - bi_valid) bits. The lookahead for the last real code (before - the EOB of the previous block) was thus at least one plus the length - of the EOB plus what we have just sent of the empty static block. } - if (1 + s.last_eob_len + 10 - s.bi_valid < 9) then - begin - send_bits(s, STATIC_TREES shl 1, 3); - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(END_BLOCK)); - {$ENDIF} - send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len); - Inc(s.compressed_len, Long(10)); - bi_flush(s); - end; - s.last_eob_len := 7; -end; - -{ =========================================================================== - Set the data type to ASCII or BINARY, using a crude approximation: - binary if more than 20% of the bytes are <= 6 or >= 128, ascii otherwise. - IN assertion: the fields freq of dyn_ltree are set and the total of all - frequencies does not exceed 64K (to fit in an int on 16 bit machines). } - -{local} -procedure set_data_type(var s : deflate_state); -var - n : int; - ascii_freq : unsigned; - bin_freq : unsigned; -begin - n := 0; - ascii_freq := 0; - bin_freq := 0; - - while (n < 7) do - begin - Inc(bin_freq, s.dyn_ltree[n].fc.Freq); - Inc(n); - end; - while (n < 128) do - begin - Inc(ascii_freq, s.dyn_ltree[n].fc.Freq); - Inc(n); - end; - while (n < LITERALS) do - begin - Inc(bin_freq, s.dyn_ltree[n].fc.Freq); - Inc(n); - end; - if (bin_freq > (ascii_freq shr 2)) then - s.data_type := Byte(Z_BINARY) - else - s.data_type := Byte(Z_ASCII); -end; - -{ =========================================================================== - Send the block data compressed using the given Huffman trees } - -{local} -procedure compress_block(var s : deflate_state; - var ltree : array of ct_data; { literal tree } - var dtree : array of ct_data); { distance tree } -var - dist : unsigned; { distance of matched string } - lc : int; { match length or unmatched char (if dist == 0) } - lx : unsigned; { running index in l_buf } - code : unsigned; { the code to send } - extra : int; { number of extra bits to send } -begin - lx := 0; - if (s.last_lit <> 0) then - repeat - dist := s.d_buf^[lx]; - lc := s.l_buf^[lx]; - Inc(lx); - if (dist = 0) then - begin - { send a literal byte } - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(lc)); - Tracecv((lc > 31) and (lc < 128), ' '+AnsiChar(lc)+' '); - {$ENDIF} - send_bits(s, ltree[lc].fc.Code, ltree[lc].dl.Len); - end - else - begin - { Here, lc is the match length - MIN_MATCH } - code := _length_code[lc]; - { send the length code } - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(code+LITERALS+1)); - {$ENDIF} - send_bits(s, ltree[code+LITERALS+1].fc.Code, ltree[code+LITERALS+1].dl.Len); - extra := extra_lbits[code]; - if (extra <> 0) then - begin - Dec(lc, base_length[code]); - send_bits(s, lc, extra); { send the extra length bits } - end; - Dec(dist); { dist is now the match distance - 1 } - {code := d_code(dist);} - if (dist < 256) then - code := _dist_code[dist] - else - code := _dist_code[256+(dist shr 7)]; - - {$IFDEF DEBUG} - Assert (code < D_CODES, 'bad d_code'); - {$ENDIF} - - { send the distance code } - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(code)); - {$ENDIF} - send_bits(s, dtree[code].fc.Code, dtree[code].dl.Len); - extra := extra_dbits[code]; - if (extra <> 0) then - begin - Dec(dist, base_dist[code]); - send_bits(s, dist, extra); { send the extra distance bits } - end; - end; { literal or match pair ? } - - { Check that the overlay between pending_buf and d_buf+l_buf is ok: } - {$IFDEF DEBUG} - Assert(s.pending < s.lit_bufsize + 2*lx, 'pendingBuf overflow'); - {$ENDIF} - until (lx >= s.last_lit); - - {$ifdef DEBUG} - Tracevvv(#13'cd '+IntToStr(END_BLOCK)); - {$ENDIF} - send_bits(s, ltree[END_BLOCK].fc.Code, ltree[END_BLOCK].dl.Len); - s.last_eob_len := ltree[END_BLOCK].dl.Len; -end; - - -{ =========================================================================== - Determine the best encoding for the current block: dynamic trees, static - trees or store, and output the encoded block to the zip file. This function - returns the total compressed length for the file so far. } - -function _tr_flush_block (var s : deflate_state; - buf : pcharf; { input block, or NULL if too old } - stored_len : ulg; { length of input block } - eof : boolean) : ulg; { true if this is the last block for a file } -var - opt_lenb, static_lenb : ulg; { opt_len and static_len in bytes } - max_blindex : int; { index of last bit length code of non zero freq } -begin - max_blindex := 0; - - { Build the Huffman trees unless a stored block is forced } - if (s.level > 0) then - begin - { Check if the file is ascii or binary } - if (s.data_type = Z_UNKNOWN) then - set_data_type(s); - - { Construct the literal and distance trees } - build_tree(s, s.l_desc); - {$ifdef DEBUG} - Tracev(^M'lit data: dyn %ld, stat %ld {s.opt_len, s.static_len}'); - {$ENDIF} - - build_tree(s, s.d_desc); - {$ifdef DEBUG} - Tracev(^M'dist data: dyn %ld, stat %ld {s.opt_len, s.static_len}'); - {$ENDIF} - { At this point, opt_len and static_len are the total bit lengths of - the compressed block data, excluding the tree representations. } - - { Build the bit length tree for the above two trees, and get the index - in bl_order of the last bit length code to send. } - max_blindex := build_bl_tree(s); - - { Determine the best encoding. Compute first the block length in bytes} - opt_lenb := (s.opt_len+3+7) shr 3; - static_lenb := (s.static_len+3+7) shr 3; - - {$ifdef DEBUG} - Tracev(^M'opt %lu(%lu) stat %lu(%lu) stored %lu lit %u '+ - '{opt_lenb, s.opt_len, static_lenb, s.static_len, stored_len,'+ - 's.last_lit}'); - {$ENDIF} - - if (static_lenb <= opt_lenb) then - opt_lenb := static_lenb; - - end - else - begin - {$IFDEF DEBUG} - Assert(buf <> pcharf(NIL), 'lost buf'); - {$ENDIF} - static_lenb := stored_len + 5; - opt_lenb := static_lenb; { force a stored block } - end; - - { If compression failed and this is the first and last block, - and if the .zip file can be seeked (to rewrite the local header), - the whole file is transformed into a stored file: } - -{$ifdef STORED_FILE_OK} -{$ifdef FORCE_STORED_FILE} - if eof and (s.compressed_len = Long(0)) then - begin { force stored file } -{$else} - if (stored_len <= opt_lenb) and eof and (s.compressed_len=Long(0)) - and seekable()) do - begin -{$endif} - { Since LIT_BUFSIZE <= 2*WSIZE, the input data must be there: } - if (buf = pcharf(0)) then - error ('block vanished'); - - copy_block(buf, unsigned(stored_len), 0); { without header } - s.compressed_len := stored_len shl 3; - s.method := STORED; - end - else -{$endif} { STORED_FILE_OK } - -{$ifdef FORCE_STORED} - if (buf <> pcharf(0)) then - begin { force stored block } -{$else} - if (stored_len+4 <= opt_lenb) and (buf <> pcharf(0)) then - begin - { 4: two words for the lengths } -{$endif} - { The test buf <> NULL is only necessary if LIT_BUFSIZE > WSIZE. - Otherwise we can't have processed more than WSIZE input bytes since - the last block flush, because compression would have been - successful. If LIT_BUFSIZE <= WSIZE, it is never too late to - transform a block into a stored block. } - - _tr_stored_block(s, buf, stored_len, eof); - -{$ifdef FORCE_STATIC} - end - else - if (static_lenb >= 0) then - begin { force static trees } -{$else} - end - else - if (static_lenb = opt_lenb) then - begin -{$endif} - send_bits(s, (STATIC_TREES shl 1)+ord(eof), 3); - compress_block(s, static_ltree, static_dtree); - Inc(s.compressed_len, 3 + s.static_len); - end - else - begin - send_bits(s, (DYN_TREES shl 1)+ord(eof), 3); - send_all_trees(s, s.l_desc.max_code+1, s.d_desc.max_code+1, - max_blindex+1); - compress_block(s, s.dyn_ltree, s.dyn_dtree); - Inc(s.compressed_len, 3 + s.opt_len); - end; - {$ifdef DEBUG} - Assert (s.compressed_len = s.bits_sent, 'bad compressed size'); - {$ENDIF} - init_block(s); - - if (eof) then - begin - bi_windup(s); - Inc(s.compressed_len, 7); { align on byte boundary } - end; - {$ifdef DEBUG} - Tracev(#13'comprlen %lu(%lu) {s.compressed_len shr 3,'+ - 's.compressed_len-7*ord(eof)}'); - {$ENDIF} - - _tr_flush_block := s.compressed_len shr 3; -end; - - -{ =========================================================================== - Save the match info and tally the frequency counts. Return true if - the current block must be flushed. } - -function _tr_tally (var s : deflate_state; - dist : unsigned; { distance of matched string } - lc : unsigned) : boolean; { match length-MIN_MATCH or unmatched char (if dist=0) } -var - {$IFDEF DEBUG} - MAX_DIST : ush; - {$ENDIF} - code : ush; -{$ifdef TRUNCATE_BLOCK} -var - out_length : ulg; - in_length : ulg; - dcode : int; -{$endif} -begin - s.d_buf^[s.last_lit] := ush(dist); - s.l_buf^[s.last_lit] := uch(lc); - Inc(s.last_lit); - if (dist = 0) then - begin - { lc is the unmatched char } - Inc(s.dyn_ltree[lc].fc.Freq); - end - else - begin - Inc(s.matches); - { Here, lc is the match length - MIN_MATCH } - Dec(dist); { dist := match distance - 1 } - - {macro d_code(dist)} - if (dist) < 256 then - code := _dist_code[dist] - else - code := _dist_code[256+(dist shr 7)]; - {$IFDEF DEBUG} -{macro MAX_DIST(s) <=> ((s)^.w_size-MIN_LOOKAHEAD) - In order to simplify the code, particularly on 16 bit machines, match - distances are limited to MAX_DIST instead of WSIZE. } - MAX_DIST := ush(s.w_size-MIN_LOOKAHEAD); - Assert((dist < ush(MAX_DIST)) and - (ush(lc) <= ush(MAX_MATCH-MIN_MATCH)) and - (ush(code) < ush(D_CODES)), '_tr_tally: bad match'); - {$ENDIF} - Inc(s.dyn_ltree[_length_code[lc]+LITERALS+1].fc.Freq); - {s.dyn_dtree[d_code(dist)].Freq++;} - Inc(s.dyn_dtree[code].fc.Freq); - end; - -{$ifdef TRUNCATE_BLOCK} - { Try to guess if it is profitable to stop the current block here } - if (s.last_lit and $1fff = 0) and (s.level > 2) then - begin - { Compute an upper bound for the compressed length } - out_length := ulg(s.last_lit)*Long(8); - in_length := ulg(long(s.strstart) - s.block_start); - for dcode := 0 to D_CODES-1 do - begin - Inc(out_length, ulg(s.dyn_dtree[dcode].fc.Freq * - (Long(5)+extra_dbits[dcode])) ); - end; - out_length := out_length shr 3; - {$ifdef DEBUG} - Tracev(^M'last_lit %u, in %ld, out ~%ld(%ld%%) '); - { s.last_lit, in_length, out_length, - Long(100) - out_length*Long(100) div in_length)); } - {$ENDIF} - if (s.matches < s.last_lit div 2) and (out_length < in_length div 2) then - begin - _tr_tally := TRUE; - exit; - end; - end; -{$endif} - _tr_tally := (s.last_lit = s.lit_bufsize-1); - { We avoid equality with lit_bufsize because of wraparound at 64K - on 16 bit machines and because stored blocks are restricted to - 64K-1 bytes. } -end; - +Unit imtrees; + +{$T-} +{$define ORG_DEBUG} +{ + trees.c -- output deflated data using Huffman coding + Copyright (C) 1995-1998 Jean-loup Gailly + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +{ + * ALGORITHM + * + * The "deflation" process uses several Huffman trees. The more + * common source values are represented by shorter bit sequences. + * + * Each code tree is stored in a compressed form which is itself + * a Huffman encoding of the lengths of all the code strings (in + * ascending order by source values). The actual code strings are + * reconstructed from the lengths in the inflate process, as described + * in the deflate specification. + * + * REFERENCES + * + * Deutsch, L.P.,"'Deflate' Compressed Data Format Specification". + * Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc + * + * Storer, James A. + * Data Compression: Methods and Theory, pp. 49-50. + * Computer Science Press, 1988. ISBN 0-7167-8156-5. + * + * Sedgewick, R. + * Algorithms, p290. + * Addison-Wesley, 1983. ISBN 0-201-06672-6. + } + +interface + +{$I imzconf.inc} + +uses + {$ifdef DEBUG} + SysUtils, strutils, + {$ENDIF} + imzutil, impaszlib; + +{ =========================================================================== + Internal compression state. } + +const + LENGTH_CODES = 29; +{ number of length codes, not counting the special END_BLOCK code } + + LITERALS = 256; +{ number of literal bytes 0..255 } + + L_CODES = (LITERALS+1+LENGTH_CODES); +{ number of Literal or Length codes, including the END_BLOCK code } + + D_CODES = 30; +{ number of distance codes } + + BL_CODES = 19; +{ number of codes used to transfer the bit lengths } + + HEAP_SIZE = (2*L_CODES+1); +{ maximum heap size } + + MAX_BITS = 15; +{ All codes must not exceed MAX_BITS bits } + +const + INIT_STATE = 42; + BUSY_STATE = 113; + FINISH_STATE = 666; +{ Stream status } + + +{ Data structure describing a single value and its code string. } +type + ct_data_ptr = ^ct_data; + ct_data = record + fc : record + case byte of + 0:(freq : ush); { frequency count } + 1:(code : ush); { bit string } + end; + dl : record + case byte of + 0:(dad : ush); { father node in Huffman tree } + 1:(len : ush); { length of bit string } + end; + end; + +{ Freq = fc.freq + Code = fc.code + Dad = dl.dad + Len = dl.len } + +type + ltree_type = array[0..HEAP_SIZE-1] of ct_data; { literal and length tree } + dtree_type = array[0..2*D_CODES+1-1] of ct_data; { distance tree } + htree_type = array[0..2*BL_CODES+1-1] of ct_data; { Huffman tree for bit lengths } + { generic tree type } + tree_type = array[0..(MaxInt div SizeOf(ct_data))-1] of ct_data; + + tree_ptr = ^tree_type; + ltree_ptr = ^ltree_type; + dtree_ptr = ^dtree_type; + htree_ptr = ^htree_type; + + +type + static_tree_desc_ptr = ^static_tree_desc; + static_tree_desc = + record + {const} static_tree : tree_ptr; { static tree or NIL } + {const} extra_bits : pzIntfArray; { extra bits for each code or NIL } + extra_base : int; { base index for extra_bits } + elems : int; { max number of elements in the tree } + max_length : int; { max bit length for the codes } + end; + + tree_desc_ptr = ^tree_desc; + tree_desc = record + dyn_tree : tree_ptr; { the dynamic tree } + max_code : int; { largest code with non zero frequency } + stat_desc : static_tree_desc_ptr; { the corresponding static tree } + end; + +type + Pos = ush; + Posf = Pos; {FAR} + IPos = uInt; + + pPosf = ^Posf; + + zPosfArray = array[0..(MaxInt div SizeOf(Posf))-1] of Posf; + pzPosfArray = ^zPosfArray; + +{ A Pos is an index in the character window. We use short instead of int to + save space in the various tables. IPos is used only for parameter passing.} + +type + deflate_state_ptr = ^deflate_state; + deflate_state = record + strm : z_streamp; { pointer back to this zlib stream } + status : int; { as the name implies } + pending_buf : pzByteArray; { output still pending } + pending_buf_size : ulg; { size of pending_buf } + pending_out : pBytef; { next pending byte to output to the stream } + pending : int; { nb of bytes in the pending buffer } + noheader : int; { suppress zlib header and adler32 } + data_type : Byte; { UNKNOWN, BINARY or ASCII } + method : Byte; { STORED (for zip only) or DEFLATED } + last_flush : int; { value of flush param for previous deflate call } + + { used by deflate.pas: } + + w_size : uInt; { LZ77 window size (32K by default) } + w_bits : uInt; { log2(w_size) (8..16) } + w_mask : uInt; { w_size - 1 } + + window : pzByteArray; + { Sliding window. Input bytes are read into the second half of the window, + and move to the first half later to keep a dictionary of at least wSize + bytes. With this organization, matches are limited to a distance of + wSize-MAX_MATCH bytes, but this ensures that IO is always + performed with a length multiple of the block size. Also, it limits + the window size to 64K, which is quite useful on MSDOS. + To do: use the user input buffer as sliding window. } + + window_size : ulg; + { Actual size of window: 2*wSize, except when the user input buffer + is directly used as sliding window. } + + prev : pzPosfArray; + { Link to older string with same hash index. To limit the size of this + array to 64K, this link is maintained only for the last 32K strings. + An index in this array is thus a window index modulo 32K. } + + head : pzPosfArray; { Heads of the hash chains or NIL. } + + ins_h : uInt; { hash index of string to be inserted } + hash_size : uInt; { number of elements in hash table } + hash_bits : uInt; { log2(hash_size) } + hash_mask : uInt; { hash_size-1 } + + hash_shift : uInt; + { Number of bits by which ins_h must be shifted at each input + step. It must be such that after MIN_MATCH steps, the oldest + byte no longer takes part in the hash key, that is: + hash_shift * MIN_MATCH >= hash_bits } + + block_start : long; + { Window position at the beginning of the current output block. Gets + negative when the window is moved backwards. } + + match_length : uInt; { length of best match } + prev_match : IPos; { previous match } + match_available : boolean; { set if previous match exists } + strstart : uInt; { start of string to insert } + match_start : uInt; { start of matching string } + lookahead : uInt; { number of valid bytes ahead in window } + + prev_length : uInt; + { Length of the best match at previous step. Matches not greater than this + are discarded. This is used in the lazy match evaluation. } + + max_chain_length : uInt; + { To speed up deflation, hash chains are never searched beyond this + length. A higher limit improves compression ratio but degrades the + speed. } + + { moved to the end because Borland Pascal won't accept the following: + max_lazy_match : uInt; + max_insert_length : uInt absolute max_lazy_match; + } + + level : int; { compression level (1..9) } + strategy : int; { favor or force Huffman coding} + + good_match : uInt; + { Use a faster search when the previous match is longer than this } + + nice_match : int; { Stop searching when current match exceeds this } + + { used by trees.pas: } + { Didn't use ct_data typedef below to supress compiler warning } + dyn_ltree : ltree_type; { literal and length tree } + dyn_dtree : dtree_type; { distance tree } + bl_tree : htree_type; { Huffman tree for bit lengths } + + l_desc : tree_desc; { desc. for literal tree } + d_desc : tree_desc; { desc. for distance tree } + bl_desc : tree_desc; { desc. for bit length tree } + + bl_count : array[0..MAX_BITS+1-1] of ush; + { number of codes at each bit length for an optimal tree } + + heap : array[0..2*L_CODES+1-1] of int; { heap used to build the Huffman trees } + heap_len : int; { number of elements in the heap } + heap_max : int; { element of largest frequency } + { The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used. + The same heap array is used to build all trees. } + + depth : array[0..2*L_CODES+1-1] of uch; + { Depth of each subtree used as tie breaker for trees of equal frequency } + + + l_buf : puchfArray; { buffer for literals or lengths } + + lit_bufsize : uInt; + { Size of match buffer for literals/lengths. There are 4 reasons for + limiting lit_bufsize to 64K: + - frequencies can be kept in 16 bit counters + - if compression is not successful for the first block, all input + data is still in the window so we can still emit a stored block even + when input comes from standard input. (This can also be done for + all blocks if lit_bufsize is not greater than 32K.) + - if compression is not successful for a file smaller than 64K, we can + even emit a stored file instead of a stored block (saving 5 bytes). + This is applicable only for zip (not gzip or zlib). + - creating new Huffman trees less frequently may not provide fast + adaptation to changes in the input data statistics. (Take for + example a binary file with poorly compressible code followed by + a highly compressible string table.) Smaller buffer sizes give + fast adaptation but have of course the overhead of transmitting + trees more frequently. + - I can't count above 4 } + + + last_lit : uInt; { running index in l_buf } + + d_buf : pushfArray; + { Buffer for distances. To simplify the code, d_buf and l_buf have + the same number of elements. To use different lengths, an extra flag + array would be necessary. } + + opt_len : ulg; { bit length of current block with optimal trees } + static_len : ulg; { bit length of current block with static trees } + compressed_len : ulg; { total bit length of compressed file } + matches : uInt; { number of string matches in current block } + last_eob_len : int; { bit length of EOB code for last block } + +{$ifdef DEBUG} + bits_sent : ulg; { bit length of the compressed data } +{$endif} + + bi_buf : ush; + { Output buffer. bits are inserted starting at the bottom (least + significant bits). } + + bi_valid : int; + { Number of valid bits in bi_buf. All bits above the last valid bit + are always zero. } + + case byte of + 0:(max_lazy_match : uInt); + { Attempt to find a better match only when the current match is strictly + smaller than this value. This mechanism is used only for compression + levels >= 4. } + + 1:(max_insert_length : uInt); + { Insert new strings in the hash table only if the match length is not + greater than this length. This saves time but degrades compression. + max_insert_length is used only for compression levels <= 3. } + end; + +procedure _tr_init (var s : deflate_state); + +function _tr_tally (var s : deflate_state; + dist : unsigned; + lc : unsigned) : boolean; + +function _tr_flush_block (var s : deflate_state; + buf : pcharf; + stored_len : ulg; + eof : boolean) : ulg; + +procedure _tr_align(var s : deflate_state); + +procedure _tr_stored_block(var s : deflate_state; + buf : pcharf; + stored_len : ulg; + eof : boolean); + +implementation + +{ #define GEN_TREES_H } + +{$ifndef GEN_TREES_H} +{ header created automatically with -DGEN_TREES_H } + +const + DIST_CODE_LEN = 512; { see definition of array dist_code below } + +{ The static literal tree. Since the bit lengths are imposed, there is no + need for the L_CODES extra codes used during heap construction. However + The codes 286 and 287 are needed to build a canonical tree (see _tr_init + below). } +var + static_ltree : array[0..L_CODES+2-1] of ct_data = ( +{ fc:(freq, code) dl:(dad,len) } +(fc:(freq: 12);dl:(len: 8)), (fc:(freq:140);dl:(len: 8)), (fc:(freq: 76);dl:(len: 8)), +(fc:(freq:204);dl:(len: 8)), (fc:(freq: 44);dl:(len: 8)), (fc:(freq:172);dl:(len: 8)), +(fc:(freq:108);dl:(len: 8)), (fc:(freq:236);dl:(len: 8)), (fc:(freq: 28);dl:(len: 8)), +(fc:(freq:156);dl:(len: 8)), (fc:(freq: 92);dl:(len: 8)), (fc:(freq:220);dl:(len: 8)), +(fc:(freq: 60);dl:(len: 8)), (fc:(freq:188);dl:(len: 8)), (fc:(freq:124);dl:(len: 8)), +(fc:(freq:252);dl:(len: 8)), (fc:(freq: 2);dl:(len: 8)), (fc:(freq:130);dl:(len: 8)), +(fc:(freq: 66);dl:(len: 8)), (fc:(freq:194);dl:(len: 8)), (fc:(freq: 34);dl:(len: 8)), +(fc:(freq:162);dl:(len: 8)), (fc:(freq: 98);dl:(len: 8)), (fc:(freq:226);dl:(len: 8)), +(fc:(freq: 18);dl:(len: 8)), (fc:(freq:146);dl:(len: 8)), (fc:(freq: 82);dl:(len: 8)), +(fc:(freq:210);dl:(len: 8)), (fc:(freq: 50);dl:(len: 8)), (fc:(freq:178);dl:(len: 8)), +(fc:(freq:114);dl:(len: 8)), (fc:(freq:242);dl:(len: 8)), (fc:(freq: 10);dl:(len: 8)), +(fc:(freq:138);dl:(len: 8)), (fc:(freq: 74);dl:(len: 8)), (fc:(freq:202);dl:(len: 8)), +(fc:(freq: 42);dl:(len: 8)), (fc:(freq:170);dl:(len: 8)), (fc:(freq:106);dl:(len: 8)), +(fc:(freq:234);dl:(len: 8)), (fc:(freq: 26);dl:(len: 8)), (fc:(freq:154);dl:(len: 8)), +(fc:(freq: 90);dl:(len: 8)), (fc:(freq:218);dl:(len: 8)), (fc:(freq: 58);dl:(len: 8)), +(fc:(freq:186);dl:(len: 8)), (fc:(freq:122);dl:(len: 8)), (fc:(freq:250);dl:(len: 8)), +(fc:(freq: 6);dl:(len: 8)), (fc:(freq:134);dl:(len: 8)), (fc:(freq: 70);dl:(len: 8)), +(fc:(freq:198);dl:(len: 8)), (fc:(freq: 38);dl:(len: 8)), (fc:(freq:166);dl:(len: 8)), +(fc:(freq:102);dl:(len: 8)), (fc:(freq:230);dl:(len: 8)), (fc:(freq: 22);dl:(len: 8)), +(fc:(freq:150);dl:(len: 8)), (fc:(freq: 86);dl:(len: 8)), (fc:(freq:214);dl:(len: 8)), +(fc:(freq: 54);dl:(len: 8)), (fc:(freq:182);dl:(len: 8)), (fc:(freq:118);dl:(len: 8)), +(fc:(freq:246);dl:(len: 8)), (fc:(freq: 14);dl:(len: 8)), (fc:(freq:142);dl:(len: 8)), +(fc:(freq: 78);dl:(len: 8)), (fc:(freq:206);dl:(len: 8)), (fc:(freq: 46);dl:(len: 8)), +(fc:(freq:174);dl:(len: 8)), (fc:(freq:110);dl:(len: 8)), (fc:(freq:238);dl:(len: 8)), +(fc:(freq: 30);dl:(len: 8)), (fc:(freq:158);dl:(len: 8)), (fc:(freq: 94);dl:(len: 8)), +(fc:(freq:222);dl:(len: 8)), (fc:(freq: 62);dl:(len: 8)), (fc:(freq:190);dl:(len: 8)), +(fc:(freq:126);dl:(len: 8)), (fc:(freq:254);dl:(len: 8)), (fc:(freq: 1);dl:(len: 8)), +(fc:(freq:129);dl:(len: 8)), (fc:(freq: 65);dl:(len: 8)), (fc:(freq:193);dl:(len: 8)), +(fc:(freq: 33);dl:(len: 8)), (fc:(freq:161);dl:(len: 8)), (fc:(freq: 97);dl:(len: 8)), +(fc:(freq:225);dl:(len: 8)), (fc:(freq: 17);dl:(len: 8)), (fc:(freq:145);dl:(len: 8)), +(fc:(freq: 81);dl:(len: 8)), (fc:(freq:209);dl:(len: 8)), (fc:(freq: 49);dl:(len: 8)), +(fc:(freq:177);dl:(len: 8)), (fc:(freq:113);dl:(len: 8)), (fc:(freq:241);dl:(len: 8)), +(fc:(freq: 9);dl:(len: 8)), (fc:(freq:137);dl:(len: 8)), (fc:(freq: 73);dl:(len: 8)), +(fc:(freq:201);dl:(len: 8)), (fc:(freq: 41);dl:(len: 8)), (fc:(freq:169);dl:(len: 8)), +(fc:(freq:105);dl:(len: 8)), (fc:(freq:233);dl:(len: 8)), (fc:(freq: 25);dl:(len: 8)), +(fc:(freq:153);dl:(len: 8)), (fc:(freq: 89);dl:(len: 8)), (fc:(freq:217);dl:(len: 8)), +(fc:(freq: 57);dl:(len: 8)), (fc:(freq:185);dl:(len: 8)), (fc:(freq:121);dl:(len: 8)), +(fc:(freq:249);dl:(len: 8)), (fc:(freq: 5);dl:(len: 8)), (fc:(freq:133);dl:(len: 8)), +(fc:(freq: 69);dl:(len: 8)), (fc:(freq:197);dl:(len: 8)), (fc:(freq: 37);dl:(len: 8)), +(fc:(freq:165);dl:(len: 8)), (fc:(freq:101);dl:(len: 8)), (fc:(freq:229);dl:(len: 8)), +(fc:(freq: 21);dl:(len: 8)), (fc:(freq:149);dl:(len: 8)), (fc:(freq: 85);dl:(len: 8)), +(fc:(freq:213);dl:(len: 8)), (fc:(freq: 53);dl:(len: 8)), (fc:(freq:181);dl:(len: 8)), +(fc:(freq:117);dl:(len: 8)), (fc:(freq:245);dl:(len: 8)), (fc:(freq: 13);dl:(len: 8)), +(fc:(freq:141);dl:(len: 8)), (fc:(freq: 77);dl:(len: 8)), (fc:(freq:205);dl:(len: 8)), +(fc:(freq: 45);dl:(len: 8)), (fc:(freq:173);dl:(len: 8)), (fc:(freq:109);dl:(len: 8)), +(fc:(freq:237);dl:(len: 8)), (fc:(freq: 29);dl:(len: 8)), (fc:(freq:157);dl:(len: 8)), +(fc:(freq: 93);dl:(len: 8)), (fc:(freq:221);dl:(len: 8)), (fc:(freq: 61);dl:(len: 8)), +(fc:(freq:189);dl:(len: 8)), (fc:(freq:125);dl:(len: 8)), (fc:(freq:253);dl:(len: 8)), +(fc:(freq: 19);dl:(len: 9)), (fc:(freq:275);dl:(len: 9)), (fc:(freq:147);dl:(len: 9)), +(fc:(freq:403);dl:(len: 9)), (fc:(freq: 83);dl:(len: 9)), (fc:(freq:339);dl:(len: 9)), +(fc:(freq:211);dl:(len: 9)), (fc:(freq:467);dl:(len: 9)), (fc:(freq: 51);dl:(len: 9)), +(fc:(freq:307);dl:(len: 9)), (fc:(freq:179);dl:(len: 9)), (fc:(freq:435);dl:(len: 9)), +(fc:(freq:115);dl:(len: 9)), (fc:(freq:371);dl:(len: 9)), (fc:(freq:243);dl:(len: 9)), +(fc:(freq:499);dl:(len: 9)), (fc:(freq: 11);dl:(len: 9)), (fc:(freq:267);dl:(len: 9)), +(fc:(freq:139);dl:(len: 9)), (fc:(freq:395);dl:(len: 9)), (fc:(freq: 75);dl:(len: 9)), +(fc:(freq:331);dl:(len: 9)), (fc:(freq:203);dl:(len: 9)), (fc:(freq:459);dl:(len: 9)), +(fc:(freq: 43);dl:(len: 9)), (fc:(freq:299);dl:(len: 9)), (fc:(freq:171);dl:(len: 9)), +(fc:(freq:427);dl:(len: 9)), (fc:(freq:107);dl:(len: 9)), (fc:(freq:363);dl:(len: 9)), +(fc:(freq:235);dl:(len: 9)), (fc:(freq:491);dl:(len: 9)), (fc:(freq: 27);dl:(len: 9)), +(fc:(freq:283);dl:(len: 9)), (fc:(freq:155);dl:(len: 9)), (fc:(freq:411);dl:(len: 9)), +(fc:(freq: 91);dl:(len: 9)), (fc:(freq:347);dl:(len: 9)), (fc:(freq:219);dl:(len: 9)), +(fc:(freq:475);dl:(len: 9)), (fc:(freq: 59);dl:(len: 9)), (fc:(freq:315);dl:(len: 9)), +(fc:(freq:187);dl:(len: 9)), (fc:(freq:443);dl:(len: 9)), (fc:(freq:123);dl:(len: 9)), +(fc:(freq:379);dl:(len: 9)), (fc:(freq:251);dl:(len: 9)), (fc:(freq:507);dl:(len: 9)), +(fc:(freq: 7);dl:(len: 9)), (fc:(freq:263);dl:(len: 9)), (fc:(freq:135);dl:(len: 9)), +(fc:(freq:391);dl:(len: 9)), (fc:(freq: 71);dl:(len: 9)), (fc:(freq:327);dl:(len: 9)), +(fc:(freq:199);dl:(len: 9)), (fc:(freq:455);dl:(len: 9)), (fc:(freq: 39);dl:(len: 9)), +(fc:(freq:295);dl:(len: 9)), (fc:(freq:167);dl:(len: 9)), (fc:(freq:423);dl:(len: 9)), +(fc:(freq:103);dl:(len: 9)), (fc:(freq:359);dl:(len: 9)), (fc:(freq:231);dl:(len: 9)), +(fc:(freq:487);dl:(len: 9)), (fc:(freq: 23);dl:(len: 9)), (fc:(freq:279);dl:(len: 9)), +(fc:(freq:151);dl:(len: 9)), (fc:(freq:407);dl:(len: 9)), (fc:(freq: 87);dl:(len: 9)), +(fc:(freq:343);dl:(len: 9)), (fc:(freq:215);dl:(len: 9)), (fc:(freq:471);dl:(len: 9)), +(fc:(freq: 55);dl:(len: 9)), (fc:(freq:311);dl:(len: 9)), (fc:(freq:183);dl:(len: 9)), +(fc:(freq:439);dl:(len: 9)), (fc:(freq:119);dl:(len: 9)), (fc:(freq:375);dl:(len: 9)), +(fc:(freq:247);dl:(len: 9)), (fc:(freq:503);dl:(len: 9)), (fc:(freq: 15);dl:(len: 9)), +(fc:(freq:271);dl:(len: 9)), (fc:(freq:143);dl:(len: 9)), (fc:(freq:399);dl:(len: 9)), +(fc:(freq: 79);dl:(len: 9)), (fc:(freq:335);dl:(len: 9)), (fc:(freq:207);dl:(len: 9)), +(fc:(freq:463);dl:(len: 9)), (fc:(freq: 47);dl:(len: 9)), (fc:(freq:303);dl:(len: 9)), +(fc:(freq:175);dl:(len: 9)), (fc:(freq:431);dl:(len: 9)), (fc:(freq:111);dl:(len: 9)), +(fc:(freq:367);dl:(len: 9)), (fc:(freq:239);dl:(len: 9)), (fc:(freq:495);dl:(len: 9)), +(fc:(freq: 31);dl:(len: 9)), (fc:(freq:287);dl:(len: 9)), (fc:(freq:159);dl:(len: 9)), +(fc:(freq:415);dl:(len: 9)), (fc:(freq: 95);dl:(len: 9)), (fc:(freq:351);dl:(len: 9)), +(fc:(freq:223);dl:(len: 9)), (fc:(freq:479);dl:(len: 9)), (fc:(freq: 63);dl:(len: 9)), +(fc:(freq:319);dl:(len: 9)), (fc:(freq:191);dl:(len: 9)), (fc:(freq:447);dl:(len: 9)), +(fc:(freq:127);dl:(len: 9)), (fc:(freq:383);dl:(len: 9)), (fc:(freq:255);dl:(len: 9)), +(fc:(freq:511);dl:(len: 9)), (fc:(freq: 0);dl:(len: 7)), (fc:(freq: 64);dl:(len: 7)), +(fc:(freq: 32);dl:(len: 7)), (fc:(freq: 96);dl:(len: 7)), (fc:(freq: 16);dl:(len: 7)), +(fc:(freq: 80);dl:(len: 7)), (fc:(freq: 48);dl:(len: 7)), (fc:(freq:112);dl:(len: 7)), +(fc:(freq: 8);dl:(len: 7)), (fc:(freq: 72);dl:(len: 7)), (fc:(freq: 40);dl:(len: 7)), +(fc:(freq:104);dl:(len: 7)), (fc:(freq: 24);dl:(len: 7)), (fc:(freq: 88);dl:(len: 7)), +(fc:(freq: 56);dl:(len: 7)), (fc:(freq:120);dl:(len: 7)), (fc:(freq: 4);dl:(len: 7)), +(fc:(freq: 68);dl:(len: 7)), (fc:(freq: 36);dl:(len: 7)), (fc:(freq:100);dl:(len: 7)), +(fc:(freq: 20);dl:(len: 7)), (fc:(freq: 84);dl:(len: 7)), (fc:(freq: 52);dl:(len: 7)), +(fc:(freq:116);dl:(len: 7)), (fc:(freq: 3);dl:(len: 8)), (fc:(freq:131);dl:(len: 8)), +(fc:(freq: 67);dl:(len: 8)), (fc:(freq:195);dl:(len: 8)), (fc:(freq: 35);dl:(len: 8)), +(fc:(freq:163);dl:(len: 8)), (fc:(freq: 99);dl:(len: 8)), (fc:(freq:227);dl:(len: 8)) +); + + +{ The static distance tree. (Actually a trivial tree since all lens use + 5 bits.) } + static_dtree : array[0..D_CODES-1] of ct_data = ( +(fc:(freq: 0); dl:(len:5)), (fc:(freq:16); dl:(len:5)), (fc:(freq: 8); dl:(len:5)), +(fc:(freq:24); dl:(len:5)), (fc:(freq: 4); dl:(len:5)), (fc:(freq:20); dl:(len:5)), +(fc:(freq:12); dl:(len:5)), (fc:(freq:28); dl:(len:5)), (fc:(freq: 2); dl:(len:5)), +(fc:(freq:18); dl:(len:5)), (fc:(freq:10); dl:(len:5)), (fc:(freq:26); dl:(len:5)), +(fc:(freq: 6); dl:(len:5)), (fc:(freq:22); dl:(len:5)), (fc:(freq:14); dl:(len:5)), +(fc:(freq:30); dl:(len:5)), (fc:(freq: 1); dl:(len:5)), (fc:(freq:17); dl:(len:5)), +(fc:(freq: 9); dl:(len:5)), (fc:(freq:25); dl:(len:5)), (fc:(freq: 5); dl:(len:5)), +(fc:(freq:21); dl:(len:5)), (fc:(freq:13); dl:(len:5)), (fc:(freq:29); dl:(len:5)), +(fc:(freq: 3); dl:(len:5)), (fc:(freq:19); dl:(len:5)), (fc:(freq:11); dl:(len:5)), +(fc:(freq:27); dl:(len:5)), (fc:(freq: 7); dl:(len:5)), (fc:(freq:23); dl:(len:5)) +); + +{ Distance codes. The first 256 values correspond to the distances + 3 .. 258, the last 256 values correspond to the top 8 bits of + the 15 bit distances. } + _dist_code : array[0..DIST_CODE_LEN-1] of uch = ( + 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8, + 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10, +10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, +11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, +12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13, +13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, +13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, +14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, +15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17, +18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22, +23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, +28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, +29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29 +); + +{ length code for each normalized match length (0 == MIN_MATCH) } + _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch = ( + 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12, +13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16, +17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19, +19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, +21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22, +22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23, +23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, +25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, +25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, +26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, +27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28 +); + + +{ First normalized length for each code (0 = MIN_MATCH) } + base_length : array[0..LENGTH_CODES-1] of int = ( +0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56, +64, 80, 96, 112, 128, 160, 192, 224, 0 +); + + +{ First normalized distance for each code (0 = distance of 1) } + base_dist : array[0..D_CODES-1] of int = ( + 0, 1, 2, 3, 4, 6, 8, 12, 16, 24, + 32, 48, 64, 96, 128, 192, 256, 384, 512, 768, + 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576 +); +{$endif} + +{ Output a byte on the stream. + IN assertion: there is enough room in pending_buf. +macro put_byte(s, c) +begin + s^.pending_buf^[s^.pending] := (c); + Inc(s^.pending); +end +} + +const + MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1); +{ Minimum amount of lookahead, except at the end of the input file. + See deflate.c for comments about the MIN_MATCH+1. } + +{macro d_code(dist) + if (dist) < 256 then + := _dist_code[dist] + else + := _dist_code[256+((dist) shr 7)]); + Mapping from a distance to a distance code. dist is the distance - 1 and + must not have side effects. _dist_code[256] and _dist_code[257] are never + used. } + +{$ifndef ORG_DEBUG} +{ Inline versions of _tr_tally for speed: } + +#if defined(GEN_TREES_H) || !defined(STDC) + extern uch _length_code[]; + extern uch _dist_code[]; +#else + extern const uch _length_code[]; + extern const uch _dist_code[]; +#endif + +macro _tr_tally_lit(s, c, flush) +var + cc : uch; +begin + cc := (c); + s^.d_buf[s^.last_lit] := 0; + s^.l_buf[s^.last_lit] := cc; + Inc(s^.last_lit); + Inc(s^.dyn_ltree[cc].fc.Freq); + flush := (s^.last_lit = s^.lit_bufsize-1); +end; + +macro _tr_tally_dist(s, distance, length, flush) \ +var + len : uch; + dist : ush; +begin + len := (length); + dist := (distance); + s^.d_buf[s^.last_lit] := dist; + s^.l_buf[s^.last_lit] = len; + Inc(s^.last_lit); + Dec(dist); + Inc(s^.dyn_ltree[_length_code[len]+LITERALS+1].fc.Freq); + Inc(s^.dyn_dtree[d_code(dist)].Freq); + flush := (s^.last_lit = s^.lit_bufsize-1); +end; + +{$endif} + +{ =========================================================================== + Constants } + +const + MAX_BL_BITS = 7; +{ Bit length codes must not exceed MAX_BL_BITS bits } + +const + END_BLOCK = 256; +{ end of block literal code } + +const + REP_3_6 = 16; +{ repeat previous bit length 3-6 times (2 bits of repeat count) } + +const + REPZ_3_10 = 17; +{ repeat a zero length 3-10 times (3 bits of repeat count) } + +const + REPZ_11_138 = 18; +{ repeat a zero length 11-138 times (7 bits of repeat count) } + +{local} +const + extra_lbits : array[0..LENGTH_CODES-1] of int + { extra bits for each length code } + = (0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,0); + +{local} +const + extra_dbits : array[0..D_CODES-1] of int + { extra bits for each distance code } + = (0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10,11,11,12,12,13,13); + +{local} +const + extra_blbits : array[0..BL_CODES-1] of int { extra bits for each bit length code } + = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7); + +{local} +const + bl_order : array[0..BL_CODES-1] of uch + = (16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15); +{ The lengths of the bit length codes are sent in order of decreasing + probability, to avoid transmitting the lengths for unused bit length codes. + } + +const + Buf_size = (8 * 2*sizeof(uch)); +{ Number of bits used within bi_buf. (bi_buf might be implemented on + more than 16 bits on some systems.) } + +{ =========================================================================== + Local data. These are initialized only once. } + + +{$ifdef GEN_TREES_H)} +{ non ANSI compilers may not accept trees.h } + +const + DIST_CODE_LEN = 512; { see definition of array dist_code below } + +{local} +var + static_ltree : array[0..L_CODES+2-1] of ct_data; +{ The static literal tree. Since the bit lengths are imposed, there is no + need for the L_CODES extra codes used during heap construction. However + The codes 286 and 287 are needed to build a canonical tree (see _tr_init + below). } + +{local} + static_dtree : array[0..D_CODES-1] of ct_data; +{ The static distance tree. (Actually a trivial tree since all codes use + 5 bits.) } + + _dist_code : array[0..DIST_CODE_LEN-1] of uch; +{ Distance codes. The first 256 values correspond to the distances + 3 .. 258, the last 256 values correspond to the top 8 bits of + the 15 bit distances. } + + _length_code : array[0..MAX_MATCH-MIN_MATCH+1-1] of uch; +{ length code for each normalized match length (0 == MIN_MATCH) } + +{local} + base_length : array[0..LENGTH_CODES-1] of int; +{ First normalized length for each code (0 = MIN_MATCH) } + +{local} + base_dist : array[0..D_CODES-1] of int; +{ First normalized distance for each code (0 = distance of 1) } + +{$endif} { GEN_TREES_H } + +{local} +const + static_l_desc : static_tree_desc = + (static_tree: {tree_ptr}(@(static_ltree)); { pointer to array of ct_data } + extra_bits: {pzIntfArray}(@(extra_lbits)); { pointer to array of int } + extra_base: LITERALS+1; + elems: L_CODES; + max_length: MAX_BITS); + +{local} +const + static_d_desc : static_tree_desc = + (static_tree: {tree_ptr}(@(static_dtree)); + extra_bits: {pzIntfArray}(@(extra_dbits)); + extra_base : 0; + elems: D_CODES; + max_length: MAX_BITS); + +{local} +const + static_bl_desc : static_tree_desc = + (static_tree: {tree_ptr}(NIL); + extra_bits: {pzIntfArray}@(extra_blbits); + extra_base : 0; + elems: BL_CODES; + max_length: MAX_BL_BITS); + +(* =========================================================================== + Local (static) routines in this file. } + +procedure tr_static_init; +procedure init_block(var deflate_state); +procedure pqdownheap(var s : deflate_state; + var tree : ct_data; + k : int); +procedure gen_bitlen(var s : deflate_state; + var desc : tree_desc); +procedure gen_codes(var tree : ct_data; + max_code : int; + bl_count : pushf); +procedure build_tree(var s : deflate_state; + var desc : tree_desc); +procedure scan_tree(var s : deflate_state; + var tree : ct_data; + max_code : int); +procedure send_tree(var s : deflate_state; + var tree : ct_data; + max_code : int); +function build_bl_tree(var deflate_state) : int; +procedure send_all_trees(var deflate_state; + lcodes : int; + dcodes : int; + blcodes : int); +procedure compress_block(var s : deflate_state; + var ltree : ct_data; + var dtree : ct_data); +procedure set_data_type(var s : deflate_state); +function bi_reverse(value : unsigned; + length : int) : unsigned; +procedure bi_windup(var deflate_state); +procedure bi_flush(var deflate_state); +procedure copy_block(var deflate_state; + buf : pcharf; + len : unsigned; + header : int); +*) + +{$ifdef GEN_TREES_H} +{local} +procedure gen_trees_header; +{$endif} + +(* +{ =========================================================================== + Output a short LSB first on the stream. + IN assertion: there is enough room in pendingBuf. } + +macro put_short(s, w) +begin + {put_byte(s, (uch)((w) & 0xff));} + s.pending_buf^[s.pending] := uch((w) and $ff); + Inc(s.pending); + + {put_byte(s, (uch)((ush)(w) >> 8));} + s.pending_buf^[s.pending] := uch(ush(w) shr 8);; + Inc(s.pending); +end +*) + +{ =========================================================================== + Send a value on a given number of bits. + IN assertion: length <= 16 and value fits in length bits. } + +{$ifdef ORG_DEBUG} + +{local} +procedure send_bits(var s : deflate_state; + value : int; { value to send } + length : int); { number of bits } +begin + {$ifdef DEBUG} + Tracevv(' l '+IntToStr(length)+ ' v '+IntToStr(value)); + Assert((length > 0) and (length <= 15), 'invalid length'); + Inc(s.bits_sent, ulg(length)); + {$ENDIF} + + { If not enough room in bi_buf, use (valid) bits from bi_buf and + (16 - bi_valid) bits from value, leaving (width - (16-bi_valid)) + unused bits in value. } + {$IFOPT Q+} {$Q-} {$DEFINE NoOverflowCheck} {$ENDIF} + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + if (s.bi_valid > int(Buf_size) - length) then + begin + s.bi_buf := s.bi_buf or int(value shl s.bi_valid); + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + + s.bi_buf := ush(value) shr (Buf_size - s.bi_valid); + Inc(s.bi_valid, length - Buf_size); + end + else + begin + s.bi_buf := s.bi_buf or int(value shl s.bi_valid); + Inc(s.bi_valid, length); + end; + {$IFDEF NoOverflowCheck} {$Q+} {$UNDEF NoOverflowCheck} {$ENDIF} + {$IFDEF NoRangeCheck} {$Q+} {$UNDEF NoRangeCheck} {$ENDIF} +end; + +{$else} { !DEBUG } + + +macro send_code(s, c, tree) +begin + send_bits(s, tree[c].Code, tree[c].Len); + { Send a code of the given tree. c and tree must not have side effects } +end + +macro send_bits(s, value, length) \ +begin int len := length;\ + if (s^.bi_valid > (int)Buf_size - len) begin\ + int val := value;\ + s^.bi_buf |= (val << s^.bi_valid);\ + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + + s^.bi_buf := (ush)val >> (Buf_size - s^.bi_valid);\ + s^.bi_valid += len - Buf_size;\ + end else begin\ + s^.bi_buf |= (value) << s^.bi_valid;\ + s^.bi_valid += len;\ + end\ +end; +{$endif} { DEBUG } + +{ =========================================================================== + Reverse the first len bits of a code, using straightforward code (a faster + method would use a table) + IN assertion: 1 <= len <= 15 } + +{local} +function bi_reverse(code : unsigned; { the value to invert } + len : int) : unsigned; { its bit length } + +var + res : unsigned; {register} +begin + res := 0; + repeat + res := res or (code and 1); + code := code shr 1; + res := res shl 1; + Dec(len); + until (len <= 0); + bi_reverse := res shr 1; +end; + +{ =========================================================================== + Generate the codes for a given tree and bit counts (which need not be + optimal). + IN assertion: the array bl_count contains the bit length statistics for + the given tree and the field len is set for all tree elements. + OUT assertion: the field code is set for all tree elements of non + zero code length. } + +{local} +procedure gen_codes(tree : tree_ptr; { the tree to decorate } + max_code : int; { largest code with non zero frequency } + var bl_count : array of ushf); { number of codes at each bit length } + +var + next_code : array[0..MAX_BITS+1-1] of ush; { next code value for each bit length } + code : ush; { running code value } + bits : int; { bit index } + n : int; { code index } +var + len : int; +begin + code := 0; + + { The distribution counts are first used to generate the code values + without bit reversal. } + + for bits := 1 to MAX_BITS do + begin + code := ((code + bl_count[bits-1]) shl 1); + next_code[bits] := code; + end; + { Check that the bit counts in bl_count are consistent. The last code + must be all ones. } + + {$IFDEF DEBUG} + Assert (code + bl_count[MAX_BITS]-1 = (1 shl MAX_BITS)-1, + 'inconsistent bit counts'); + Tracev(#13'gen_codes: max_code '+IntToStr(max_code)); + {$ENDIF} + + for n := 0 to max_code do + begin + len := tree^[n].dl.Len; + if (len = 0) then + continue; + { Now reverse the bits } + tree^[n].fc.Code := bi_reverse(next_code[len], len); + Inc(next_code[len]); + {$ifdef DEBUG} + if (n>31) and (n<128) then + Tracecv(tree <> tree_ptr(@static_ltree), + (^M'n #'+IntToStr(n)+' '+AnsiChar(n)+' l '+IntToStr(len)+' c '+ + IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')')) + else + Tracecv(tree <> tree_ptr(@static_ltree), + (^M'n #'+IntToStr(n)+' l '+IntToStr(len)+' c '+ + IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')')); + {$ENDIF} + end; +end; + +{ =========================================================================== + Genererate the file trees.h describing the static trees. } +{$ifdef GEN_TREES_H} + +macro SEPARATOR(i, last, width) + if (i) = (last) then + ( ^M');'^M^M + else \ + if (i) mod (width) = (width)-1 then + ','^M + else + ', ' + +procedure gen_trees_header; +var + header : system.text; + i : int; +begin + system.assign(header, 'trees.inc'); + {$I-} + ReWrite(header); + {$I+} + Assert (IOresult <> 0, 'Can''t open trees.h'); + WriteLn(header, + '{ header created automatically with -DGEN_TREES_H }'^M); + + WriteLn(header, 'local const ct_data static_ltree[L_CODES+2] := ('); + for i := 0 to L_CODES+2-1 do + begin + WriteLn(header, '((%3u),(%3u))%s', static_ltree[i].Code, + static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5)); + end; + + WriteLn(header, 'local const ct_data static_dtree[D_CODES] := ('); + for i := 0 to D_CODES-1 do + begin + WriteLn(header, '((%2u),(%2u))%s', static_dtree[i].Code, + static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5)); + end; + + WriteLn(header, 'const uch _dist_code[DIST_CODE_LEN] := ('); + for i := 0 to DIST_CODE_LEN-1 do + begin + WriteLn(header, '%2u%s', _dist_code[i], + SEPARATOR(i, DIST_CODE_LEN-1, 20)); + end; + + WriteLn(header, 'const uch _length_code[MAX_MATCH-MIN_MATCH+1]= ('); + for i := 0 to MAX_MATCH-MIN_MATCH+1-1 do + begin + WriteLn(header, '%2u%s', _length_code[i], + SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20)); + end; + + WriteLn(header, 'local const int base_length[LENGTH_CODES] := ('); + for i := 0 to LENGTH_CODES-1 do + begin + WriteLn(header, '%1u%s', base_length[i], + SEPARATOR(i, LENGTH_CODES-1, 20)); + end; + + WriteLn(header, 'local const int base_dist[D_CODES] := ('); + for i := 0 to D_CODES-1 do + begin + WriteLn(header, '%5u%s', base_dist[i], + SEPARATOR(i, D_CODES-1, 10)); + end; + + close(header); +end; +{$endif} { GEN_TREES_H } + + +{ =========================================================================== + Initialize the various 'constant' tables. } + +{local} +procedure tr_static_init; + +{$ifdef GEN_TREES_H} +const + static_init_done : boolean = FALSE; +var + n : int; { iterates over tree elements } + bits : int; { bit counter } + length : int; { length value } + code : int; { code value } + dist : int; { distance index } + bl_count : array[0..MAX_BITS+1-1] of ush; + { number of codes at each bit length for an optimal tree } +begin + if (static_init_done) then + exit; + + { Initialize the mapping length (0..255) -> length code (0..28) } + length := 0; + for code := 0 to LENGTH_CODES-1-1 do + begin + base_length[code] := length; + for n := 0 to (1 shl extra_lbits[code])-1 do + begin + _length_code[length] := uch(code); + Inc(length); + end; + end; + Assert (length = 256, 'tr_static_init: length <> 256'); + { Note that the length 255 (match length 258) can be represented + in two different ways: code 284 + 5 bits or code 285, so we + overwrite length_code[255] to use the best encoding: } + + _length_code[length-1] := uch(code); + + { Initialize the mapping dist (0..32K) -> dist code (0..29) } + dist := 0; + for code := 0 to 16-1 do + begin + base_dist[code] := dist; + for n := 0 to (1 shl extra_dbits[code])-1 do + begin + _dist_code[dist] := uch(code); + Inc(dist); + end; + end; + Assert (dist = 256, 'tr_static_init: dist <> 256'); + dist := dist shr 7; { from now on, all distances are divided by 128 } + for code := 16 to D_CODES-1 do + begin + base_dist[code] := dist shl 7; + for n := 0 to (1 shl (extra_dbits[code]-7))-1 do + begin + _dist_code[256 + dist] := uch(code); + Inc(dist); + end; + end; + Assert (dist = 256, 'tr_static_init: 256+dist <> 512'); + + { Construct the codes of the static literal tree } + for bits := 0 to MAX_BITS do + bl_count[bits] := 0; + n := 0; + while (n <= 143) do + begin + static_ltree[n].dl.Len := 8; + Inc(n); + Inc(bl_count[8]); + end; + while (n <= 255) do + begin + static_ltree[n].dl.Len := 9; + Inc(n); + Inc(bl_count[9]); + end; + while (n <= 279) do + begin + static_ltree[n].dl.Len := 7; + Inc(n); + Inc(bl_count[7]); + end; + while (n <= 287) do + begin + static_ltree[n].dl.Len := 8; + Inc(n); + Inc(bl_count[8]); + end; + + { Codes 286 and 287 do not exist, but we must include them in the + tree construction to get a canonical Huffman tree (longest code + all ones) } + + gen_codes(tree_ptr(@static_ltree), L_CODES+1, bl_count); + + { The static distance tree is trivial: } + for n := 0 to D_CODES-1 do + begin + static_dtree[n].dl.Len := 5; + static_dtree[n].fc.Code := bi_reverse(unsigned(n), 5); + end; + static_init_done := TRUE; + + gen_trees_header; { save to include file } +{$else} +begin +{$endif} { GEN_TREES_H) } +end; + +{ =========================================================================== + Initialize a new block. } +{local} + +procedure init_block(var s : deflate_state); +var + n : int; { iterates over tree elements } +begin + { Initialize the trees. } + for n := 0 to L_CODES-1 do + s.dyn_ltree[n].fc.Freq := 0; + for n := 0 to D_CODES-1 do + s.dyn_dtree[n].fc.Freq := 0; + for n := 0 to BL_CODES-1 do + s.bl_tree[n].fc.Freq := 0; + + s.dyn_ltree[END_BLOCK].fc.Freq := 1; + s.static_len := Long(0); + s.opt_len := Long(0); + s.matches := 0; + s.last_lit := 0; +end; + +const + SMALLEST = 1; +{ Index within the heap array of least frequent node in the Huffman tree } + +{ =========================================================================== + Initialize the tree data structures for a new zlib stream. } +procedure _tr_init(var s : deflate_state); +begin + tr_static_init; + + s.compressed_len := Long(0); + + s.l_desc.dyn_tree := tree_ptr(@s.dyn_ltree); + s.l_desc.stat_desc := @static_l_desc; + + s.d_desc.dyn_tree := tree_ptr(@s.dyn_dtree); + s.d_desc.stat_desc := @static_d_desc; + + s.bl_desc.dyn_tree := tree_ptr(@s.bl_tree); + s.bl_desc.stat_desc := @static_bl_desc; + + s.bi_buf := 0; + s.bi_valid := 0; + s.last_eob_len := 8; { enough lookahead for inflate } +{$ifdef DEBUG} + s.bits_sent := Long(0); +{$endif} + + { Initialize the first block of the first file: } + init_block(s); +end; + +{ =========================================================================== + Remove the smallest element from the heap and recreate the heap with + one less element. Updates heap and heap_len. + +macro pqremove(s, tree, top) +begin + top := s.heap[SMALLEST]; + s.heap[SMALLEST] := s.heap[s.heap_len]; + Dec(s.heap_len); + pqdownheap(s, tree, SMALLEST); +end +} + +{ =========================================================================== + Compares to subtrees, using the tree depth as tie breaker when + the subtrees have equal frequency. This minimizes the worst case length. + +macro smaller(tree, n, m, depth) + ( (tree[n].Freq < tree[m].Freq) or + ((tree[n].Freq = tree[m].Freq) and (depth[n] <= depth[m])) ) +} + +{ =========================================================================== + Restore the heap property by moving down the tree starting at node k, + exchanging a node with the smallest of its two sons if necessary, stopping + when the heap property is re-established (each father smaller than its + two sons). } +{local} + +procedure pqdownheap(var s : deflate_state; + var tree : tree_type; { the tree to restore } + k : int); { node to move down } +var + v : int; + j : int; +begin + v := s.heap[k]; + j := k shl 1; { left son of k } + while (j <= s.heap_len) do + begin + { Set j to the smallest of the two sons: } + if (j < s.heap_len) and + {smaller(tree, s.heap[j+1], s.heap[j], s.depth)} + ( (tree[s.heap[j+1]].fc.Freq < tree[s.heap[j]].fc.Freq) or + ((tree[s.heap[j+1]].fc.Freq = tree[s.heap[j]].fc.Freq) and + (s.depth[s.heap[j+1]] <= s.depth[s.heap[j]])) ) then + begin + Inc(j); + end; + { Exit if v is smaller than both sons } + if {(smaller(tree, v, s.heap[j], s.depth))} + ( (tree[v].fc.Freq < tree[s.heap[j]].fc.Freq) or + ((tree[v].fc.Freq = tree[s.heap[j]].fc.Freq) and + (s.depth[v] <= s.depth[s.heap[j]])) ) then + break; + { Exchange v with the smallest son } + s.heap[k] := s.heap[j]; + k := j; + + { And continue down the tree, setting j to the left son of k } + j := j shl 1; + end; + s.heap[k] := v; +end; + +{ =========================================================================== + Compute the optimal bit lengths for a tree and update the total bit length + for the current block. + IN assertion: the fields freq and dad are set, heap[heap_max] and + above are the tree nodes sorted by increasing frequency. + OUT assertions: the field len is set to the optimal bit length, the + array bl_count contains the frequencies for each bit length. + The length opt_len is updated; static_len is also updated if stree is + not null. } + +{local} +procedure gen_bitlen(var s : deflate_state; + var desc : tree_desc); { the tree descriptor } +var + tree : tree_ptr; + max_code : int; + stree : tree_ptr; {const} + extra : pzIntfArray; {const} + base : int; + max_length : int; + h : int; { heap index } + n, m : int; { iterate over the tree elements } + bits : int; { bit length } + xbits : int; { extra bits } + f : ush; { frequency } + overflow : int; { number of elements with bit length too large } +begin + tree := desc.dyn_tree; + max_code := desc.max_code; + stree := desc.stat_desc^.static_tree; + extra := desc.stat_desc^.extra_bits; + base := desc.stat_desc^.extra_base; + max_length := desc.stat_desc^.max_length; + overflow := 0; + + for bits := 0 to MAX_BITS do + s.bl_count[bits] := 0; + + { In a first pass, compute the optimal bit lengths (which may + overflow in the case of the bit length tree). } + + tree^[s.heap[s.heap_max]].dl.Len := 0; { root of the heap } + + for h := s.heap_max+1 to HEAP_SIZE-1 do + begin + n := s.heap[h]; + bits := tree^[tree^[n].dl.Dad].dl.Len + 1; + if (bits > max_length) then + begin + bits := max_length; + Inc(overflow); + end; + tree^[n].dl.Len := ush(bits); + { We overwrite tree[n].dl.Dad which is no longer needed } + + if (n > max_code) then + continue; { not a leaf node } + + Inc(s.bl_count[bits]); + xbits := 0; + if (n >= base) then + xbits := extra^[n-base]; + f := tree^[n].fc.Freq; + Inc(s.opt_len, ulg(f) * (bits + xbits)); + if (stree <> NIL) then + Inc(s.static_len, ulg(f) * (stree^[n].dl.Len + xbits)); + end; + if (overflow = 0) then + exit; + {$ifdef DEBUG} + Tracev(^M'bit length overflow'); + {$endif} + { This happens for example on obj2 and pic of the Calgary corpus } + + { Find the first bit length which could increase: } + repeat + bits := max_length-1; + while (s.bl_count[bits] = 0) do + Dec(bits); + Dec(s.bl_count[bits]); { move one leaf down the tree } + Inc(s.bl_count[bits+1], 2); { move one overflow item as its brother } + Dec(s.bl_count[max_length]); + { The brother of the overflow item also moves one step up, + but this does not affect bl_count[max_length] } + + Dec(overflow, 2); + until (overflow <= 0); + + { Now recompute all bit lengths, scanning in increasing frequency. + h is still equal to HEAP_SIZE. (It is simpler to reconstruct all + lengths instead of fixing only the wrong ones. This idea is taken + from 'ar' written by Haruhiko Okumura.) } + h := HEAP_SIZE; { Delphi3: compiler warning w/o this } + for bits := max_length downto 1 do + begin + n := s.bl_count[bits]; + while (n <> 0) do + begin + Dec(h); + m := s.heap[h]; + if (m > max_code) then + continue; + if (tree^[m].dl.Len <> unsigned(bits)) then + begin + {$ifdef DEBUG} + Trace('code '+IntToStr(m)+' bits '+IntToStr(tree^[m].dl.Len) + +'.'+IntToStr(bits)); + {$ENDIF} + Inc(s.opt_len, (long(bits) - long(tree^[m].dl.Len)) + * long(tree^[m].fc.Freq) ); + tree^[m].dl.Len := ush(bits); + end; + Dec(n); + end; + end; +end; + +{ =========================================================================== + Construct one Huffman tree and assigns the code bit strings and lengths. + Update the total bit length for the current block. + IN assertion: the field freq is set for all tree elements. + OUT assertions: the fields len and code are set to the optimal bit length + and corresponding code. The length opt_len is updated; static_len is + also updated if stree is not null. The field max_code is set. } + +{local} +procedure build_tree(var s : deflate_state; + var desc : tree_desc); { the tree descriptor } + +var + tree : tree_ptr; + stree : tree_ptr; {const} + elems : int; + n, m : int; { iterate over heap elements } + max_code : int; { largest code with non zero frequency } + node : int; { new node being created } +begin + tree := desc.dyn_tree; + stree := desc.stat_desc^.static_tree; + elems := desc.stat_desc^.elems; + max_code := -1; + + { Construct the initial heap, with least frequent element in + heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1]. + heap[0] is not used. } + s.heap_len := 0; + s.heap_max := HEAP_SIZE; + + for n := 0 to elems-1 do + begin + if (tree^[n].fc.Freq <> 0) then + begin + max_code := n; + Inc(s.heap_len); + s.heap[s.heap_len] := n; + s.depth[n] := 0; + end + else + begin + tree^[n].dl.Len := 0; + end; + end; + + { The pkzip format requires that at least one distance code exists, + and that at least one bit should be sent even if there is only one + possible code. So to avoid special checks later on we force at least + two codes of non zero frequency. } + + while (s.heap_len < 2) do + begin + Inc(s.heap_len); + if (max_code < 2) then + begin + Inc(max_code); + s.heap[s.heap_len] := max_code; + node := max_code; + end + else + begin + s.heap[s.heap_len] := 0; + node := 0; + end; + tree^[node].fc.Freq := 1; + s.depth[node] := 0; + Dec(s.opt_len); + if (stree <> NIL) then + Dec(s.static_len, stree^[node].dl.Len); + { node is 0 or 1 so it does not have extra bits } + end; + desc.max_code := max_code; + + { The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree, + establish sub-heaps of increasing lengths: } + + for n := s.heap_len div 2 downto 1 do + pqdownheap(s, tree^, n); + + { Construct the Huffman tree by repeatedly combining the least two + frequent nodes. } + + node := elems; { next internal node of the tree } + repeat + {pqremove(s, tree, n);} { n := node of least frequency } + n := s.heap[SMALLEST]; + s.heap[SMALLEST] := s.heap[s.heap_len]; + Dec(s.heap_len); + pqdownheap(s, tree^, SMALLEST); + + m := s.heap[SMALLEST]; { m := node of next least frequency } + + Dec(s.heap_max); + s.heap[s.heap_max] := n; { keep the nodes sorted by frequency } + Dec(s.heap_max); + s.heap[s.heap_max] := m; + + { Create a new node father of n and m } + tree^[node].fc.Freq := tree^[n].fc.Freq + tree^[m].fc.Freq; + { maximum } + if (s.depth[n] >= s.depth[m]) then + s.depth[node] := uch (s.depth[n] + 1) + else + s.depth[node] := uch (s.depth[m] + 1); + + tree^[m].dl.Dad := ush(node); + tree^[n].dl.Dad := ush(node); +{$ifdef DUMP_BL_TREE} + if (tree = tree_ptr(@s.bl_tree)) then + begin + WriteLn(#13'node ',node,'(',tree^[node].fc.Freq,') sons ',n, + '(',tree^[n].fc.Freq,') ', m, '(',tree^[m].fc.Freq,')'); + end; +{$endif} + { and insert the new node in the heap } + s.heap[SMALLEST] := node; + Inc(node); + pqdownheap(s, tree^, SMALLEST); + + until (s.heap_len < 2); + + Dec(s.heap_max); + s.heap[s.heap_max] := s.heap[SMALLEST]; + + { At this point, the fields freq and dad are set. We can now + generate the bit lengths. } + + gen_bitlen(s, desc); + + { The field len is now set, we can generate the bit codes } + gen_codes (tree, max_code, s.bl_count); +end; + +{ =========================================================================== + Scan a literal or distance tree to determine the frequencies of the codes + in the bit length tree. } + +{local} +procedure scan_tree(var s : deflate_state; + var tree : array of ct_data; { the tree to be scanned } + max_code : int); { and its largest code of non zero frequency } +var + n : int; { iterates over all tree elements } + prevlen : int; { last emitted length } + curlen : int; { length of current code } + nextlen : int; { length of next code } + count : int; { repeat count of the current code } + max_count : int; { max repeat count } + min_count : int; { min repeat count } +begin + prevlen := -1; + nextlen := tree[0].dl.Len; + count := 0; + max_count := 7; + min_count := 4; + + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end; + tree[max_code+1].dl.Len := ush($ffff); { guard } + + for n := 0 to max_code do + begin + curlen := nextlen; + nextlen := tree[n+1].dl.Len; + Inc(count); + if (count < max_count) and (curlen = nextlen) then + continue + else + if (count < min_count) then + Inc(s.bl_tree[curlen].fc.Freq, count) + else + if (curlen <> 0) then + begin + if (curlen <> prevlen) then + Inc(s.bl_tree[curlen].fc.Freq); + Inc(s.bl_tree[REP_3_6].fc.Freq); + end + else + if (count <= 10) then + Inc(s.bl_tree[REPZ_3_10].fc.Freq) + else + Inc(s.bl_tree[REPZ_11_138].fc.Freq); + + count := 0; + prevlen := curlen; + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end + else + if (curlen = nextlen) then + begin + max_count := 6; + min_count := 3; + end + else + begin + max_count := 7; + min_count := 4; + end; + end; +end; + +{ =========================================================================== + Send a literal or distance tree in compressed form, using the codes in + bl_tree. } + +{local} +procedure send_tree(var s : deflate_state; + var tree : array of ct_data; { the tree to be scanned } + max_code : int); { and its largest code of non zero frequency } + +var + n : int; { iterates over all tree elements } + prevlen : int; { last emitted length } + curlen : int; { length of current code } + nextlen : int; { length of next code } + count : int; { repeat count of the current code } + max_count : int; { max repeat count } + min_count : int; { min repeat count } +begin + prevlen := -1; + nextlen := tree[0].dl.Len; + count := 0; + max_count := 7; + min_count := 4; + + { tree[max_code+1].dl.Len := -1; } { guard already set } + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end; + + for n := 0 to max_code do + begin + curlen := nextlen; + nextlen := tree[n+1].dl.Len; + Inc(count); + if (count < max_count) and (curlen = nextlen) then + continue + else + if (count < min_count) then + begin + repeat + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(curlen)); + {$ENDIF} + send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len); + Dec(count); + until (count = 0); + end + else + if (curlen <> 0) then + begin + if (curlen <> prevlen) then + begin + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(curlen)); + {$ENDIF} + send_bits(s, s.bl_tree[curlen].fc.Code, s.bl_tree[curlen].dl.Len); + Dec(count); + end; + {$IFDEF DEBUG} + Assert((count >= 3) and (count <= 6), ' 3_6?'); + {$ENDIF} + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(REP_3_6)); + {$ENDIF} + send_bits(s, s.bl_tree[REP_3_6].fc.Code, s.bl_tree[REP_3_6].dl.Len); + send_bits(s, count-3, 2); + end + else + if (count <= 10) then + begin + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(REPZ_3_10)); + {$ENDIF} + send_bits(s, s.bl_tree[REPZ_3_10].fc.Code, s.bl_tree[REPZ_3_10].dl.Len); + send_bits(s, count-3, 3); + end + else + begin + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(REPZ_11_138)); + {$ENDIF} + send_bits(s, s.bl_tree[REPZ_11_138].fc.Code, s.bl_tree[REPZ_11_138].dl.Len); + send_bits(s, count-11, 7); + end; + count := 0; + prevlen := curlen; + if (nextlen = 0) then + begin + max_count := 138; + min_count := 3; + end + else + if (curlen = nextlen) then + begin + max_count := 6; + min_count := 3; + end + else + begin + max_count := 7; + min_count := 4; + end; + end; +end; + +{ =========================================================================== + Construct the Huffman tree for the bit lengths and return the index in + bl_order of the last bit length code to send. } + +{local} +function build_bl_tree(var s : deflate_state) : int; +var + max_blindex : int; { index of last bit length code of non zero freq } +begin + { Determine the bit length frequencies for literal and distance trees } + scan_tree(s, s.dyn_ltree, s.l_desc.max_code); + scan_tree(s, s.dyn_dtree, s.d_desc.max_code); + + { Build the bit length tree: } + build_tree(s, s.bl_desc); + { opt_len now includes the length of the tree representations, except + the lengths of the bit lengths codes and the 5+5+4 bits for the counts. } + + { Determine the number of bit length codes to send. The pkzip format + requires that at least 4 bit length codes be sent. (appnote.txt says + 3 but the actual value used is 4.) } + + for max_blindex := BL_CODES-1 downto 3 do + begin + if (s.bl_tree[bl_order[max_blindex]].dl.Len <> 0) then + break; + end; + { Update opt_len to include the bit length tree and counts } + Inc(s.opt_len, 3*(max_blindex+1) + 5+5+4); + {$ifdef DEBUG} + Tracev(^M'dyn trees: dyn %ld, stat %ld {s.opt_len, s.static_len}'); + {$ENDIF} + + build_bl_tree := max_blindex; +end; + +{ =========================================================================== + Send the header for a block using dynamic Huffman trees: the counts, the + lengths of the bit length codes, the literal tree and the distance tree. + IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4. } + +{local} +procedure send_all_trees(var s : deflate_state; + lcodes : int; + dcodes : int; + blcodes : int); { number of codes for each tree } +var + rank : int; { index in bl_order } +begin + {$IFDEF DEBUG} + Assert ((lcodes >= 257) and (dcodes >= 1) and (blcodes >= 4), + 'not enough codes'); + Assert ((lcodes <= L_CODES) and (dcodes <= D_CODES) + and (blcodes <= BL_CODES), 'too many codes'); + Tracev(^M'bl counts: '); + {$ENDIF} + send_bits(s, lcodes-257, 5); { not +255 as stated in appnote.txt } + send_bits(s, dcodes-1, 5); + send_bits(s, blcodes-4, 4); { not -3 as stated in appnote.txt } + for rank := 0 to blcodes-1 do + begin + {$ifdef DEBUG} + Tracev(^M'bl code '+IntToStr(bl_order[rank])); + {$ENDIF} + send_bits(s, s.bl_tree[bl_order[rank]].dl.Len, 3); + end; + {$ifdef DEBUG} + Tracev(^M'bl tree: sent '+IntToStr(s.bits_sent)); + {$ENDIF} + + send_tree(s, s.dyn_ltree, lcodes-1); { literal tree } + {$ifdef DEBUG} + Tracev(^M'lit tree: sent '+IntToStr(s.bits_sent)); + {$ENDIF} + + send_tree(s, s.dyn_dtree, dcodes-1); { distance tree } + {$ifdef DEBUG} + Tracev(^M'dist tree: sent '+IntToStr(s.bits_sent)); + {$ENDIF} +end; + +{ =========================================================================== + Flush the bit buffer and align the output on a byte boundary } + +{local} +procedure bi_windup(var s : deflate_state); +begin + if (s.bi_valid > 8) then + begin + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + end + else + if (s.bi_valid > 0) then + begin + {put_byte(s, (Byte)s^.bi_buf);} + s.pending_buf^[s.pending] := Byte(s.bi_buf); + Inc(s.pending); + end; + s.bi_buf := 0; + s.bi_valid := 0; +{$ifdef DEBUG} + s.bits_sent := (s.bits_sent+7) and (not 7); +{$endif} +end; + +{ =========================================================================== + Copy a stored block, storing first the length and its + one's complement if requested. } + +{local} +procedure copy_block(var s : deflate_state; + buf : pcharf; { the input data } + len : unsigned; { its length } + header : boolean); { true if block header must be written } +begin + bi_windup(s); { align on byte boundary } + s.last_eob_len := 8; { enough lookahead for inflate } + + if (header) then + begin + {put_short(s, (ush)len);} + s.pending_buf^[s.pending] := uch(ush(len) and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(len) shr 8);; + Inc(s.pending); + {put_short(s, (ush)~len);} + s.pending_buf^[s.pending] := uch(ush(not len) and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(not len) shr 8);; + Inc(s.pending); + +{$ifdef DEBUG} + Inc(s.bits_sent, 2*16); +{$endif} + end; +{$ifdef DEBUG} + Inc(s.bits_sent, ulg(len shl 3)); +{$endif} + while (len <> 0) do + begin + Dec(len); + {put_byte(s, *buf++);} + s.pending_buf^[s.pending] := buf^; + Inc(buf); + Inc(s.pending); + end; +end; + + +{ =========================================================================== + Send a stored block } + +procedure _tr_stored_block(var s : deflate_state; + buf : pcharf; { input block } + stored_len : ulg; { length of input block } + eof : boolean); { true if this is the last block for a file } + +begin + send_bits(s, (STORED_BLOCK shl 1)+ord(eof), 3); { send block type } + s.compressed_len := (s.compressed_len + 3 + 7) and ulg(not Long(7)); + Inc(s.compressed_len, (stored_len + 4) shl 3); + + copy_block(s, buf, unsigned(stored_len), TRUE); { with header } +end; + +{ =========================================================================== + Flush the bit buffer, keeping at most 7 bits in it. } + +{local} +procedure bi_flush(var s : deflate_state); +begin + if (s.bi_valid = 16) then + begin + {put_short(s, s.bi_buf);} + s.pending_buf^[s.pending] := uch(s.bi_buf and $ff); + Inc(s.pending); + s.pending_buf^[s.pending] := uch(ush(s.bi_buf) shr 8);; + Inc(s.pending); + + s.bi_buf := 0; + s.bi_valid := 0; + end + else + if (s.bi_valid >= 8) then + begin + {put_byte(s, (Byte)s^.bi_buf);} + s.pending_buf^[s.pending] := Byte(s.bi_buf); + Inc(s.pending); + + s.bi_buf := s.bi_buf shr 8; + Dec(s.bi_valid, 8); + end; +end; + + +{ =========================================================================== + Send one empty static block to give enough lookahead for inflate. + This takes 10 bits, of which 7 may remain in the bit buffer. + The current inflate code requires 9 bits of lookahead. If the + last two codes for the previous block (real code plus EOB) were coded + on 5 bits or less, inflate may have only 5+3 bits of lookahead to decode + the last real code. In this case we send two empty static blocks instead + of one. (There are no problems if the previous block is stored or fixed.) + To simplify the code, we assume the worst case of last real code encoded + on one bit only. } + +procedure _tr_align(var s : deflate_state); +begin + send_bits(s, STATIC_TREES shl 1, 3); + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(END_BLOCK)); + {$ENDIF} + send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len); + Inc(s.compressed_len, Long(10)); { 3 for block type, 7 for EOB } + bi_flush(s); + { Of the 10 bits for the empty block, we have already sent + (10 - bi_valid) bits. The lookahead for the last real code (before + the EOB of the previous block) was thus at least one plus the length + of the EOB plus what we have just sent of the empty static block. } + if (1 + s.last_eob_len + 10 - s.bi_valid < 9) then + begin + send_bits(s, STATIC_TREES shl 1, 3); + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(END_BLOCK)); + {$ENDIF} + send_bits(s, static_ltree[END_BLOCK].fc.Code, static_ltree[END_BLOCK].dl.Len); + Inc(s.compressed_len, Long(10)); + bi_flush(s); + end; + s.last_eob_len := 7; +end; + +{ =========================================================================== + Set the data type to ASCII or BINARY, using a crude approximation: + binary if more than 20% of the bytes are <= 6 or >= 128, ascii otherwise. + IN assertion: the fields freq of dyn_ltree are set and the total of all + frequencies does not exceed 64K (to fit in an int on 16 bit machines). } + +{local} +procedure set_data_type(var s : deflate_state); +var + n : int; + ascii_freq : unsigned; + bin_freq : unsigned; +begin + n := 0; + ascii_freq := 0; + bin_freq := 0; + + while (n < 7) do + begin + Inc(bin_freq, s.dyn_ltree[n].fc.Freq); + Inc(n); + end; + while (n < 128) do + begin + Inc(ascii_freq, s.dyn_ltree[n].fc.Freq); + Inc(n); + end; + while (n < LITERALS) do + begin + Inc(bin_freq, s.dyn_ltree[n].fc.Freq); + Inc(n); + end; + if (bin_freq > (ascii_freq shr 2)) then + s.data_type := Byte(Z_BINARY) + else + s.data_type := Byte(Z_ASCII); +end; + +{ =========================================================================== + Send the block data compressed using the given Huffman trees } + +{local} +procedure compress_block(var s : deflate_state; + var ltree : array of ct_data; { literal tree } + var dtree : array of ct_data); { distance tree } +var + dist : unsigned; { distance of matched string } + lc : int; { match length or unmatched char (if dist == 0) } + lx : unsigned; { running index in l_buf } + code : unsigned; { the code to send } + extra : int; { number of extra bits to send } +begin + lx := 0; + if (s.last_lit <> 0) then + repeat + dist := s.d_buf^[lx]; + lc := s.l_buf^[lx]; + Inc(lx); + if (dist = 0) then + begin + { send a literal byte } + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(lc)); + Tracecv((lc > 31) and (lc < 128), ' '+AnsiChar(lc)+' '); + {$ENDIF} + send_bits(s, ltree[lc].fc.Code, ltree[lc].dl.Len); + end + else + begin + { Here, lc is the match length - MIN_MATCH } + code := _length_code[lc]; + { send the length code } + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(code+LITERALS+1)); + {$ENDIF} + send_bits(s, ltree[code+LITERALS+1].fc.Code, ltree[code+LITERALS+1].dl.Len); + extra := extra_lbits[code]; + if (extra <> 0) then + begin + Dec(lc, base_length[code]); + send_bits(s, lc, extra); { send the extra length bits } + end; + Dec(dist); { dist is now the match distance - 1 } + {code := d_code(dist);} + if (dist < 256) then + code := _dist_code[dist] + else + code := _dist_code[256+(dist shr 7)]; + + {$IFDEF DEBUG} + Assert (code < D_CODES, 'bad d_code'); + {$ENDIF} + + { send the distance code } + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(code)); + {$ENDIF} + send_bits(s, dtree[code].fc.Code, dtree[code].dl.Len); + extra := extra_dbits[code]; + if (extra <> 0) then + begin + Dec(dist, base_dist[code]); + send_bits(s, dist, extra); { send the extra distance bits } + end; + end; { literal or match pair ? } + + { Check that the overlay between pending_buf and d_buf+l_buf is ok: } + {$IFDEF DEBUG} + Assert(s.pending < s.lit_bufsize + 2*lx, 'pendingBuf overflow'); + {$ENDIF} + until (lx >= s.last_lit); + + {$ifdef DEBUG} + Tracevvv(#13'cd '+IntToStr(END_BLOCK)); + {$ENDIF} + send_bits(s, ltree[END_BLOCK].fc.Code, ltree[END_BLOCK].dl.Len); + s.last_eob_len := ltree[END_BLOCK].dl.Len; +end; + + +{ =========================================================================== + Determine the best encoding for the current block: dynamic trees, static + trees or store, and output the encoded block to the zip file. This function + returns the total compressed length for the file so far. } + +function _tr_flush_block (var s : deflate_state; + buf : pcharf; { input block, or NULL if too old } + stored_len : ulg; { length of input block } + eof : boolean) : ulg; { true if this is the last block for a file } +var + opt_lenb, static_lenb : ulg; { opt_len and static_len in bytes } + max_blindex : int; { index of last bit length code of non zero freq } +begin + max_blindex := 0; + + { Build the Huffman trees unless a stored block is forced } + if (s.level > 0) then + begin + { Check if the file is ascii or binary } + if (s.data_type = Z_UNKNOWN) then + set_data_type(s); + + { Construct the literal and distance trees } + build_tree(s, s.l_desc); + {$ifdef DEBUG} + Tracev(^M'lit data: dyn %ld, stat %ld {s.opt_len, s.static_len}'); + {$ENDIF} + + build_tree(s, s.d_desc); + {$ifdef DEBUG} + Tracev(^M'dist data: dyn %ld, stat %ld {s.opt_len, s.static_len}'); + {$ENDIF} + { At this point, opt_len and static_len are the total bit lengths of + the compressed block data, excluding the tree representations. } + + { Build the bit length tree for the above two trees, and get the index + in bl_order of the last bit length code to send. } + max_blindex := build_bl_tree(s); + + { Determine the best encoding. Compute first the block length in bytes} + opt_lenb := (s.opt_len+3+7) shr 3; + static_lenb := (s.static_len+3+7) shr 3; + + {$ifdef DEBUG} + Tracev(^M'opt %lu(%lu) stat %lu(%lu) stored %lu lit %u '+ + '{opt_lenb, s.opt_len, static_lenb, s.static_len, stored_len,'+ + 's.last_lit}'); + {$ENDIF} + + if (static_lenb <= opt_lenb) then + opt_lenb := static_lenb; + + end + else + begin + {$IFDEF DEBUG} + Assert(buf <> pcharf(NIL), 'lost buf'); + {$ENDIF} + static_lenb := stored_len + 5; + opt_lenb := static_lenb; { force a stored block } + end; + + { If compression failed and this is the first and last block, + and if the .zip file can be seeked (to rewrite the local header), + the whole file is transformed into a stored file: } + +{$ifdef STORED_FILE_OK} +{$ifdef FORCE_STORED_FILE} + if eof and (s.compressed_len = Long(0)) then + begin { force stored file } +{$else} + if (stored_len <= opt_lenb) and eof and (s.compressed_len=Long(0)) + and seekable()) do + begin +{$endif} + { Since LIT_BUFSIZE <= 2*WSIZE, the input data must be there: } + if (buf = pcharf(0)) then + error ('block vanished'); + + copy_block(buf, unsigned(stored_len), 0); { without header } + s.compressed_len := stored_len shl 3; + s.method := STORED; + end + else +{$endif} { STORED_FILE_OK } + +{$ifdef FORCE_STORED} + if (buf <> pcharf(0)) then + begin { force stored block } +{$else} + if (stored_len+4 <= opt_lenb) and (buf <> pcharf(0)) then + begin + { 4: two words for the lengths } +{$endif} + { The test buf <> NULL is only necessary if LIT_BUFSIZE > WSIZE. + Otherwise we can't have processed more than WSIZE input bytes since + the last block flush, because compression would have been + successful. If LIT_BUFSIZE <= WSIZE, it is never too late to + transform a block into a stored block. } + + _tr_stored_block(s, buf, stored_len, eof); + +{$ifdef FORCE_STATIC} + end + else + if (static_lenb >= 0) then + begin { force static trees } +{$else} + end + else + if (static_lenb = opt_lenb) then + begin +{$endif} + send_bits(s, (STATIC_TREES shl 1)+ord(eof), 3); + compress_block(s, static_ltree, static_dtree); + Inc(s.compressed_len, 3 + s.static_len); + end + else + begin + send_bits(s, (DYN_TREES shl 1)+ord(eof), 3); + send_all_trees(s, s.l_desc.max_code+1, s.d_desc.max_code+1, + max_blindex+1); + compress_block(s, s.dyn_ltree, s.dyn_dtree); + Inc(s.compressed_len, 3 + s.opt_len); + end; + {$ifdef DEBUG} + Assert (s.compressed_len = s.bits_sent, 'bad compressed size'); + {$ENDIF} + init_block(s); + + if (eof) then + begin + bi_windup(s); + Inc(s.compressed_len, 7); { align on byte boundary } + end; + {$ifdef DEBUG} + Tracev(#13'comprlen %lu(%lu) {s.compressed_len shr 3,'+ + 's.compressed_len-7*ord(eof)}'); + {$ENDIF} + + _tr_flush_block := s.compressed_len shr 3; +end; + + +{ =========================================================================== + Save the match info and tally the frequency counts. Return true if + the current block must be flushed. } + +function _tr_tally (var s : deflate_state; + dist : unsigned; { distance of matched string } + lc : unsigned) : boolean; { match length-MIN_MATCH or unmatched char (if dist=0) } +var + {$IFDEF DEBUG} + MAX_DIST : ush; + {$ENDIF} + code : ush; +{$ifdef TRUNCATE_BLOCK} +var + out_length : ulg; + in_length : ulg; + dcode : int; +{$endif} +begin + s.d_buf^[s.last_lit] := ush(dist); + s.l_buf^[s.last_lit] := uch(lc); + Inc(s.last_lit); + if (dist = 0) then + begin + { lc is the unmatched char } + Inc(s.dyn_ltree[lc].fc.Freq); + end + else + begin + Inc(s.matches); + { Here, lc is the match length - MIN_MATCH } + Dec(dist); { dist := match distance - 1 } + + {macro d_code(dist)} + if (dist) < 256 then + code := _dist_code[dist] + else + code := _dist_code[256+(dist shr 7)]; + {$IFDEF DEBUG} +{macro MAX_DIST(s) <=> ((s)^.w_size-MIN_LOOKAHEAD) + In order to simplify the code, particularly on 16 bit machines, match + distances are limited to MAX_DIST instead of WSIZE. } + MAX_DIST := ush(s.w_size-MIN_LOOKAHEAD); + Assert((dist < ush(MAX_DIST)) and + (ush(lc) <= ush(MAX_MATCH-MIN_MATCH)) and + (ush(code) < ush(D_CODES)), '_tr_tally: bad match'); + {$ENDIF} + Inc(s.dyn_ltree[_length_code[lc]+LITERALS+1].fc.Freq); + {s.dyn_dtree[d_code(dist)].Freq++;} + Inc(s.dyn_dtree[code].fc.Freq); + end; + +{$ifdef TRUNCATE_BLOCK} + { Try to guess if it is profitable to stop the current block here } + if (s.last_lit and $1fff = 0) and (s.level > 2) then + begin + { Compute an upper bound for the compressed length } + out_length := ulg(s.last_lit)*Long(8); + in_length := ulg(long(s.strstart) - s.block_start); + for dcode := 0 to D_CODES-1 do + begin + Inc(out_length, ulg(s.dyn_dtree[dcode].fc.Freq * + (Long(5)+extra_dbits[dcode])) ); + end; + out_length := out_length shr 3; + {$ifdef DEBUG} + Tracev(^M'last_lit %u, in %ld, out ~%ld(%ld%%) '); + { s.last_lit, in_length, out_length, + Long(100) - out_length*Long(100) div in_length)); } + {$ENDIF} + if (s.matches < s.last_lit div 2) and (out_length < in_length div 2) then + begin + _tr_tally := TRUE; + exit; + end; + end; +{$endif} + _tr_tally := (s.last_lit = s.lit_bufsize-1); + { We avoid equality with lit_bufsize because of wraparound at 64K + on 16 bit machines and because stored blocks are restricted to + 64K-1 bytes. } +end; + end. \ No newline at end of file diff --git a/Imaging/ZLib/imzconf.inc b/Imaging/ZLib/imzconf.inc index bd518a5..d688a4b 100644 --- a/Imaging/ZLib/imzconf.inc +++ b/Imaging/ZLib/imzconf.inc @@ -1,25 +1,25 @@ -{ -------------------------------------------------------------------- } - -{$DEFINE MAX_MATCH_IS_258} - -{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more - than 64k bytes at a time (needed on systems with 16-bit int). } - -{$UNDEF MAXSEG_64K} -{$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } -{$UNDEF DYNAMIC_CRC_TABLE} -{$UNDEF FASTEST} -{$DEFINE Use32} -{$DEFINE patch112} { apply patch from the zlib home page } - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} - -{$UNDEF DEBUG} // for Delphi 2007 in DEBUG mode - -{$RANGECHECKS OFF} -{$OVERFLOWCHECKS OFF} -{ -------------------------------------------------------------------- } - - +{ -------------------------------------------------------------------- } + +{$DEFINE MAX_MATCH_IS_258} + +{ Compile with -DMAXSEG_64K if the alloc function cannot allocate more + than 64k bytes at a time (needed on systems with 16-bit int). } + +{$UNDEF MAXSEG_64K} +{$DEFINE UNALIGNED_OK} { requires SizeOf(ush) = 2 ! } +{$UNDEF DYNAMIC_CRC_TABLE} +{$UNDEF FASTEST} +{$DEFINE Use32} +{$DEFINE patch112} { apply patch from the zlib home page } + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +{$UNDEF DEBUG} // for Delphi 2007 in DEBUG mode + +{$RANGECHECKS OFF} +{$OVERFLOWCHECKS OFF} +{ -------------------------------------------------------------------- } + + diff --git a/Imaging/ZLib/imzdeflate.pas b/Imaging/ZLib/imzdeflate.pas index dc5e96f..622fe4b 100644 --- a/Imaging/ZLib/imzdeflate.pas +++ b/Imaging/ZLib/imzdeflate.pas @@ -1,2129 +1,2129 @@ -Unit imzdeflate; - -{ Orginal: deflate.h -- internal compression state - deflate.c -- compress data using the deflation algorithm - Copyright (C) 1995-1996 Jean-loup Gailly. - - Pascal tranlastion - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - - -{ ALGORITHM - - The "deflation" process depends on being able to identify portions - of the input text which are identical to earlier input (within a - sliding window trailing behind the input currently being processed). - - The most straightforward technique turns out to be the fastest for - most input files: try all possible matches and select the longest. - The key feature of this algorithm is that insertions into the string - dictionary are very simple and thus fast, and deletions are avoided - completely. Insertions are performed at each input character, whereas - string matches are performed only when the previous match ends. So it - is preferable to spend more time in matches to allow very fast string - insertions and avoid deletions. The matching algorithm for small - strings is inspired from that of Rabin & Karp. A brute force approach - is used to find longer strings when a small match has been found. - A similar algorithm is used in comic (by Jan-Mark Wams) and freeze - (by Leonid Broukhis). - A previous version of this file used a more sophisticated algorithm - (by Fiala and Greene) which is guaranteed to run in linear amortized - time, but has a larger average cost, uses more memory and is patented. - However the F&G algorithm may be faster for some highly redundant - files if the parameter max_chain_length (described below) is too large. - - ACKNOWLEDGEMENTS - - The idea of lazy evaluation of matches is due to Jan-Mark Wams, and - I found it in 'freeze' written by Leonid Broukhis. - Thanks to many people for bug reports and testing. - - REFERENCES - - Deutsch, L.P.,"'Deflate' Compressed Data Format Specification". - Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc - - A description of the Rabin and Karp algorithm is given in the book - "Algorithms" by R. Sedgewick, Addison-Wesley, p252. - - Fiala,E.R., and Greene,D.H. - Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595} - -interface - -{$I imzconf.inc} - -uses - imzutil, impaszlib; - - -function deflateInit_(strm : z_streamp; - level : int; - const version : AnsiString; - stream_size : int) : int; - - -function deflateInit (var strm : z_stream; level : int) : int; - -{ Initializes the internal stream state for compression. The fields - zalloc, zfree and opaque must be initialized before by the caller. - If zalloc and zfree are set to Z_NULL, deflateInit updates them to - use default allocation functions. - - The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9: - 1 gives best speed, 9 gives best compression, 0 gives no compression at - all (the input data is simply copied a block at a time). - Z_DEFAULT_COMPRESSION requests a default compromise between speed and - compression (currently equivalent to level 6). - - deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not - enough memory, Z_STREAM_ERROR if level is not a valid compression level, - Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible - with the version assumed by the caller (ZLIB_VERSION). - msg is set to null if there is no error message. deflateInit does not - perform any compression: this will be done by deflate(). } - - -{EXPORT} -function deflate (var strm : z_stream; flush : int) : int; - -{ Performs one or both of the following actions: - - - Compress more input starting at next_in and update next_in and avail_in - accordingly. If not all input can be processed (because there is not - enough room in the output buffer), next_in and avail_in are updated and - processing will resume at this point for the next call of deflate(). - - - Provide more output starting at next_out and update next_out and avail_out - accordingly. This action is forced if the parameter flush is non zero. - Forcing flush frequently degrades the compression ratio, so this parameter - should be set only when necessary (in interactive applications). - Some output may be provided even if flush is not set. - - Before the call of deflate(), the application should ensure that at least - one of the actions is possible, by providing more input and/or consuming - more output, and updating avail_in or avail_out accordingly; avail_out - should never be zero before the call. The application can consume the - compressed output when it wants, for example when the output buffer is full - (avail_out == 0), or after each call of deflate(). If deflate returns Z_OK - and with zero avail_out, it must be called again after making room in the - output buffer because there might be more output pending. - - If the parameter flush is set to Z_PARTIAL_FLUSH, the current compression - block is terminated and flushed to the output buffer so that the - decompressor can get all input data available so far. For method 9, a future - variant on method 8, the current block will be flushed but not terminated. - Z_SYNC_FLUSH has the same effect as partial flush except that the compressed - output is byte aligned (the compressor can clear its internal bit buffer) - and the current block is always terminated; this can be useful if the - compressor has to be restarted from scratch after an interruption (in which - case the internal state of the compressor may be lost). - If flush is set to Z_FULL_FLUSH, the compression block is terminated, a - special marker is output and the compression dictionary is discarded; this - is useful to allow the decompressor to synchronize if one compressed block - has been damaged (see inflateSync below). Flushing degrades compression and - so should be used only when necessary. Using Z_FULL_FLUSH too often can - seriously degrade the compression. If deflate returns with avail_out == 0, - this function must be called again with the same value of the flush - parameter and more output space (updated avail_out), until the flush is - complete (deflate returns with non-zero avail_out). - - If the parameter flush is set to Z_FINISH, all pending input is processed, - all pending output is flushed and deflate returns with Z_STREAM_END if there - was enough output space; if deflate returns with Z_OK, this function must be - called again with Z_FINISH and more output space (updated avail_out) but no - more input data, until it returns with Z_STREAM_END or an error. After - deflate has returned Z_STREAM_END, the only possible operations on the - stream are deflateReset or deflateEnd. - - Z_FINISH can be used immediately after deflateInit if all the compression - is to be done in a single step. In this case, avail_out must be at least - 0.1% larger than avail_in plus 12 bytes. If deflate does not return - Z_STREAM_END, then it must be called again as described above. - - deflate() may update data_type if it can make a good guess about - the input data type (Z_ASCII or Z_BINARY). In doubt, the data is considered - binary. This field is only for information purposes and does not affect - the compression algorithm in any manner. - - deflate() returns Z_OK if some progress has been made (more input - processed or more output produced), Z_STREAM_END if all input has been - consumed and all output has been produced (only when flush is set to - Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example - if next_in or next_out was NULL), Z_BUF_ERROR if no progress is possible. } - - -function deflateEnd (var strm : z_stream) : int; - -{ All dynamically allocated data structures for this stream are freed. - This function discards any unprocessed input and does not flush any - pending output. - - deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the - stream state was inconsistent, Z_DATA_ERROR if the stream was freed - prematurely (some input or output was discarded). In the error case, - msg may be set but then points to a static string (which must not be - deallocated). } - - - - - { Advanced functions } - -{ The following functions are needed only in some special applications. } - - -{EXPORT} -function deflateInit2 (var strm : z_stream; - level : int; - method : int; - windowBits : int; - memLevel : int; - strategy : int) : int; - -{ This is another version of deflateInit with more compression options. The - fields next_in, zalloc, zfree and opaque must be initialized before by - the caller. - - The method parameter is the compression method. It must be Z_DEFLATED in - this version of the library. (Method 9 will allow a 64K history buffer and - partial block flushes.) - - The windowBits parameter is the base two logarithm of the window size - (the size of the history buffer). It should be in the range 8..15 for this - version of the library (the value 16 will be allowed for method 9). Larger - values of this parameter result in better compression at the expense of - memory usage. The default value is 15 if deflateInit is used instead. - - The memLevel parameter specifies how much memory should be allocated - for the internal compression state. memLevel=1 uses minimum memory but - is slow and reduces compression ratio; memLevel=9 uses maximum memory - for optimal speed. The default value is 8. See zconf.h for total memory - usage as a function of windowBits and memLevel. - - The strategy parameter is used to tune the compression algorithm. Use the - value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a - filter (or predictor), or Z_HUFFMAN_ONLY to force Huffman encoding only (no - string match). Filtered data consists mostly of small values with a - somewhat random distribution. In this case, the compression algorithm is - tuned to compress them better. The effect of Z_FILTERED is to force more - Huffman coding and less string matching; it is somewhat intermediate - between Z_DEFAULT and Z_HUFFMAN_ONLY. The strategy parameter only affects - the compression ratio but not the correctness of the compressed output even - if it is not set appropriately. - - If next_in is not null, the library will use this buffer to hold also - some history information; the buffer must either hold the entire input - data, or have at least 1<<(windowBits+1) bytes and be writable. If next_in - is null, the library will allocate its own history buffer (and leave next_in - null). next_out need not be provided here but must be provided by the - application for the next call of deflate(). - - If the history buffer is provided by the application, next_in must - must never be changed by the application since the compressor maintains - information inside this buffer from call to call; the application - must provide more input only by increasing avail_in. next_in is always - reset by the library in this case. - - deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was - not enough memory, Z_STREAM_ERROR if a parameter is invalid (such as - an invalid method). msg is set to null if there is no error message. - deflateInit2 does not perform any compression: this will be done by - deflate(). } - - -{EXPORT} -function deflateSetDictionary (var strm : z_stream; - dictionary : pBytef; {const bytes} - dictLength : uint) : int; - -{ Initializes the compression dictionary (history buffer) from the given - byte sequence without producing any compressed output. This function must - be called immediately after deflateInit or deflateInit2, before any call - of deflate. The compressor and decompressor must use exactly the same - dictionary (see inflateSetDictionary). - The dictionary should consist of strings (byte sequences) that are likely - to be encountered later in the data to be compressed, with the most commonly - used strings preferably put towards the end of the dictionary. Using a - dictionary is most useful when the data to be compressed is short and - can be predicted with good accuracy; the data can then be compressed better - than with the default empty dictionary. In this version of the library, - only the last 32K bytes of the dictionary are used. - Upon return of this function, strm->adler is set to the Adler32 value - of the dictionary; the decompressor may later use this value to determine - which dictionary has been used by the compressor. (The Adler32 value - applies to the whole dictionary even if only a subset of the dictionary is - actually used by the compressor.) - - deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a - parameter is invalid (such as NULL dictionary) or the stream state - is inconsistent (for example if deflate has already been called for this - stream). deflateSetDictionary does not perform any compression: this will - be done by deflate(). } - -{EXPORT} -function deflateCopy (dest : z_streamp; - source : z_streamp) : int; - -{ Sets the destination stream as a complete copy of the source stream. If - the source stream is using an application-supplied history buffer, a new - buffer is allocated for the destination stream. The compressed output - buffer is always application-supplied. It's the responsibility of the - application to provide the correct values of next_out and avail_out for the - next call of deflate. - - This function can be useful when several compression strategies will be - tried, for example when there are several ways of pre-processing the input - data with a filter. The streams that will be discarded should then be freed - by calling deflateEnd. Note that deflateCopy duplicates the internal - compression state which can be quite large, so this strategy is slow and - can consume lots of memory. - - deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not - enough memory, Z_STREAM_ERROR if the source stream state was inconsistent - (such as zalloc being NULL). msg is left unchanged in both source and - destination. } - -{EXPORT} -function deflateReset (var strm : z_stream) : int; - -{ This function is equivalent to deflateEnd followed by deflateInit, - but does not free and reallocate all the internal compression state. - The stream will keep the same compression level and any other attributes - that may have been set by deflateInit2. - - deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source - stream state was inconsistent (such as zalloc or state being NIL). } - - -{EXPORT} -function deflateParams (var strm : z_stream; level : int; strategy : int) : int; - -{ Dynamically update the compression level and compression strategy. - This can be used to switch between compression and straight copy of - the input data, or to switch to a different kind of input data requiring - a different strategy. If the compression level is changed, the input - available so far is compressed with the old level (and may be flushed); - the new level will take effect only at the next call of deflate(). - - Before the call of deflateParams, the stream state must be set as for - a call of deflate(), since the currently available input may have to - be compressed and flushed. In particular, strm->avail_out must be non-zero. - - deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source - stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR - if strm->avail_out was zero. } - - -const - deflate_copyright : string = ' deflate 1.1.2 Copyright 1995-1998 Jean-loup Gailly '; - -{ If you use the zlib library in a product, an acknowledgment is welcome - in the documentation of your product. If for some reason you cannot - include such an acknowledgment, I would appreciate that you keep this - copyright string in the executable of your product. } - -implementation - -uses - imtrees, imadler; - -{ =========================================================================== - Function prototypes. } - -type - block_state = ( - need_more, { block not completed, need more input or more output } - block_done, { block flush performed } - finish_started, { finish started, need only more output at next deflate } - finish_done); { finish done, accept no more input or output } - -{ Compression function. Returns the block state after the call. } -type - compress_func = function(var s : deflate_state; flush : int) : block_state; - -{local} -procedure fill_window(var s : deflate_state); forward; -{local} -function deflate_stored(var s : deflate_state; flush : int) : block_state; forward; -{local} -function deflate_fast(var s : deflate_state; flush : int) : block_state; forward; -{local} -function deflate_slow(var s : deflate_state; flush : int) : block_state; forward; -{local} -procedure lm_init(var s : deflate_state); forward; - -{local} -procedure putShortMSB(var s : deflate_state; b : uInt); forward; -{local} -procedure flush_pending (var strm : z_stream); forward; -{local} -function read_buf(strm : z_streamp; - buf : pBytef; - size : unsigned) : int; forward; -{$ifdef ASMV} -procedure match_init; { asm code initialization } -function longest_match(var deflate_state; cur_match : IPos) : uInt; forward; -{$else} -{local} -function longest_match(var s : deflate_state; cur_match : IPos) : uInt; - forward; -{$endif} - -{$ifdef DEBUG} -{local} -procedure check_match(var s : deflate_state; - start, match : IPos; - length : int); forward; -{$endif} - -{ ========================================================================== - local data } - -const - ZNIL = 0; -{ Tail of hash chains } - -const - TOO_FAR = 4096; -{ Matches of length 3 are discarded if their distance exceeds TOO_FAR } - -const - MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1); -{ Minimum amount of lookahead, except at the end of the input file. - See deflate.c for comments about the MIN_MATCH+1. } - -{macro MAX_DIST(var s : deflate_state) : uInt; -begin - MAX_DIST := (s.w_size - MIN_LOOKAHEAD); -end; - In order to simplify the code, particularly on 16 bit machines, match - distances are limited to MAX_DIST instead of WSIZE. } - - -{ Values for max_lazy_match, good_match and max_chain_length, depending on - the desired pack level (0..9). The values given below have been tuned to - exclude worst case performance for pathological files. Better values may be - found for specific files. } - -type - config = record - good_length : ush; { reduce lazy search above this match length } - max_lazy : ush; { do not perform lazy search above this match length } - nice_length : ush; { quit search above this match length } - max_chain : ush; - func : compress_func; - end; - -{local} -const - configuration_table : array[0..10-1] of config = ( -{ good lazy nice chain } -{0} (good_length:0; max_lazy:0; nice_length:0; max_chain:0; func:deflate_stored), { store only } -{1} (good_length:4; max_lazy:4; nice_length:8; max_chain:4; func:deflate_fast), { maximum speed, no lazy matches } -{2} (good_length:4; max_lazy:5; nice_length:16; max_chain:8; func:deflate_fast), -{3} (good_length:4; max_lazy:6; nice_length:32; max_chain:32; func:deflate_fast), - -{4} (good_length:4; max_lazy:4; nice_length:16; max_chain:16; func:deflate_slow), { lazy matches } -{5} (good_length:8; max_lazy:16; nice_length:32; max_chain:32; func:deflate_slow), -{6} (good_length:8; max_lazy:16; nice_length:128; max_chain:128; func:deflate_slow), -{7} (good_length:8; max_lazy:32; nice_length:128; max_chain:256; func:deflate_slow), -{8} (good_length:32; max_lazy:128; nice_length:258; max_chain:1024; func:deflate_slow), -{9} (good_length:32; max_lazy:258; nice_length:258; max_chain:4096; func:deflate_slow)); { maximum compression } - -{ Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4 - For deflate_fast() (levels <= 3) good is ignored and lazy has a different - meaning. } - -const - EQUAL = 0; -{ result of memcmp for equal strings } - -{ ========================================================================== - Update a hash value with the given input byte - IN assertion: all calls to to UPDATE_HASH are made with consecutive - input characters, so that a running hash key can be computed from the - previous key instead of complete recalculation each time. - -macro UPDATE_HASH(s,h,c) - h := (( (h) shl s^.hash_shift) xor (c)) and s^.hash_mask; -} - -{ =========================================================================== - Insert string str in the dictionary and set match_head to the previous head - of the hash chain (the most recent string with same hash key). Return - the previous length of the hash chain. - If this file is compiled with -DFASTEST, the compression level is forced - to 1, and no hash chains are maintained. - IN assertion: all calls to to INSERT_STRING are made with consecutive - input characters and the first MIN_MATCH bytes of str are valid - (except for the last MIN_MATCH-1 bytes of the input file). } - -procedure INSERT_STRING(var s : deflate_state; - str : uInt; - var match_head : IPos); -begin -{$ifdef FASTEST} - {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])} - s.ins_h := ((s.ins_h shl s.hash_shift) xor - (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask; - match_head := s.head[s.ins_h] - s.head[s.ins_h] := Pos(str); -{$else} - {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])} - s.ins_h := ((s.ins_h shl s.hash_shift) xor - (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask; - - match_head := s.head^[s.ins_h]; - s.prev^[(str) and s.w_mask] := match_head; - s.head^[s.ins_h] := Pos(str); -{$endif} -end; - -{ ========================================================================= - Initialize the hash table (avoiding 64K overflow for 16 bit systems). - prev[] will be initialized on the fly. - -macro CLEAR_HASH(s) - s^.head[s^.hash_size-1] := ZNIL; - zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0])); -} - -{ ======================================================================== } - -function deflateInit2_(var strm : z_stream; - level : int; - method : int; - windowBits : int; - memLevel : int; - strategy : int; - const version : AnsiString; - stream_size : int) : int; -var - s : deflate_state_ptr; - noheader : int; - - overlay : pushfArray; - { We overlay pending_buf and d_buf+l_buf. This works since the average - output size for (length,distance) codes is <= 24 bits. } -begin - noheader := 0; - if (version = '') or (version[1] <> ZLIB_VERSION[1]) or - (stream_size <> sizeof(z_stream)) then - begin - deflateInit2_ := Z_VERSION_ERROR; - exit; - end; - { - if (strm = Z_NULL) then - begin - deflateInit2_ := Z_STREAM_ERROR; - exit; - end; - } - { SetLength(strm.msg, 255); } - strm.msg := ''; - if not Assigned(strm.zalloc) then - begin - {$IFDEF FPC} strm.zalloc := @zcalloc; {$ELSE} - strm.zalloc := zcalloc; - {$ENDIF} - strm.opaque := voidpf(0); - end; - if not Assigned(strm.zfree) then - {$IFDEF FPC} strm.zfree := @zcfree; {$ELSE} - strm.zfree := zcfree; - {$ENDIF} - - if (level = Z_DEFAULT_COMPRESSION) then - level := 6; -{$ifdef FASTEST} - level := 1; -{$endif} - - if (windowBits < 0) then { undocumented feature: suppress zlib header } - begin - noheader := 1; - windowBits := -windowBits; - end; - if (memLevel < 1) or (memLevel > MAX_MEM_LEVEL) or (method <> Z_DEFLATED) - or (windowBits < 8) or (windowBits > 15) or (level < 0) - or (level > 9) or (strategy < 0) or (strategy > Z_HUFFMAN_ONLY) then - begin - deflateInit2_ := Z_STREAM_ERROR; - exit; - end; - - s := deflate_state_ptr (ZALLOC(strm, 1, sizeof(deflate_state))); - if (s = Z_NULL) then - begin - deflateInit2_ := Z_MEM_ERROR; - exit; - end; - strm.state := pInternal_state(s); - s^.strm := @strm; - - s^.noheader := noheader; - s^.w_bits := windowBits; - s^.w_size := 1 shl s^.w_bits; - s^.w_mask := s^.w_size - 1; - - s^.hash_bits := memLevel + 7; - s^.hash_size := 1 shl s^.hash_bits; - s^.hash_mask := s^.hash_size - 1; - s^.hash_shift := ((s^.hash_bits+MIN_MATCH-1) div MIN_MATCH); - - s^.window := pzByteArray (ZALLOC(strm, s^.w_size, 2*sizeof(Byte))); - s^.prev := pzPosfArray (ZALLOC(strm, s^.w_size, sizeof(Pos))); - s^.head := pzPosfArray (ZALLOC(strm, s^.hash_size, sizeof(Pos))); - - s^.lit_bufsize := 1 shl (memLevel + 6); { 16K elements by default } - - overlay := pushfArray (ZALLOC(strm, s^.lit_bufsize, sizeof(ush)+2)); - s^.pending_buf := pzByteArray (overlay); - s^.pending_buf_size := ulg(s^.lit_bufsize) * (sizeof(ush)+Long(2)); - - if (s^.window = Z_NULL) or (s^.prev = Z_NULL) or (s^.head = Z_NULL) - or (s^.pending_buf = Z_NULL) then - begin - {ERR_MSG(Z_MEM_ERROR);} - strm.msg := z_errmsg[z_errbase-Z_MEM_ERROR]; - deflateEnd (strm); - deflateInit2_ := Z_MEM_ERROR; - exit; - end; - s^.d_buf := pushfArray( @overlay^[s^.lit_bufsize div sizeof(ush)] ); - s^.l_buf := puchfArray( @s^.pending_buf^[(1+sizeof(ush))*s^.lit_bufsize] ); - - s^.level := level; - s^.strategy := strategy; - s^.method := Byte(method); - - deflateInit2_ := deflateReset(strm); -end; - -{ ========================================================================= } - -function deflateInit2(var strm : z_stream; - level : int; - method : int; - windowBits : int; - memLevel : int; - strategy : int) : int; -{ a macro } -begin - deflateInit2 := deflateInit2_(strm, level, method, windowBits, - memLevel, strategy, ZLIB_VERSION, sizeof(z_stream)); -end; - -{ ========================================================================= } - -function deflateInit_(strm : z_streamp; - level : int; - const version : AnsiString; - stream_size : int) : int; -begin - if (strm = Z_NULL) then - deflateInit_ := Z_STREAM_ERROR - else - deflateInit_ := deflateInit2_(strm^, level, Z_DEFLATED, MAX_WBITS, - DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, version, stream_size); - { To do: ignore strm^.next_in if we use it as window } -end; - -{ ========================================================================= } - -function deflateInit(var strm : z_stream; level : int) : int; -{ deflateInit is a macro to allow checking the zlib version - and the compiler's view of z_stream: } -begin - deflateInit := deflateInit2_(strm, level, Z_DEFLATED, MAX_WBITS, - DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, ZLIB_VERSION, sizeof(z_stream)); -end; - -{ ======================================================================== } -function deflateSetDictionary (var strm : z_stream; - dictionary : pBytef; - dictLength : uInt) : int; -var - s : deflate_state_ptr; - length : uInt; - n : uInt; - hash_head : IPos; -var - MAX_DIST : uInt; {macro} -begin - length := dictLength; - hash_head := 0; - - if {(@strm = Z_NULL) or} - (strm.state = Z_NULL) or (dictionary = Z_NULL) - or (deflate_state_ptr(strm.state)^.status <> INIT_STATE) then - begin - deflateSetDictionary := Z_STREAM_ERROR; - exit; - end; - - s := deflate_state_ptr(strm.state); - strm.adler := adler32(strm.adler, dictionary, dictLength); - - if (length < MIN_MATCH) then - begin - deflateSetDictionary := Z_OK; - exit; - end; - MAX_DIST := (s^.w_size - MIN_LOOKAHEAD); - if (length > MAX_DIST) then - begin - length := MAX_DIST; -{$ifndef USE_DICT_HEAD} - Inc(dictionary, dictLength - length); { use the tail of the dictionary } -{$endif} - end; - - zmemcpy( pBytef(s^.window), dictionary, length); - s^.strstart := length; - s^.block_start := long(length); - - { Insert all strings in the hash table (except for the last two bytes). - s^.lookahead stays null, so s^.ins_h will be recomputed at the next - call of fill_window. } - - s^.ins_h := s^.window^[0]; - {UPDATE_HASH(s, s^.ins_h, s^.window[1]);} - s^.ins_h := ((s^.ins_h shl s^.hash_shift) xor (s^.window^[1])) - and s^.hash_mask; - - for n := 0 to length - MIN_MATCH do - begin - INSERT_STRING(s^, n, hash_head); - end; - {if (hash_head <> 0) then - hash_head := 0; - to make compiler happy } - deflateSetDictionary := Z_OK; -end; - -{ ======================================================================== } -function deflateReset (var strm : z_stream) : int; -var - s : deflate_state_ptr; -begin - if {(@strm = Z_NULL) or} - (strm.state = Z_NULL) - or (not Assigned(strm.zalloc)) or (not Assigned(strm.zfree)) then - begin - deflateReset := Z_STREAM_ERROR; - exit; - end; - - strm.total_out := 0; - strm.total_in := 0; - strm.msg := ''; { use zfree if we ever allocate msg dynamically } - strm.data_type := Z_UNKNOWN; - - s := deflate_state_ptr(strm.state); - s^.pending := 0; - s^.pending_out := pBytef(s^.pending_buf); - - if (s^.noheader < 0) then - begin - s^.noheader := 0; { was set to -1 by deflate(..., Z_FINISH); } - end; - if s^.noheader <> 0 then - s^.status := BUSY_STATE - else - s^.status := INIT_STATE; - strm.adler := 1; - s^.last_flush := Z_NO_FLUSH; - - _tr_init(s^); - lm_init(s^); - - deflateReset := Z_OK; -end; - -{ ======================================================================== } -function deflateParams(var strm : z_stream; - level : int; - strategy : int) : int; -var - s : deflate_state_ptr; - func : compress_func; - err : int; -begin - err := Z_OK; - if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then - begin - deflateParams := Z_STREAM_ERROR; - exit; - end; - - s := deflate_state_ptr(strm.state); - - if (level = Z_DEFAULT_COMPRESSION) then - begin - level := 6; - end; - if (level < 0) or (level > 9) or (strategy < 0) - or (strategy > Z_HUFFMAN_ONLY) then - begin - deflateParams := Z_STREAM_ERROR; - exit; - end; - func := configuration_table[s^.level].func; - - if (@func <> @configuration_table[level].func) - and (strm.total_in <> 0) then - begin - { Flush the last buffer: } - err := deflate(strm, Z_PARTIAL_FLUSH); - end; - if (s^.level <> level) then - begin - s^.level := level; - s^.max_lazy_match := configuration_table[level].max_lazy; - s^.good_match := configuration_table[level].good_length; - s^.nice_match := configuration_table[level].nice_length; - s^.max_chain_length := configuration_table[level].max_chain; - end; - s^.strategy := strategy; - deflateParams := err; -end; - -{ ========================================================================= - Put a short in the pending buffer. The 16-bit value is put in MSB order. - IN assertion: the stream state is correct and there is enough room in - pending_buf. } - -{local} -procedure putShortMSB (var s : deflate_state; b : uInt); -begin - s.pending_buf^[s.pending] := Byte(b shr 8); - Inc(s.pending); - s.pending_buf^[s.pending] := Byte(b and $ff); - Inc(s.pending); -end; - -{ ========================================================================= - Flush as much pending output as possible. All deflate() output goes - through this function so some applications may wish to modify it - to avoid allocating a large strm^.next_out buffer and copying into it. - (See also read_buf()). } - -{local} -procedure flush_pending(var strm : z_stream); -var - len : unsigned; - s : deflate_state_ptr; -begin - s := deflate_state_ptr(strm.state); - len := s^.pending; - - if (len > strm.avail_out) then - len := strm.avail_out; - if (len = 0) then - exit; - - zmemcpy(strm.next_out, s^.pending_out, len); - Inc(strm.next_out, len); - Inc(s^.pending_out, len); - Inc(strm.total_out, len); - Dec(strm.avail_out, len); - Dec(s^.pending, len); - if (s^.pending = 0) then - begin - s^.pending_out := pBytef(s^.pending_buf); - end; -end; - -{ ========================================================================= } -function deflate (var strm : z_stream; flush : int) : int; -var - old_flush : int; { value of flush param for previous deflate call } - s : deflate_state_ptr; -var - header : uInt; - level_flags : uInt; -var - bstate : block_state; -begin - if {(@strm = Z_NULL) or} (strm.state = Z_NULL) - or (flush > Z_FINISH) or (flush < 0) then - begin - deflate := Z_STREAM_ERROR; - exit; - end; - s := deflate_state_ptr(strm.state); - - if (strm.next_out = Z_NULL) or - ((strm.next_in = Z_NULL) and (strm.avail_in <> 0)) or - ((s^.status = FINISH_STATE) and (flush <> Z_FINISH)) then - begin - {ERR_RETURN(strm^, Z_STREAM_ERROR);} - strm.msg := z_errmsg[z_errbase - Z_STREAM_ERROR]; - deflate := Z_STREAM_ERROR; - exit; - end; - if (strm.avail_out = 0) then - begin - {ERR_RETURN(strm^, Z_BUF_ERROR);} - strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; - deflate := Z_BUF_ERROR; - exit; - end; - - s^.strm := @strm; { just in case } - old_flush := s^.last_flush; - s^.last_flush := flush; - - { Write the zlib header } - if (s^.status = INIT_STATE) then - begin - - header := (Z_DEFLATED + ((s^.w_bits-8) shl 4)) shl 8; - level_flags := (s^.level-1) shr 1; - - if (level_flags > 3) then - level_flags := 3; - header := header or (level_flags shl 6); - if (s^.strstart <> 0) then - header := header or PRESET_DICT; - Inc(header, 31 - (header mod 31)); - - s^.status := BUSY_STATE; - putShortMSB(s^, header); - - { Save the adler32 of the preset dictionary: } - if (s^.strstart <> 0) then - begin - putShortMSB(s^, uInt(strm.adler shr 16)); - putShortMSB(s^, uInt(strm.adler and $ffff)); - end; - strm.adler := long(1); - end; - - { Flush as much pending output as possible } - if (s^.pending <> 0) then - begin - flush_pending(strm); - if (strm.avail_out = 0) then - begin - { Since avail_out is 0, deflate will be called again with - more output space, but possibly with both pending and - avail_in equal to zero. There won't be anything to do, - but this is not an error situation so make sure we - return OK instead of BUF_ERROR at next call of deflate: } - - s^.last_flush := -1; - deflate := Z_OK; - exit; - end; - - { Make sure there is something to do and avoid duplicate consecutive - flushes. For repeated and useless calls with Z_FINISH, we keep - returning Z_STREAM_END instead of Z_BUFF_ERROR. } - - end - else - if (strm.avail_in = 0) and (flush <= old_flush) - and (flush <> Z_FINISH) then - begin - {ERR_RETURN(strm^, Z_BUF_ERROR);} - strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; - deflate := Z_BUF_ERROR; - exit; - end; - - { User must not provide more input after the first FINISH: } - if (s^.status = FINISH_STATE) and (strm.avail_in <> 0) then - begin - {ERR_RETURN(strm^, Z_BUF_ERROR);} - strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; - deflate := Z_BUF_ERROR; - exit; - end; - - { Start a new block or continue the current one. } - if (strm.avail_in <> 0) or (s^.lookahead <> 0) - or ((flush <> Z_NO_FLUSH) and (s^.status <> FINISH_STATE)) then - begin - bstate := configuration_table[s^.level].func(s^, flush); - - if (bstate = finish_started) or (bstate = finish_done) then - s^.status := FINISH_STATE; - - if (bstate = need_more) or (bstate = finish_started) then - begin - if (strm.avail_out = 0) then - s^.last_flush := -1; { avoid BUF_ERROR next call, see above } - - deflate := Z_OK; - exit; - { If flush != Z_NO_FLUSH && avail_out == 0, the next call - of deflate should use the same flush parameter to make sure - that the flush is complete. So we don't have to output an - empty block here, this will be done at next call. This also - ensures that for a very small output buffer, we emit at most - one empty block. } - end; - if (bstate = block_done) then - begin - if (flush = Z_PARTIAL_FLUSH) then - _tr_align(s^) - else - begin { FULL_FLUSH or SYNC_FLUSH } - _tr_stored_block(s^, pcharf(NIL), Long(0), FALSE); - { For a full flush, this empty block will be recognized - as a special marker by inflate_sync(). } - - if (flush = Z_FULL_FLUSH) then - begin - {macro CLEAR_HASH(s);} { forget history } - s^.head^[s^.hash_size-1] := ZNIL; - zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0])); - end; - end; - - flush_pending(strm); - if (strm.avail_out = 0) then - begin - s^.last_flush := -1; { avoid BUF_ERROR at next call, see above } - deflate := Z_OK; - exit; - end; - - end; - end; - {$IFDEF DEBUG} - Assert(strm.avail_out > 0, 'bug2'); - {$ENDIF} - if (flush <> Z_FINISH) then - begin - deflate := Z_OK; - exit; - end; - - if (s^.noheader <> 0) then - begin - deflate := Z_STREAM_END; - exit; - end; - - { Write the zlib trailer (adler32) } - putShortMSB(s^, uInt(strm.adler shr 16)); - putShortMSB(s^, uInt(strm.adler and $ffff)); - flush_pending(strm); - { If avail_out is zero, the application will call deflate again - to flush the rest. } - - s^.noheader := -1; { write the trailer only once! } - if s^.pending <> 0 then - deflate := Z_OK - else - deflate := Z_STREAM_END; -end; - -{ ========================================================================= } -function deflateEnd (var strm : z_stream) : int; -var - status : int; - s : deflate_state_ptr; -begin - if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then - begin - deflateEnd := Z_STREAM_ERROR; - exit; - end; - - s := deflate_state_ptr(strm.state); - status := s^.status; - if (status <> INIT_STATE) and (status <> BUSY_STATE) and - (status <> FINISH_STATE) then - begin - deflateEnd := Z_STREAM_ERROR; - exit; - end; - - { Deallocate in reverse order of allocations: } - TRY_FREE(strm, s^.pending_buf); - TRY_FREE(strm, s^.head); - TRY_FREE(strm, s^.prev); - TRY_FREE(strm, s^.window); - - ZFREE(strm, s); - strm.state := Z_NULL; - - if status = BUSY_STATE then - deflateEnd := Z_DATA_ERROR - else - deflateEnd := Z_OK; -end; - -{ ========================================================================= - Copy the source state to the destination state. - To simplify the source, this is not supported for 16-bit MSDOS (which - doesn't have enough memory anyway to duplicate compression states). } - - -{ ========================================================================= } -function deflateCopy (dest, source : z_streamp) : int; -{$ifndef MAXSEG_64K} -var - ds : deflate_state_ptr; - ss : deflate_state_ptr; - overlay : pushfArray; -{$endif} -begin -{$ifdef MAXSEG_64K} - deflateCopy := Z_STREAM_ERROR; - exit; -{$else} - - if (source = Z_NULL) or (dest = Z_NULL) or (source^.state = Z_NULL) then - begin - deflateCopy := Z_STREAM_ERROR; - exit; - end; - ss := deflate_state_ptr(source^.state); - dest^ := source^; - - ds := deflate_state_ptr( ZALLOC(dest^, 1, sizeof(deflate_state)) ); - if (ds = Z_NULL) then - begin - deflateCopy := Z_MEM_ERROR; - exit; - end; - dest^.state := pInternal_state(ds); - ds^ := ss^; - ds^.strm := dest; - - ds^.window := pzByteArray ( ZALLOC(dest^, ds^.w_size, 2*sizeof(Byte)) ); - ds^.prev := pzPosfArray ( ZALLOC(dest^, ds^.w_size, sizeof(Pos)) ); - ds^.head := pzPosfArray ( ZALLOC(dest^, ds^.hash_size, sizeof(Pos)) ); - overlay := pushfArray ( ZALLOC(dest^, ds^.lit_bufsize, sizeof(ush)+2) ); - ds^.pending_buf := pzByteArray ( overlay ); - - if (ds^.window = Z_NULL) or (ds^.prev = Z_NULL) or (ds^.head = Z_NULL) - or (ds^.pending_buf = Z_NULL) then - begin - deflateEnd (dest^); - deflateCopy := Z_MEM_ERROR; - exit; - end; - { following zmemcpy do not work for 16-bit MSDOS } - zmemcpy(pBytef(ds^.window), pBytef(ss^.window), ds^.w_size * 2 * sizeof(Byte)); - zmemcpy(pBytef(ds^.prev), pBytef(ss^.prev), ds^.w_size * sizeof(Pos)); - zmemcpy(pBytef(ds^.head), pBytef(ss^.head), ds^.hash_size * sizeof(Pos)); - zmemcpy(pBytef(ds^.pending_buf), pBytef(ss^.pending_buf), uInt(ds^.pending_buf_size)); - - ds^.pending_out := @ds^.pending_buf^[ptr2int(ss^.pending_out) - ptr2int(ss^.pending_buf)]; - ds^.d_buf := pushfArray (@overlay^[ds^.lit_bufsize div sizeof(ush)] ); - ds^.l_buf := puchfArray (@ds^.pending_buf^[(1+sizeof(ush))*ds^.lit_bufsize]); - - ds^.l_desc.dyn_tree := tree_ptr(@ds^.dyn_ltree); - ds^.d_desc.dyn_tree := tree_ptr(@ds^.dyn_dtree); - ds^.bl_desc.dyn_tree := tree_ptr(@ds^.bl_tree); - - deflateCopy := Z_OK; -{$endif} -end; - - -{ =========================================================================== - Read a new buffer from the current input stream, update the adler32 - and total number of bytes read. All deflate() input goes through - this function so some applications may wish to modify it to avoid - allocating a large strm^.next_in buffer and copying from it. - (See also flush_pending()). } - -{local} -function read_buf(strm : z_streamp; buf : pBytef; size : unsigned) : int; -var - len : unsigned; -begin - len := strm^.avail_in; - - if (len > size) then - len := size; - if (len = 0) then - begin - read_buf := 0; - exit; - end; - - Dec(strm^.avail_in, len); - - if deflate_state_ptr(strm^.state)^.noheader = 0 then - begin - strm^.adler := adler32(strm^.adler, strm^.next_in, len); - end; - zmemcpy(buf, strm^.next_in, len); - Inc(strm^.next_in, len); - Inc(strm^.total_in, len); - - read_buf := int(len); -end; - -{ =========================================================================== - Initialize the "longest match" routines for a new zlib stream } - -{local} -procedure lm_init (var s : deflate_state); -begin - s.window_size := ulg( uLong(2)*s.w_size); - - {macro CLEAR_HASH(s);} - s.head^[s.hash_size-1] := ZNIL; - zmemzero(pBytef(s.head), unsigned(s.hash_size-1)*sizeof(s.head^[0])); - - { Set the default configuration parameters: } - - s.max_lazy_match := configuration_table[s.level].max_lazy; - s.good_match := configuration_table[s.level].good_length; - s.nice_match := configuration_table[s.level].nice_length; - s.max_chain_length := configuration_table[s.level].max_chain; - - s.strstart := 0; - s.block_start := long(0); - s.lookahead := 0; - s.prev_length := MIN_MATCH-1; - s.match_length := MIN_MATCH-1; - s.match_available := FALSE; - s.ins_h := 0; -{$ifdef ASMV} - match_init; { initialize the asm code } -{$endif} -end; - -{ =========================================================================== - Set match_start to the longest match starting at the given string and - return its length. Matches shorter or equal to prev_length are discarded, - in which case the result is equal to prev_length and match_start is - garbage. - IN assertions: cur_match is the head of the hash chain for the current - string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1 - OUT assertion: the match length is not greater than s^.lookahead. } - - -{$ifndef ASMV} -{ For 80x86 and 680x0, an optimized version will be provided in match.asm or - match.S. The code will be functionally equivalent. } - -{$ifndef FASTEST} - -{local} -function longest_match(var s : deflate_state; - cur_match : IPos { current match } - ) : uInt; -label - nextstep; -var - chain_length : unsigned; { max hash chain length } - {register} scan : pBytef; { current string } - {register} match : pBytef; { matched string } - {register} len : int; { length of current match } - best_len : int; { best match length so far } - nice_match : int; { stop if match long enough } - limit : IPos; - - prev : pzPosfArray; - wmask : uInt; -{$ifdef UNALIGNED_OK} - {register} strend : pBytef; - {register} scan_start : ush; - {register} scan_end : ush; -{$else} - {register} strend : pBytef; - {register} scan_end1 : Byte; - {register} scan_end : Byte; -{$endif} -var - MAX_DIST : uInt; -begin - chain_length := s.max_chain_length; { max hash chain length } - scan := @(s.window^[s.strstart]); - best_len := s.prev_length; { best match length so far } - nice_match := s.nice_match; { stop if match long enough } - - - MAX_DIST := s.w_size - MIN_LOOKAHEAD; -{In order to simplify the code, particularly on 16 bit machines, match -distances are limited to MAX_DIST instead of WSIZE. } - - if s.strstart > IPos(MAX_DIST) then - limit := s.strstart - IPos(MAX_DIST) - else - limit := ZNIL; - { Stop when cur_match becomes <= limit. To simplify the code, - we prevent matches with the string of window index 0. } - - prev := s.prev; - wmask := s.w_mask; - -{$ifdef UNALIGNED_OK} - { Compare two bytes at a time. Note: this is not always beneficial. - Try with and without -DUNALIGNED_OK to check. } - - strend := pBytef(@(s.window^[s.strstart + MAX_MATCH - 1])); - scan_start := pushf(scan)^; - scan_end := pushfArray(scan)^[best_len-1]; { fix } -{$else} - strend := pBytef(@(s.window^[s.strstart + MAX_MATCH])); - {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} - scan_end1 := pzByteArray(scan)^[best_len-1]; - {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} - scan_end := pzByteArray(scan)^[best_len]; -{$endif} - - { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. - It is easy to get rid of this optimization if necessary. } - {$IFDEF DEBUG} - Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever'); - {$ENDIF} - { Do not waste too much time if we already have a good match: } - if (s.prev_length >= s.good_match) then - begin - chain_length := chain_length shr 2; - end; - - { Do not look for matches beyond the end of the input. This is necessary - to make deflate deterministic. } - - if (uInt(nice_match) > s.lookahead) then - nice_match := s.lookahead; - {$IFDEF DEBUG} - Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead'); - {$ENDIF} - repeat - {$IFDEF DEBUG} - Assert(cur_match < s.strstart, 'no future'); - {$ENDIF} - match := @(s.window^[cur_match]); - - { Skip to next match if the match length cannot increase - or if the match length is less than 2: } - -{$undef DO_UNALIGNED_OK} -{$ifdef UNALIGNED_OK} - {$ifdef MAX_MATCH_IS_258} - {$define DO_UNALIGNED_OK} - {$endif} -{$endif} - -{$ifdef DO_UNALIGNED_OK} - { This code assumes sizeof(unsigned short) = 2. Do not use - UNALIGNED_OK if your compiler uses a different size. } - {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} - if (pushfArray(match)^[best_len-1] <> scan_end) or - (pushf(match)^ <> scan_start) then - goto nextstep; {continue;} - {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} - - { It is not necessary to compare scan[2] and match[2] since they are - always equal when the other bytes match, given that the hash keys - are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at - strstart+3, +5, ... up to strstart+257. We check for insufficient - lookahead only every 4th comparison; the 128th check will be made - at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is - necessary to put more guard bytes at the end of the window, or - to check more often for insufficient lookahead. } - {$IFDEF DEBUG} - Assert(pzByteArray(scan)^[2] = pzByteArray(match)^[2], 'scan[2]?'); - {$ENDIF} - Inc(scan); - Inc(match); - - repeat - Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; - Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; - Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; - Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; - until (ptr2int(scan) >= ptr2int(strend)); - { The funny "do while" generates better code on most compilers } - - { Here, scan <= window+strstart+257 } - {$IFDEF DEBUG} - {$ifopt R+} {$define RangeCheck} {$endif} {$R-} - Assert(ptr2int(scan) <= - ptr2int(@(s.window^[unsigned(s.window_size-1)])), - 'wild scan'); - {$ifdef RangeCheck} {$R+} {$undef RangeCheck} {$endif} - {$ENDIF} - if (scan^ = match^) then - Inc(scan); - - len := (MAX_MATCH - 1) - int(ptr2int(strend)) + int(ptr2int(scan)); - scan := strend; - Dec(scan, (MAX_MATCH-1)); - -{$else} { UNALIGNED_OK } - - {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} - if (pzByteArray(match)^[best_len] <> scan_end) or - (pzByteArray(match)^[best_len-1] <> scan_end1) or - (match^ <> scan^) then - goto nextstep; {continue;} - {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} - Inc(match); - if (match^ <> pzByteArray(scan)^[1]) then - goto nextstep; {continue;} - - { The check at best_len-1 can be removed because it will be made - again later. (This heuristic is not always a win.) - It is not necessary to compare scan[2] and match[2] since they - are always equal when the other bytes match, given that - the hash keys are equal and that HASH_BITS >= 8. } - - Inc(scan, 2); - Inc(match); - {$IFDEF DEBUG} - Assert( scan^ = match^, 'match[2]?'); - {$ENDIF} - { We check for insufficient lookahead only every 8th comparison; - the 256th check will be made at strstart+258. } - - repeat - Inc(scan); Inc(match); if (scan^ <> match^) then break; - Inc(scan); Inc(match); if (scan^ <> match^) then break; - Inc(scan); Inc(match); if (scan^ <> match^) then break; - Inc(scan); Inc(match); if (scan^ <> match^) then break; - Inc(scan); Inc(match); if (scan^ <> match^) then break; - Inc(scan); Inc(match); if (scan^ <> match^) then break; - Inc(scan); Inc(match); if (scan^ <> match^) then break; - Inc(scan); Inc(match); if (scan^ <> match^) then break; - until (ptr2int(scan) >= ptr2int(strend)); - - {$IFDEF DEBUG} - Assert(ptr2int(scan) <= - ptr2int(@(s.window^[unsigned(s.window_size-1)])), - 'wild scan'); - {$ENDIF} - - len := MAX_MATCH - int(ptr2int(strend) - ptr2int(scan)); - scan := strend; - Dec(scan, MAX_MATCH); - -{$endif} { UNALIGNED_OK } - - if (len > best_len) then - begin - s.match_start := cur_match; - best_len := len; - if (len >= nice_match) then - break; - {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} -{$ifdef UNALIGNED_OK} - scan_end := pzByteArray(scan)^[best_len-1]; -{$else} - scan_end1 := pzByteArray(scan)^[best_len-1]; - scan_end := pzByteArray(scan)^[best_len]; -{$endif} - {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} - end; - nextstep: - cur_match := prev^[cur_match and wmask]; - Dec(chain_length); - until (cur_match <= limit) or (chain_length = 0); - - if (uInt(best_len) <= s.lookahead) then - longest_match := uInt(best_len) - else - longest_match := s.lookahead; -end; -{$endif} { ASMV } - -{$else} { FASTEST } -{ --------------------------------------------------------------------------- - Optimized version for level = 1 only } - -{local} -function longest_match(var s : deflate_state; - cur_match : IPos { current match } - ) : uInt; -var - {register} scan : pBytef; { current string } - {register} match : pBytef; { matched string } - {register} len : int; { length of current match } - {register} strend : pBytef; -begin - scan := @s.window^[s.strstart]; - strend := @s.window^[s.strstart + MAX_MATCH]; - - - { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. - It is easy to get rid of this optimization if necessary. } - {$IFDEF DEBUG} - Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever'); - - Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead'); - - Assert(cur_match < s.strstart, 'no future'); - {$ENDIF} - match := s.window + cur_match; - - { Return failure if the match length is less than 2: } - - if (match[0] <> scan[0]) or (match[1] <> scan[1]) then - begin - longest_match := MIN_MATCH-1; - exit; - end; - - { The check at best_len-1 can be removed because it will be made - again later. (This heuristic is not always a win.) - It is not necessary to compare scan[2] and match[2] since they - are always equal when the other bytes match, given that - the hash keys are equal and that HASH_BITS >= 8. } - - scan += 2, match += 2; - Assert(scan^ = match^, 'match[2]?'); - - { We check for insufficient lookahead only every 8th comparison; - the 256th check will be made at strstart+258. } - - repeat - Inc(scan); Inc(match); if scan^<>match^ then break; - Inc(scan); Inc(match); if scan^<>match^ then break; - Inc(scan); Inc(match); if scan^<>match^ then break; - Inc(scan); Inc(match); if scan^<>match^ then break; - Inc(scan); Inc(match); if scan^<>match^ then break; - Inc(scan); Inc(match); if scan^<>match^ then break; - Inc(scan); Inc(match); if scan^<>match^ then break; - Inc(scan); Inc(match); if scan^<>match^ then break; - until (ptr2int(scan) >= ptr2int(strend)); - - Assert(scan <= s.window+unsigned(s.window_size-1), 'wild scan'); - - len := MAX_MATCH - int(strend - scan); - - if (len < MIN_MATCH) then - begin - return := MIN_MATCH - 1; - exit; - end; - - s.match_start := cur_match; - if len <= s.lookahead then - longest_match := len - else - longest_match := s.lookahead; -end; -{$endif} { FASTEST } - -{$ifdef DEBUG} -{ =========================================================================== - Check that the match at match_start is indeed a match. } - -{local} -procedure check_match(var s : deflate_state; - start, match : IPos; - length : int); -begin - exit; - { check that the match is indeed a match } - if (zmemcmp(pBytef(@s.window^[match]), - pBytef(@s.window^[start]), length) <> EQUAL) then - begin - WriteLn(' start ',start,', match ',match ,' length ', length); - repeat - Write(AnsiChar(s.window^[match]), AnsiChar(s.window^[start])); - Inc(match); - Inc(start); - Dec(length); - Until (length = 0); - z_error('invalid match'); - end; - if (z_verbose > 1) then - begin - Write('\\[',start-match,',',length,']'); - repeat - Write(AnsiChar(s.window^[start])); - Inc(start); - Dec(length); - Until (length = 0); - end; -end; -{$endif} - -{ =========================================================================== - Fill the window when the lookahead becomes insufficient. - Updates strstart and lookahead. - - IN assertion: lookahead < MIN_LOOKAHEAD - OUT assertions: strstart <= window_size-MIN_LOOKAHEAD - At least one byte has been read, or avail_in = 0; reads are - performed for at least two bytes (required for the zip translate_eol - option -- not supported here). } - -{local} -procedure fill_window(var s : deflate_state); -var - {register} n, m : unsigned; - {register} p : pPosf; - more : unsigned; { Amount of free space at the end of the window. } - wsize : uInt; -begin - wsize := s.w_size; - repeat - more := unsigned(s.window_size -ulg(s.lookahead) -ulg(s.strstart)); - - { Deal with !@#$% 64K limit: } - if (more = 0) and (s.strstart = 0) and (s.lookahead = 0) then - more := wsize - else - if (more = unsigned(-1)) then - begin - { Very unlikely, but possible on 16 bit machine if strstart = 0 - and lookahead = 1 (input done one byte at time) } - Dec(more); - - { If the window is almost full and there is insufficient lookahead, - move the upper half to the lower one to make room in the upper half.} - end - else - if (s.strstart >= wsize+ {MAX_DIST}(wsize-MIN_LOOKAHEAD)) then - begin - zmemcpy( pBytef(s.window), pBytef(@(s.window^[wsize])), - unsigned(wsize)); - Dec(s.match_start, wsize); - Dec(s.strstart, wsize); { we now have strstart >= MAX_DIST } - Dec(s.block_start, long(wsize)); - - { Slide the hash table (could be avoided with 32 bit values - at the expense of memory usage). We slide even when level = 0 - to keep the hash table consistent if we switch back to level > 0 - later. (Using level 0 permanently is not an optimal usage of - zlib, so we don't care about this pathological case.) } - - n := s.hash_size; - p := @s.head^[n]; - repeat - Dec(p); - m := p^; - if (m >= wsize) then - p^ := Pos(m-wsize) - else - p^ := Pos(ZNIL); - Dec(n); - Until (n=0); - - n := wsize; -{$ifndef FASTEST} - p := @s.prev^[n]; - repeat - Dec(p); - m := p^; - if (m >= wsize) then - p^ := Pos(m-wsize) - else - p^:= Pos(ZNIL); - { If n is not on any hash chain, prev^[n] is garbage but - its value will never be used. } - Dec(n); - Until (n=0); -{$endif} - Inc(more, wsize); - end; - if (s.strm^.avail_in = 0) then - exit; - - {* If there was no sliding: - * strstart <= WSIZE+MAX_DIST-1 && lookahead <= MIN_LOOKAHEAD - 1 && - * more == window_size - lookahead - strstart - * => more >= window_size - (MIN_LOOKAHEAD-1 + WSIZE + MAX_DIST-1) - * => more >= window_size - 2*WSIZE + 2 - * In the BIG_MEM or MMAP case (not yet supported), - * window_size == input_size + MIN_LOOKAHEAD && - * strstart + s->lookahead <= input_size => more >= MIN_LOOKAHEAD. - * Otherwise, window_size == 2*WSIZE so more >= 2. - * If there was sliding, more >= WSIZE. So in all cases, more >= 2. } - - {$IFDEF DEBUG} - Assert(more >= 2, 'more < 2'); - {$ENDIF} - - n := read_buf(s.strm, pBytef(@(s.window^[s.strstart + s.lookahead])), - more); - Inc(s.lookahead, n); - - { Initialize the hash value now that we have some input: } - if (s.lookahead >= MIN_MATCH) then - begin - s.ins_h := s.window^[s.strstart]; - {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);} - s.ins_h := ((s.ins_h shl s.hash_shift) xor s.window^[s.strstart+1]) - and s.hash_mask; -{$ifdef MIN_MATCH <> 3} - Call UPDATE_HASH() MIN_MATCH-3 more times -{$endif} - end; - { If the whole input has less than MIN_MATCH bytes, ins_h is garbage, - but this is not important since only literal bytes will be emitted. } - - until (s.lookahead >= MIN_LOOKAHEAD) or (s.strm^.avail_in = 0); -end; - -{ =========================================================================== - Flush the current block, with given end-of-file flag. - IN assertion: strstart is set to the end of the current match. } - -procedure FLUSH_BLOCK_ONLY(var s : deflate_state; eof : boolean); {macro} -begin - if (s.block_start >= Long(0)) then - _tr_flush_block(s, pcharf(@s.window^[unsigned(s.block_start)]), - ulg(long(s.strstart) - s.block_start), eof) - else - _tr_flush_block(s, pcharf(Z_NULL), - ulg(long(s.strstart) - s.block_start), eof); - - s.block_start := s.strstart; - flush_pending(s.strm^); - {$IFDEF DEBUG} - Tracev('[FLUSH]'); - {$ENDIF} -end; - -{ Same but force premature exit if necessary. -macro FLUSH_BLOCK(var s : deflate_state; eof : boolean) : boolean; -var - result : block_state; -begin - FLUSH_BLOCK_ONLY(s, eof); - if (s.strm^.avail_out = 0) then - begin - if eof then - result := finish_started - else - result := need_more; - exit; - end; -end; -} - -{ =========================================================================== - Copy without compression as much as possible from the input stream, return - the current block state. - This function does not insert new strings in the dictionary since - uncompressible data is probably not useful. This function is used - only for the level=0 compression option. - NOTE: this function should be optimized to avoid extra copying from - window to pending_buf. } - - -{local} -function deflate_stored(var s : deflate_state; flush : int) : block_state; -{ Stored blocks are limited to 0xffff bytes, pending_buf is limited - to pending_buf_size, and each stored block has a 5 byte header: } -var - max_block_size : ulg; - max_start : ulg; -begin - max_block_size := $ffff; - if (max_block_size > s.pending_buf_size - 5) then - max_block_size := s.pending_buf_size - 5; - - { Copy as much as possible from input to output: } - while TRUE do - begin - { Fill the window as much as possible: } - if (s.lookahead <= 1) then - begin - {$IFDEF DEBUG} - Assert( (s.strstart < s.w_size + {MAX_DIST}s.w_size-MIN_LOOKAHEAD) or - (s.block_start >= long(s.w_size)), 'slide too late'); - {$ENDIF} - fill_window(s); - if (s.lookahead = 0) and (flush = Z_NO_FLUSH) then - begin - deflate_stored := need_more; - exit; - end; - - if (s.lookahead = 0) then - break; { flush the current block } - end; - {$IFDEF DEBUG} - Assert(s.block_start >= long(0), 'block gone'); - {$ENDIF} - Inc(s.strstart, s.lookahead); - s.lookahead := 0; - - { Emit a stored block if pending_buf will be full: } - max_start := s.block_start + max_block_size; - if (s.strstart = 0) or (ulg(s.strstart) >= max_start) then - begin - { strstart = 0 is possible when wraparound on 16-bit machine } - s.lookahead := s.strstart - uInt(max_start); - s.strstart := uInt(max_start); - {FLUSH_BLOCK(s, FALSE);} - FLUSH_BLOCK_ONLY(s, FALSE); - if (s.strm^.avail_out = 0) then - begin - deflate_stored := need_more; - exit; - end; - end; - - { Flush if we may have to slide, otherwise block_start may become - negative and the data will be gone: } - - if (s.strstart - uInt(s.block_start) >= {MAX_DIST} - s.w_size-MIN_LOOKAHEAD) then - begin - {FLUSH_BLOCK(s, FALSE);} - FLUSH_BLOCK_ONLY(s, FALSE); - if (s.strm^.avail_out = 0) then - begin - deflate_stored := need_more; - exit; - end; - end; - end; - - {FLUSH_BLOCK(s, flush = Z_FINISH);} - FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); - if (s.strm^.avail_out = 0) then - begin - if flush = Z_FINISH then - deflate_stored := finish_started - else - deflate_stored := need_more; - exit; - end; - - if flush = Z_FINISH then - deflate_stored := finish_done - else - deflate_stored := block_done; -end; - -{ =========================================================================== - Compress as much as possible from the input stream, return the current - block state. - This function does not perform lazy evaluation of matches and inserts - new strings in the dictionary only for unmatched strings or for short - matches. It is used only for the fast compression options. } - -{local} -function deflate_fast(var s : deflate_state; flush : int) : block_state; -var - hash_head : IPos; { head of the hash chain } - bflush : boolean; { set if current block must be flushed } -begin - hash_head := ZNIL; - while TRUE do - begin - { Make sure that we always have enough lookahead, except - at the end of the input file. We need MAX_MATCH bytes - for the next match, plus MIN_MATCH bytes to insert the - string following the next match. } - - if (s.lookahead < MIN_LOOKAHEAD) then - begin - fill_window(s); - if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then - begin - deflate_fast := need_more; - exit; - end; - - if (s.lookahead = 0) then - break; { flush the current block } - end; - - - { Insert the string window[strstart .. strstart+2] in the - dictionary, and set hash_head to the head of the hash chain: } - - if (s.lookahead >= MIN_MATCH) then - begin - INSERT_STRING(s, s.strstart, hash_head); - end; - - { Find the longest match, discarding those <= prev_length. - At this point we have always match_length < MIN_MATCH } - if (hash_head <> ZNIL) and - (s.strstart - hash_head <= (s.w_size-MIN_LOOKAHEAD){MAX_DIST}) then - begin - { To simplify the code, we prevent matches with the string - of window index 0 (in particular we have to avoid a match - of the string with itself at the start of the input file). } - if (s.strategy <> Z_HUFFMAN_ONLY) then - begin - s.match_length := longest_match (s, hash_head); - end; - { longest_match() sets match_start } - end; - if (s.match_length >= MIN_MATCH) then - begin - {$IFDEF DEBUG} - check_match(s, s.strstart, s.match_start, s.match_length); - {$ENDIF} - - {_tr_tally_dist(s, s.strstart - s.match_start, - s.match_length - MIN_MATCH, bflush);} - bflush := _tr_tally(s, s.strstart - s.match_start, - s.match_length - MIN_MATCH); - - Dec(s.lookahead, s.match_length); - - { Insert new strings in the hash table only if the match length - is not too large. This saves time but degrades compression. } - -{$ifndef FASTEST} - if (s.match_length <= s.max_insert_length) - and (s.lookahead >= MIN_MATCH) then - begin - Dec(s.match_length); { string at strstart already in hash table } - repeat - Inc(s.strstart); - INSERT_STRING(s, s.strstart, hash_head); - { strstart never exceeds WSIZE-MAX_MATCH, so there are - always MIN_MATCH bytes ahead. } - Dec(s.match_length); - until (s.match_length = 0); - Inc(s.strstart); - end - else -{$endif} - - begin - Inc(s.strstart, s.match_length); - s.match_length := 0; - s.ins_h := s.window^[s.strstart]; - {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);} - s.ins_h := (( s.ins_h shl s.hash_shift) xor - s.window^[s.strstart+1]) and s.hash_mask; -if MIN_MATCH <> 3 then { the linker removes this } -begin - {Call UPDATE_HASH() MIN_MATCH-3 more times} -end; - - { If lookahead < MIN_MATCH, ins_h is garbage, but it does not - matter since it will be recomputed at next deflate call. } - - end; - end - else - begin - { No match, output a literal byte } - {$IFDEF DEBUG} - Tracevv(AnsiChar(s.window^[s.strstart])); - {$ENDIF} - {_tr_tally_lit (s, 0, s.window^[s.strstart], bflush);} - bflush := _tr_tally (s, 0, s.window^[s.strstart]); - - Dec(s.lookahead); - Inc(s.strstart); - end; - if bflush then - begin {FLUSH_BLOCK(s, FALSE);} - FLUSH_BLOCK_ONLY(s, FALSE); - if (s.strm^.avail_out = 0) then - begin - deflate_fast := need_more; - exit; - end; - end; - end; - {FLUSH_BLOCK(s, flush = Z_FINISH);} - FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); - if (s.strm^.avail_out = 0) then - begin - if flush = Z_FINISH then - deflate_fast := finish_started - else - deflate_fast := need_more; - exit; - end; - - if flush = Z_FINISH then - deflate_fast := finish_done - else - deflate_fast := block_done; -end; - -{ =========================================================================== - Same as above, but achieves better compression. We use a lazy - evaluation for matches: a match is finally adopted only if there is - no better match at the next window position. } - -{local} -function deflate_slow(var s : deflate_state; flush : int) : block_state; -var - hash_head : IPos; { head of hash chain } - bflush : boolean; { set if current block must be flushed } -var - max_insert : uInt; -begin - hash_head := ZNIL; - - { Process the input block. } - while TRUE do - begin - { Make sure that we always have enough lookahead, except - at the end of the input file. We need MAX_MATCH bytes - for the next match, plus MIN_MATCH bytes to insert the - string following the next match. } - - if (s.lookahead < MIN_LOOKAHEAD) then - begin - fill_window(s); - if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then - begin - deflate_slow := need_more; - exit; - end; - - if (s.lookahead = 0) then - break; { flush the current block } - end; - - { Insert the string window[strstart .. strstart+2] in the - dictionary, and set hash_head to the head of the hash chain: } - - if (s.lookahead >= MIN_MATCH) then - begin - INSERT_STRING(s, s.strstart, hash_head); - end; - - { Find the longest match, discarding those <= prev_length. } - - s.prev_length := s.match_length; - s.prev_match := s.match_start; - s.match_length := MIN_MATCH-1; - - if (hash_head <> ZNIL) and (s.prev_length < s.max_lazy_match) and - (s.strstart - hash_head <= {MAX_DIST}(s.w_size-MIN_LOOKAHEAD)) then - begin - { To simplify the code, we prevent matches with the string - of window index 0 (in particular we have to avoid a match - of the string with itself at the start of the input file). } - - if (s.strategy <> Z_HUFFMAN_ONLY) then - begin - s.match_length := longest_match (s, hash_head); - end; - { longest_match() sets match_start } - - if (s.match_length <= 5) and ((s.strategy = Z_FILTERED) or - ((s.match_length = MIN_MATCH) and - (s.strstart - s.match_start > TOO_FAR))) then - begin - { If prev_match is also MIN_MATCH, match_start is garbage - but we will ignore the current match anyway. } - - s.match_length := MIN_MATCH-1; - end; - end; - { If there was a match at the previous step and the current - match is not better, output the previous match: } - - if (s.prev_length >= MIN_MATCH) - and (s.match_length <= s.prev_length) then - begin - max_insert := s.strstart + s.lookahead - MIN_MATCH; - { Do not insert strings in hash table beyond this. } - {$ifdef DEBUG} - check_match(s, s.strstart-1, s.prev_match, s.prev_length); - {$endif} - - {_tr_tally_dist(s, s->strstart -1 - s->prev_match, - s->prev_length - MIN_MATCH, bflush);} - bflush := _tr_tally(s, s.strstart -1 - s.prev_match, - s.prev_length - MIN_MATCH); - - { Insert in hash table all strings up to the end of the match. - strstart-1 and strstart are already inserted. If there is not - enough lookahead, the last two strings are not inserted in - the hash table. } - - Dec(s.lookahead, s.prev_length-1); - Dec(s.prev_length, 2); - repeat - Inc(s.strstart); - if (s.strstart <= max_insert) then - begin - INSERT_STRING(s, s.strstart, hash_head); - end; - Dec(s.prev_length); - until (s.prev_length = 0); - s.match_available := FALSE; - s.match_length := MIN_MATCH-1; - Inc(s.strstart); - - if (bflush) then {FLUSH_BLOCK(s, FALSE);} - begin - FLUSH_BLOCK_ONLY(s, FALSE); - if (s.strm^.avail_out = 0) then - begin - deflate_slow := need_more; - exit; - end; - end; - end - else - if (s.match_available) then - begin - { If there was no match at the previous position, output a - single literal. If there was a match but the current match - is longer, truncate the previous match to a single literal. } - {$IFDEF DEBUG} - Tracevv(AnsiChar(s.window^[s.strstart-1])); - {$ENDIF} - bflush := _tr_tally (s, 0, s.window^[s.strstart-1]); - - if bflush then - begin - FLUSH_BLOCK_ONLY(s, FALSE); - end; - Inc(s.strstart); - Dec(s.lookahead); - if (s.strm^.avail_out = 0) then - begin - deflate_slow := need_more; - exit; - end; - end - else - begin - { There is no previous match to compare with, wait for - the next step to decide. } - - s.match_available := TRUE; - Inc(s.strstart); - Dec(s.lookahead); - end; - end; - - {$IFDEF DEBUG} - Assert (flush <> Z_NO_FLUSH, 'no flush?'); - {$ENDIF} - if (s.match_available) then - begin - {$IFDEF DEBUG} - Tracevv(AnsiChar(s.window^[s.strstart-1])); - bflush := - {$ENDIF} - _tr_tally (s, 0, s.window^[s.strstart-1]); - s.match_available := FALSE; - end; - {FLUSH_BLOCK(s, flush = Z_FINISH);} - FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); - if (s.strm^.avail_out = 0) then - begin - if flush = Z_FINISH then - deflate_slow := finish_started - else - deflate_slow := need_more; - exit; - end; - if flush = Z_FINISH then - deflate_slow := finish_done - else - deflate_slow := block_done; -end; - -end. +Unit imzdeflate; + +{ Orginal: deflate.h -- internal compression state + deflate.c -- compress data using the deflation algorithm + Copyright (C) 1995-1996 Jean-loup Gailly. + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + + +{ ALGORITHM + + The "deflation" process depends on being able to identify portions + of the input text which are identical to earlier input (within a + sliding window trailing behind the input currently being processed). + + The most straightforward technique turns out to be the fastest for + most input files: try all possible matches and select the longest. + The key feature of this algorithm is that insertions into the string + dictionary are very simple and thus fast, and deletions are avoided + completely. Insertions are performed at each input character, whereas + string matches are performed only when the previous match ends. So it + is preferable to spend more time in matches to allow very fast string + insertions and avoid deletions. The matching algorithm for small + strings is inspired from that of Rabin & Karp. A brute force approach + is used to find longer strings when a small match has been found. + A similar algorithm is used in comic (by Jan-Mark Wams) and freeze + (by Leonid Broukhis). + A previous version of this file used a more sophisticated algorithm + (by Fiala and Greene) which is guaranteed to run in linear amortized + time, but has a larger average cost, uses more memory and is patented. + However the F&G algorithm may be faster for some highly redundant + files if the parameter max_chain_length (described below) is too large. + + ACKNOWLEDGEMENTS + + The idea of lazy evaluation of matches is due to Jan-Mark Wams, and + I found it in 'freeze' written by Leonid Broukhis. + Thanks to many people for bug reports and testing. + + REFERENCES + + Deutsch, L.P.,"'Deflate' Compressed Data Format Specification". + Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc + + A description of the Rabin and Karp algorithm is given in the book + "Algorithms" by R. Sedgewick, Addison-Wesley, p252. + + Fiala,E.R., and Greene,D.H. + Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595} + +interface + +{$I imzconf.inc} + +uses + imzutil, impaszlib; + + +function deflateInit_(strm : z_streamp; + level : int; + const version : AnsiString; + stream_size : int) : int; + + +function deflateInit (var strm : z_stream; level : int) : int; + +{ Initializes the internal stream state for compression. The fields + zalloc, zfree and opaque must be initialized before by the caller. + If zalloc and zfree are set to Z_NULL, deflateInit updates them to + use default allocation functions. + + The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9: + 1 gives best speed, 9 gives best compression, 0 gives no compression at + all (the input data is simply copied a block at a time). + Z_DEFAULT_COMPRESSION requests a default compromise between speed and + compression (currently equivalent to level 6). + + deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not + enough memory, Z_STREAM_ERROR if level is not a valid compression level, + Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible + with the version assumed by the caller (ZLIB_VERSION). + msg is set to null if there is no error message. deflateInit does not + perform any compression: this will be done by deflate(). } + + +{EXPORT} +function deflate (var strm : z_stream; flush : int) : int; + +{ Performs one or both of the following actions: + + - Compress more input starting at next_in and update next_in and avail_in + accordingly. If not all input can be processed (because there is not + enough room in the output buffer), next_in and avail_in are updated and + processing will resume at this point for the next call of deflate(). + + - Provide more output starting at next_out and update next_out and avail_out + accordingly. This action is forced if the parameter flush is non zero. + Forcing flush frequently degrades the compression ratio, so this parameter + should be set only when necessary (in interactive applications). + Some output may be provided even if flush is not set. + + Before the call of deflate(), the application should ensure that at least + one of the actions is possible, by providing more input and/or consuming + more output, and updating avail_in or avail_out accordingly; avail_out + should never be zero before the call. The application can consume the + compressed output when it wants, for example when the output buffer is full + (avail_out == 0), or after each call of deflate(). If deflate returns Z_OK + and with zero avail_out, it must be called again after making room in the + output buffer because there might be more output pending. + + If the parameter flush is set to Z_PARTIAL_FLUSH, the current compression + block is terminated and flushed to the output buffer so that the + decompressor can get all input data available so far. For method 9, a future + variant on method 8, the current block will be flushed but not terminated. + Z_SYNC_FLUSH has the same effect as partial flush except that the compressed + output is byte aligned (the compressor can clear its internal bit buffer) + and the current block is always terminated; this can be useful if the + compressor has to be restarted from scratch after an interruption (in which + case the internal state of the compressor may be lost). + If flush is set to Z_FULL_FLUSH, the compression block is terminated, a + special marker is output and the compression dictionary is discarded; this + is useful to allow the decompressor to synchronize if one compressed block + has been damaged (see inflateSync below). Flushing degrades compression and + so should be used only when necessary. Using Z_FULL_FLUSH too often can + seriously degrade the compression. If deflate returns with avail_out == 0, + this function must be called again with the same value of the flush + parameter and more output space (updated avail_out), until the flush is + complete (deflate returns with non-zero avail_out). + + If the parameter flush is set to Z_FINISH, all pending input is processed, + all pending output is flushed and deflate returns with Z_STREAM_END if there + was enough output space; if deflate returns with Z_OK, this function must be + called again with Z_FINISH and more output space (updated avail_out) but no + more input data, until it returns with Z_STREAM_END or an error. After + deflate has returned Z_STREAM_END, the only possible operations on the + stream are deflateReset or deflateEnd. + + Z_FINISH can be used immediately after deflateInit if all the compression + is to be done in a single step. In this case, avail_out must be at least + 0.1% larger than avail_in plus 12 bytes. If deflate does not return + Z_STREAM_END, then it must be called again as described above. + + deflate() may update data_type if it can make a good guess about + the input data type (Z_ASCII or Z_BINARY). In doubt, the data is considered + binary. This field is only for information purposes and does not affect + the compression algorithm in any manner. + + deflate() returns Z_OK if some progress has been made (more input + processed or more output produced), Z_STREAM_END if all input has been + consumed and all output has been produced (only when flush is set to + Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example + if next_in or next_out was NULL), Z_BUF_ERROR if no progress is possible. } + + +function deflateEnd (var strm : z_stream) : int; + +{ All dynamically allocated data structures for this stream are freed. + This function discards any unprocessed input and does not flush any + pending output. + + deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the + stream state was inconsistent, Z_DATA_ERROR if the stream was freed + prematurely (some input or output was discarded). In the error case, + msg may be set but then points to a static string (which must not be + deallocated). } + + + + + { Advanced functions } + +{ The following functions are needed only in some special applications. } + + +{EXPORT} +function deflateInit2 (var strm : z_stream; + level : int; + method : int; + windowBits : int; + memLevel : int; + strategy : int) : int; + +{ This is another version of deflateInit with more compression options. The + fields next_in, zalloc, zfree and opaque must be initialized before by + the caller. + + The method parameter is the compression method. It must be Z_DEFLATED in + this version of the library. (Method 9 will allow a 64K history buffer and + partial block flushes.) + + The windowBits parameter is the base two logarithm of the window size + (the size of the history buffer). It should be in the range 8..15 for this + version of the library (the value 16 will be allowed for method 9). Larger + values of this parameter result in better compression at the expense of + memory usage. The default value is 15 if deflateInit is used instead. + + The memLevel parameter specifies how much memory should be allocated + for the internal compression state. memLevel=1 uses minimum memory but + is slow and reduces compression ratio; memLevel=9 uses maximum memory + for optimal speed. The default value is 8. See zconf.h for total memory + usage as a function of windowBits and memLevel. + + The strategy parameter is used to tune the compression algorithm. Use the + value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a + filter (or predictor), or Z_HUFFMAN_ONLY to force Huffman encoding only (no + string match). Filtered data consists mostly of small values with a + somewhat random distribution. In this case, the compression algorithm is + tuned to compress them better. The effect of Z_FILTERED is to force more + Huffman coding and less string matching; it is somewhat intermediate + between Z_DEFAULT and Z_HUFFMAN_ONLY. The strategy parameter only affects + the compression ratio but not the correctness of the compressed output even + if it is not set appropriately. + + If next_in is not null, the library will use this buffer to hold also + some history information; the buffer must either hold the entire input + data, or have at least 1<<(windowBits+1) bytes and be writable. If next_in + is null, the library will allocate its own history buffer (and leave next_in + null). next_out need not be provided here but must be provided by the + application for the next call of deflate(). + + If the history buffer is provided by the application, next_in must + must never be changed by the application since the compressor maintains + information inside this buffer from call to call; the application + must provide more input only by increasing avail_in. next_in is always + reset by the library in this case. + + deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was + not enough memory, Z_STREAM_ERROR if a parameter is invalid (such as + an invalid method). msg is set to null if there is no error message. + deflateInit2 does not perform any compression: this will be done by + deflate(). } + + +{EXPORT} +function deflateSetDictionary (var strm : z_stream; + dictionary : pBytef; {const bytes} + dictLength : uint) : int; + +{ Initializes the compression dictionary (history buffer) from the given + byte sequence without producing any compressed output. This function must + be called immediately after deflateInit or deflateInit2, before any call + of deflate. The compressor and decompressor must use exactly the same + dictionary (see inflateSetDictionary). + The dictionary should consist of strings (byte sequences) that are likely + to be encountered later in the data to be compressed, with the most commonly + used strings preferably put towards the end of the dictionary. Using a + dictionary is most useful when the data to be compressed is short and + can be predicted with good accuracy; the data can then be compressed better + than with the default empty dictionary. In this version of the library, + only the last 32K bytes of the dictionary are used. + Upon return of this function, strm->adler is set to the Adler32 value + of the dictionary; the decompressor may later use this value to determine + which dictionary has been used by the compressor. (The Adler32 value + applies to the whole dictionary even if only a subset of the dictionary is + actually used by the compressor.) + + deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a + parameter is invalid (such as NULL dictionary) or the stream state + is inconsistent (for example if deflate has already been called for this + stream). deflateSetDictionary does not perform any compression: this will + be done by deflate(). } + +{EXPORT} +function deflateCopy (dest : z_streamp; + source : z_streamp) : int; + +{ Sets the destination stream as a complete copy of the source stream. If + the source stream is using an application-supplied history buffer, a new + buffer is allocated for the destination stream. The compressed output + buffer is always application-supplied. It's the responsibility of the + application to provide the correct values of next_out and avail_out for the + next call of deflate. + + This function can be useful when several compression strategies will be + tried, for example when there are several ways of pre-processing the input + data with a filter. The streams that will be discarded should then be freed + by calling deflateEnd. Note that deflateCopy duplicates the internal + compression state which can be quite large, so this strategy is slow and + can consume lots of memory. + + deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not + enough memory, Z_STREAM_ERROR if the source stream state was inconsistent + (such as zalloc being NULL). msg is left unchanged in both source and + destination. } + +{EXPORT} +function deflateReset (var strm : z_stream) : int; + +{ This function is equivalent to deflateEnd followed by deflateInit, + but does not free and reallocate all the internal compression state. + The stream will keep the same compression level and any other attributes + that may have been set by deflateInit2. + + deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source + stream state was inconsistent (such as zalloc or state being NIL). } + + +{EXPORT} +function deflateParams (var strm : z_stream; level : int; strategy : int) : int; + +{ Dynamically update the compression level and compression strategy. + This can be used to switch between compression and straight copy of + the input data, or to switch to a different kind of input data requiring + a different strategy. If the compression level is changed, the input + available so far is compressed with the old level (and may be flushed); + the new level will take effect only at the next call of deflate(). + + Before the call of deflateParams, the stream state must be set as for + a call of deflate(), since the currently available input may have to + be compressed and flushed. In particular, strm->avail_out must be non-zero. + + deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source + stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR + if strm->avail_out was zero. } + + +const + deflate_copyright : string = ' deflate 1.1.2 Copyright 1995-1998 Jean-loup Gailly '; + +{ If you use the zlib library in a product, an acknowledgment is welcome + in the documentation of your product. If for some reason you cannot + include such an acknowledgment, I would appreciate that you keep this + copyright string in the executable of your product. } + +implementation + +uses + imtrees, imadler; + +{ =========================================================================== + Function prototypes. } + +type + block_state = ( + need_more, { block not completed, need more input or more output } + block_done, { block flush performed } + finish_started, { finish started, need only more output at next deflate } + finish_done); { finish done, accept no more input or output } + +{ Compression function. Returns the block state after the call. } +type + compress_func = function(var s : deflate_state; flush : int) : block_state; + +{local} +procedure fill_window(var s : deflate_state); forward; +{local} +function deflate_stored(var s : deflate_state; flush : int) : block_state; forward; +{local} +function deflate_fast(var s : deflate_state; flush : int) : block_state; forward; +{local} +function deflate_slow(var s : deflate_state; flush : int) : block_state; forward; +{local} +procedure lm_init(var s : deflate_state); forward; + +{local} +procedure putShortMSB(var s : deflate_state; b : uInt); forward; +{local} +procedure flush_pending (var strm : z_stream); forward; +{local} +function read_buf(strm : z_streamp; + buf : pBytef; + size : unsigned) : int; forward; +{$ifdef ASMV} +procedure match_init; { asm code initialization } +function longest_match(var deflate_state; cur_match : IPos) : uInt; forward; +{$else} +{local} +function longest_match(var s : deflate_state; cur_match : IPos) : uInt; + forward; +{$endif} + +{$ifdef DEBUG} +{local} +procedure check_match(var s : deflate_state; + start, match : IPos; + length : int); forward; +{$endif} + +{ ========================================================================== + local data } + +const + ZNIL = 0; +{ Tail of hash chains } + +const + TOO_FAR = 4096; +{ Matches of length 3 are discarded if their distance exceeds TOO_FAR } + +const + MIN_LOOKAHEAD = (MAX_MATCH+MIN_MATCH+1); +{ Minimum amount of lookahead, except at the end of the input file. + See deflate.c for comments about the MIN_MATCH+1. } + +{macro MAX_DIST(var s : deflate_state) : uInt; +begin + MAX_DIST := (s.w_size - MIN_LOOKAHEAD); +end; + In order to simplify the code, particularly on 16 bit machines, match + distances are limited to MAX_DIST instead of WSIZE. } + + +{ Values for max_lazy_match, good_match and max_chain_length, depending on + the desired pack level (0..9). The values given below have been tuned to + exclude worst case performance for pathological files. Better values may be + found for specific files. } + +type + config = record + good_length : ush; { reduce lazy search above this match length } + max_lazy : ush; { do not perform lazy search above this match length } + nice_length : ush; { quit search above this match length } + max_chain : ush; + func : compress_func; + end; + +{local} +const + configuration_table : array[0..10-1] of config = ( +{ good lazy nice chain } +{0} (good_length:0; max_lazy:0; nice_length:0; max_chain:0; func:deflate_stored), { store only } +{1} (good_length:4; max_lazy:4; nice_length:8; max_chain:4; func:deflate_fast), { maximum speed, no lazy matches } +{2} (good_length:4; max_lazy:5; nice_length:16; max_chain:8; func:deflate_fast), +{3} (good_length:4; max_lazy:6; nice_length:32; max_chain:32; func:deflate_fast), + +{4} (good_length:4; max_lazy:4; nice_length:16; max_chain:16; func:deflate_slow), { lazy matches } +{5} (good_length:8; max_lazy:16; nice_length:32; max_chain:32; func:deflate_slow), +{6} (good_length:8; max_lazy:16; nice_length:128; max_chain:128; func:deflate_slow), +{7} (good_length:8; max_lazy:32; nice_length:128; max_chain:256; func:deflate_slow), +{8} (good_length:32; max_lazy:128; nice_length:258; max_chain:1024; func:deflate_slow), +{9} (good_length:32; max_lazy:258; nice_length:258; max_chain:4096; func:deflate_slow)); { maximum compression } + +{ Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4 + For deflate_fast() (levels <= 3) good is ignored and lazy has a different + meaning. } + +const + EQUAL = 0; +{ result of memcmp for equal strings } + +{ ========================================================================== + Update a hash value with the given input byte + IN assertion: all calls to to UPDATE_HASH are made with consecutive + input characters, so that a running hash key can be computed from the + previous key instead of complete recalculation each time. + +macro UPDATE_HASH(s,h,c) + h := (( (h) shl s^.hash_shift) xor (c)) and s^.hash_mask; +} + +{ =========================================================================== + Insert string str in the dictionary and set match_head to the previous head + of the hash chain (the most recent string with same hash key). Return + the previous length of the hash chain. + If this file is compiled with -DFASTEST, the compression level is forced + to 1, and no hash chains are maintained. + IN assertion: all calls to to INSERT_STRING are made with consecutive + input characters and the first MIN_MATCH bytes of str are valid + (except for the last MIN_MATCH-1 bytes of the input file). } + +procedure INSERT_STRING(var s : deflate_state; + str : uInt; + var match_head : IPos); +begin +{$ifdef FASTEST} + {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])} + s.ins_h := ((s.ins_h shl s.hash_shift) xor + (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask; + match_head := s.head[s.ins_h] + s.head[s.ins_h] := Pos(str); +{$else} + {UPDATE_HASH(s, s.ins_h, s.window[(str) + (MIN_MATCH-1)])} + s.ins_h := ((s.ins_h shl s.hash_shift) xor + (s.window^[(str) + (MIN_MATCH-1)])) and s.hash_mask; + + match_head := s.head^[s.ins_h]; + s.prev^[(str) and s.w_mask] := match_head; + s.head^[s.ins_h] := Pos(str); +{$endif} +end; + +{ ========================================================================= + Initialize the hash table (avoiding 64K overflow for 16 bit systems). + prev[] will be initialized on the fly. + +macro CLEAR_HASH(s) + s^.head[s^.hash_size-1] := ZNIL; + zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0])); +} + +{ ======================================================================== } + +function deflateInit2_(var strm : z_stream; + level : int; + method : int; + windowBits : int; + memLevel : int; + strategy : int; + const version : AnsiString; + stream_size : int) : int; +var + s : deflate_state_ptr; + noheader : int; + + overlay : pushfArray; + { We overlay pending_buf and d_buf+l_buf. This works since the average + output size for (length,distance) codes is <= 24 bits. } +begin + noheader := 0; + if (version = '') or (version[1] <> ZLIB_VERSION[1]) or + (stream_size <> sizeof(z_stream)) then + begin + deflateInit2_ := Z_VERSION_ERROR; + exit; + end; + { + if (strm = Z_NULL) then + begin + deflateInit2_ := Z_STREAM_ERROR; + exit; + end; + } + { SetLength(strm.msg, 255); } + strm.msg := ''; + if not Assigned(strm.zalloc) then + begin + {$IFDEF FPC} strm.zalloc := @zcalloc; {$ELSE} + strm.zalloc := zcalloc; + {$ENDIF} + strm.opaque := voidpf(0); + end; + if not Assigned(strm.zfree) then + {$IFDEF FPC} strm.zfree := @zcfree; {$ELSE} + strm.zfree := zcfree; + {$ENDIF} + + if (level = Z_DEFAULT_COMPRESSION) then + level := 6; +{$ifdef FASTEST} + level := 1; +{$endif} + + if (windowBits < 0) then { undocumented feature: suppress zlib header } + begin + noheader := 1; + windowBits := -windowBits; + end; + if (memLevel < 1) or (memLevel > MAX_MEM_LEVEL) or (method <> Z_DEFLATED) + or (windowBits < 8) or (windowBits > 15) or (level < 0) + or (level > 9) or (strategy < 0) or (strategy > Z_HUFFMAN_ONLY) then + begin + deflateInit2_ := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr (ZALLOC(strm, 1, sizeof(deflate_state))); + if (s = Z_NULL) then + begin + deflateInit2_ := Z_MEM_ERROR; + exit; + end; + strm.state := pInternal_state(s); + s^.strm := @strm; + + s^.noheader := noheader; + s^.w_bits := windowBits; + s^.w_size := 1 shl s^.w_bits; + s^.w_mask := s^.w_size - 1; + + s^.hash_bits := memLevel + 7; + s^.hash_size := 1 shl s^.hash_bits; + s^.hash_mask := s^.hash_size - 1; + s^.hash_shift := ((s^.hash_bits+MIN_MATCH-1) div MIN_MATCH); + + s^.window := pzByteArray (ZALLOC(strm, s^.w_size, 2*sizeof(Byte))); + s^.prev := pzPosfArray (ZALLOC(strm, s^.w_size, sizeof(Pos))); + s^.head := pzPosfArray (ZALLOC(strm, s^.hash_size, sizeof(Pos))); + + s^.lit_bufsize := 1 shl (memLevel + 6); { 16K elements by default } + + overlay := pushfArray (ZALLOC(strm, s^.lit_bufsize, sizeof(ush)+2)); + s^.pending_buf := pzByteArray (overlay); + s^.pending_buf_size := ulg(s^.lit_bufsize) * (sizeof(ush)+Long(2)); + + if (s^.window = Z_NULL) or (s^.prev = Z_NULL) or (s^.head = Z_NULL) + or (s^.pending_buf = Z_NULL) then + begin + {ERR_MSG(Z_MEM_ERROR);} + strm.msg := z_errmsg[z_errbase-Z_MEM_ERROR]; + deflateEnd (strm); + deflateInit2_ := Z_MEM_ERROR; + exit; + end; + s^.d_buf := pushfArray( @overlay^[s^.lit_bufsize div sizeof(ush)] ); + s^.l_buf := puchfArray( @s^.pending_buf^[(1+sizeof(ush))*s^.lit_bufsize] ); + + s^.level := level; + s^.strategy := strategy; + s^.method := Byte(method); + + deflateInit2_ := deflateReset(strm); +end; + +{ ========================================================================= } + +function deflateInit2(var strm : z_stream; + level : int; + method : int; + windowBits : int; + memLevel : int; + strategy : int) : int; +{ a macro } +begin + deflateInit2 := deflateInit2_(strm, level, method, windowBits, + memLevel, strategy, ZLIB_VERSION, sizeof(z_stream)); +end; + +{ ========================================================================= } + +function deflateInit_(strm : z_streamp; + level : int; + const version : AnsiString; + stream_size : int) : int; +begin + if (strm = Z_NULL) then + deflateInit_ := Z_STREAM_ERROR + else + deflateInit_ := deflateInit2_(strm^, level, Z_DEFLATED, MAX_WBITS, + DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, version, stream_size); + { To do: ignore strm^.next_in if we use it as window } +end; + +{ ========================================================================= } + +function deflateInit(var strm : z_stream; level : int) : int; +{ deflateInit is a macro to allow checking the zlib version + and the compiler's view of z_stream: } +begin + deflateInit := deflateInit2_(strm, level, Z_DEFLATED, MAX_WBITS, + DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, ZLIB_VERSION, sizeof(z_stream)); +end; + +{ ======================================================================== } +function deflateSetDictionary (var strm : z_stream; + dictionary : pBytef; + dictLength : uInt) : int; +var + s : deflate_state_ptr; + length : uInt; + n : uInt; + hash_head : IPos; +var + MAX_DIST : uInt; {macro} +begin + length := dictLength; + hash_head := 0; + + if {(@strm = Z_NULL) or} + (strm.state = Z_NULL) or (dictionary = Z_NULL) + or (deflate_state_ptr(strm.state)^.status <> INIT_STATE) then + begin + deflateSetDictionary := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr(strm.state); + strm.adler := adler32(strm.adler, dictionary, dictLength); + + if (length < MIN_MATCH) then + begin + deflateSetDictionary := Z_OK; + exit; + end; + MAX_DIST := (s^.w_size - MIN_LOOKAHEAD); + if (length > MAX_DIST) then + begin + length := MAX_DIST; +{$ifndef USE_DICT_HEAD} + Inc(dictionary, dictLength - length); { use the tail of the dictionary } +{$endif} + end; + + zmemcpy( pBytef(s^.window), dictionary, length); + s^.strstart := length; + s^.block_start := long(length); + + { Insert all strings in the hash table (except for the last two bytes). + s^.lookahead stays null, so s^.ins_h will be recomputed at the next + call of fill_window. } + + s^.ins_h := s^.window^[0]; + {UPDATE_HASH(s, s^.ins_h, s^.window[1]);} + s^.ins_h := ((s^.ins_h shl s^.hash_shift) xor (s^.window^[1])) + and s^.hash_mask; + + for n := 0 to length - MIN_MATCH do + begin + INSERT_STRING(s^, n, hash_head); + end; + {if (hash_head <> 0) then + hash_head := 0; - to make compiler happy } + deflateSetDictionary := Z_OK; +end; + +{ ======================================================================== } +function deflateReset (var strm : z_stream) : int; +var + s : deflate_state_ptr; +begin + if {(@strm = Z_NULL) or} + (strm.state = Z_NULL) + or (not Assigned(strm.zalloc)) or (not Assigned(strm.zfree)) then + begin + deflateReset := Z_STREAM_ERROR; + exit; + end; + + strm.total_out := 0; + strm.total_in := 0; + strm.msg := ''; { use zfree if we ever allocate msg dynamically } + strm.data_type := Z_UNKNOWN; + + s := deflate_state_ptr(strm.state); + s^.pending := 0; + s^.pending_out := pBytef(s^.pending_buf); + + if (s^.noheader < 0) then + begin + s^.noheader := 0; { was set to -1 by deflate(..., Z_FINISH); } + end; + if s^.noheader <> 0 then + s^.status := BUSY_STATE + else + s^.status := INIT_STATE; + strm.adler := 1; + s^.last_flush := Z_NO_FLUSH; + + _tr_init(s^); + lm_init(s^); + + deflateReset := Z_OK; +end; + +{ ======================================================================== } +function deflateParams(var strm : z_stream; + level : int; + strategy : int) : int; +var + s : deflate_state_ptr; + func : compress_func; + err : int; +begin + err := Z_OK; + if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then + begin + deflateParams := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr(strm.state); + + if (level = Z_DEFAULT_COMPRESSION) then + begin + level := 6; + end; + if (level < 0) or (level > 9) or (strategy < 0) + or (strategy > Z_HUFFMAN_ONLY) then + begin + deflateParams := Z_STREAM_ERROR; + exit; + end; + func := configuration_table[s^.level].func; + + if (@func <> @configuration_table[level].func) + and (strm.total_in <> 0) then + begin + { Flush the last buffer: } + err := deflate(strm, Z_PARTIAL_FLUSH); + end; + if (s^.level <> level) then + begin + s^.level := level; + s^.max_lazy_match := configuration_table[level].max_lazy; + s^.good_match := configuration_table[level].good_length; + s^.nice_match := configuration_table[level].nice_length; + s^.max_chain_length := configuration_table[level].max_chain; + end; + s^.strategy := strategy; + deflateParams := err; +end; + +{ ========================================================================= + Put a short in the pending buffer. The 16-bit value is put in MSB order. + IN assertion: the stream state is correct and there is enough room in + pending_buf. } + +{local} +procedure putShortMSB (var s : deflate_state; b : uInt); +begin + s.pending_buf^[s.pending] := Byte(b shr 8); + Inc(s.pending); + s.pending_buf^[s.pending] := Byte(b and $ff); + Inc(s.pending); +end; + +{ ========================================================================= + Flush as much pending output as possible. All deflate() output goes + through this function so some applications may wish to modify it + to avoid allocating a large strm^.next_out buffer and copying into it. + (See also read_buf()). } + +{local} +procedure flush_pending(var strm : z_stream); +var + len : unsigned; + s : deflate_state_ptr; +begin + s := deflate_state_ptr(strm.state); + len := s^.pending; + + if (len > strm.avail_out) then + len := strm.avail_out; + if (len = 0) then + exit; + + zmemcpy(strm.next_out, s^.pending_out, len); + Inc(strm.next_out, len); + Inc(s^.pending_out, len); + Inc(strm.total_out, len); + Dec(strm.avail_out, len); + Dec(s^.pending, len); + if (s^.pending = 0) then + begin + s^.pending_out := pBytef(s^.pending_buf); + end; +end; + +{ ========================================================================= } +function deflate (var strm : z_stream; flush : int) : int; +var + old_flush : int; { value of flush param for previous deflate call } + s : deflate_state_ptr; +var + header : uInt; + level_flags : uInt; +var + bstate : block_state; +begin + if {(@strm = Z_NULL) or} (strm.state = Z_NULL) + or (flush > Z_FINISH) or (flush < 0) then + begin + deflate := Z_STREAM_ERROR; + exit; + end; + s := deflate_state_ptr(strm.state); + + if (strm.next_out = Z_NULL) or + ((strm.next_in = Z_NULL) and (strm.avail_in <> 0)) or + ((s^.status = FINISH_STATE) and (flush <> Z_FINISH)) then + begin + {ERR_RETURN(strm^, Z_STREAM_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_STREAM_ERROR]; + deflate := Z_STREAM_ERROR; + exit; + end; + if (strm.avail_out = 0) then + begin + {ERR_RETURN(strm^, Z_BUF_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; + deflate := Z_BUF_ERROR; + exit; + end; + + s^.strm := @strm; { just in case } + old_flush := s^.last_flush; + s^.last_flush := flush; + + { Write the zlib header } + if (s^.status = INIT_STATE) then + begin + + header := (Z_DEFLATED + ((s^.w_bits-8) shl 4)) shl 8; + level_flags := (s^.level-1) shr 1; + + if (level_flags > 3) then + level_flags := 3; + header := header or (level_flags shl 6); + if (s^.strstart <> 0) then + header := header or PRESET_DICT; + Inc(header, 31 - (header mod 31)); + + s^.status := BUSY_STATE; + putShortMSB(s^, header); + + { Save the adler32 of the preset dictionary: } + if (s^.strstart <> 0) then + begin + putShortMSB(s^, uInt(strm.adler shr 16)); + putShortMSB(s^, uInt(strm.adler and $ffff)); + end; + strm.adler := long(1); + end; + + { Flush as much pending output as possible } + if (s^.pending <> 0) then + begin + flush_pending(strm); + if (strm.avail_out = 0) then + begin + { Since avail_out is 0, deflate will be called again with + more output space, but possibly with both pending and + avail_in equal to zero. There won't be anything to do, + but this is not an error situation so make sure we + return OK instead of BUF_ERROR at next call of deflate: } + + s^.last_flush := -1; + deflate := Z_OK; + exit; + end; + + { Make sure there is something to do and avoid duplicate consecutive + flushes. For repeated and useless calls with Z_FINISH, we keep + returning Z_STREAM_END instead of Z_BUFF_ERROR. } + + end + else + if (strm.avail_in = 0) and (flush <= old_flush) + and (flush <> Z_FINISH) then + begin + {ERR_RETURN(strm^, Z_BUF_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; + deflate := Z_BUF_ERROR; + exit; + end; + + { User must not provide more input after the first FINISH: } + if (s^.status = FINISH_STATE) and (strm.avail_in <> 0) then + begin + {ERR_RETURN(strm^, Z_BUF_ERROR);} + strm.msg := z_errmsg[z_errbase - Z_BUF_ERROR]; + deflate := Z_BUF_ERROR; + exit; + end; + + { Start a new block or continue the current one. } + if (strm.avail_in <> 0) or (s^.lookahead <> 0) + or ((flush <> Z_NO_FLUSH) and (s^.status <> FINISH_STATE)) then + begin + bstate := configuration_table[s^.level].func(s^, flush); + + if (bstate = finish_started) or (bstate = finish_done) then + s^.status := FINISH_STATE; + + if (bstate = need_more) or (bstate = finish_started) then + begin + if (strm.avail_out = 0) then + s^.last_flush := -1; { avoid BUF_ERROR next call, see above } + + deflate := Z_OK; + exit; + { If flush != Z_NO_FLUSH && avail_out == 0, the next call + of deflate should use the same flush parameter to make sure + that the flush is complete. So we don't have to output an + empty block here, this will be done at next call. This also + ensures that for a very small output buffer, we emit at most + one empty block. } + end; + if (bstate = block_done) then + begin + if (flush = Z_PARTIAL_FLUSH) then + _tr_align(s^) + else + begin { FULL_FLUSH or SYNC_FLUSH } + _tr_stored_block(s^, pcharf(NIL), Long(0), FALSE); + { For a full flush, this empty block will be recognized + as a special marker by inflate_sync(). } + + if (flush = Z_FULL_FLUSH) then + begin + {macro CLEAR_HASH(s);} { forget history } + s^.head^[s^.hash_size-1] := ZNIL; + zmemzero(pBytef(s^.head), unsigned(s^.hash_size-1)*sizeof(s^.head^[0])); + end; + end; + + flush_pending(strm); + if (strm.avail_out = 0) then + begin + s^.last_flush := -1; { avoid BUF_ERROR at next call, see above } + deflate := Z_OK; + exit; + end; + + end; + end; + {$IFDEF DEBUG} + Assert(strm.avail_out > 0, 'bug2'); + {$ENDIF} + if (flush <> Z_FINISH) then + begin + deflate := Z_OK; + exit; + end; + + if (s^.noheader <> 0) then + begin + deflate := Z_STREAM_END; + exit; + end; + + { Write the zlib trailer (adler32) } + putShortMSB(s^, uInt(strm.adler shr 16)); + putShortMSB(s^, uInt(strm.adler and $ffff)); + flush_pending(strm); + { If avail_out is zero, the application will call deflate again + to flush the rest. } + + s^.noheader := -1; { write the trailer only once! } + if s^.pending <> 0 then + deflate := Z_OK + else + deflate := Z_STREAM_END; +end; + +{ ========================================================================= } +function deflateEnd (var strm : z_stream) : int; +var + status : int; + s : deflate_state_ptr; +begin + if {(@strm = Z_NULL) or} (strm.state = Z_NULL) then + begin + deflateEnd := Z_STREAM_ERROR; + exit; + end; + + s := deflate_state_ptr(strm.state); + status := s^.status; + if (status <> INIT_STATE) and (status <> BUSY_STATE) and + (status <> FINISH_STATE) then + begin + deflateEnd := Z_STREAM_ERROR; + exit; + end; + + { Deallocate in reverse order of allocations: } + TRY_FREE(strm, s^.pending_buf); + TRY_FREE(strm, s^.head); + TRY_FREE(strm, s^.prev); + TRY_FREE(strm, s^.window); + + ZFREE(strm, s); + strm.state := Z_NULL; + + if status = BUSY_STATE then + deflateEnd := Z_DATA_ERROR + else + deflateEnd := Z_OK; +end; + +{ ========================================================================= + Copy the source state to the destination state. + To simplify the source, this is not supported for 16-bit MSDOS (which + doesn't have enough memory anyway to duplicate compression states). } + + +{ ========================================================================= } +function deflateCopy (dest, source : z_streamp) : int; +{$ifndef MAXSEG_64K} +var + ds : deflate_state_ptr; + ss : deflate_state_ptr; + overlay : pushfArray; +{$endif} +begin +{$ifdef MAXSEG_64K} + deflateCopy := Z_STREAM_ERROR; + exit; +{$else} + + if (source = Z_NULL) or (dest = Z_NULL) or (source^.state = Z_NULL) then + begin + deflateCopy := Z_STREAM_ERROR; + exit; + end; + ss := deflate_state_ptr(source^.state); + dest^ := source^; + + ds := deflate_state_ptr( ZALLOC(dest^, 1, sizeof(deflate_state)) ); + if (ds = Z_NULL) then + begin + deflateCopy := Z_MEM_ERROR; + exit; + end; + dest^.state := pInternal_state(ds); + ds^ := ss^; + ds^.strm := dest; + + ds^.window := pzByteArray ( ZALLOC(dest^, ds^.w_size, 2*sizeof(Byte)) ); + ds^.prev := pzPosfArray ( ZALLOC(dest^, ds^.w_size, sizeof(Pos)) ); + ds^.head := pzPosfArray ( ZALLOC(dest^, ds^.hash_size, sizeof(Pos)) ); + overlay := pushfArray ( ZALLOC(dest^, ds^.lit_bufsize, sizeof(ush)+2) ); + ds^.pending_buf := pzByteArray ( overlay ); + + if (ds^.window = Z_NULL) or (ds^.prev = Z_NULL) or (ds^.head = Z_NULL) + or (ds^.pending_buf = Z_NULL) then + begin + deflateEnd (dest^); + deflateCopy := Z_MEM_ERROR; + exit; + end; + { following zmemcpy do not work for 16-bit MSDOS } + zmemcpy(pBytef(ds^.window), pBytef(ss^.window), ds^.w_size * 2 * sizeof(Byte)); + zmemcpy(pBytef(ds^.prev), pBytef(ss^.prev), ds^.w_size * sizeof(Pos)); + zmemcpy(pBytef(ds^.head), pBytef(ss^.head), ds^.hash_size * sizeof(Pos)); + zmemcpy(pBytef(ds^.pending_buf), pBytef(ss^.pending_buf), uInt(ds^.pending_buf_size)); + + ds^.pending_out := @ds^.pending_buf^[ptr2int(ss^.pending_out) - ptr2int(ss^.pending_buf)]; + ds^.d_buf := pushfArray (@overlay^[ds^.lit_bufsize div sizeof(ush)] ); + ds^.l_buf := puchfArray (@ds^.pending_buf^[(1+sizeof(ush))*ds^.lit_bufsize]); + + ds^.l_desc.dyn_tree := tree_ptr(@ds^.dyn_ltree); + ds^.d_desc.dyn_tree := tree_ptr(@ds^.dyn_dtree); + ds^.bl_desc.dyn_tree := tree_ptr(@ds^.bl_tree); + + deflateCopy := Z_OK; +{$endif} +end; + + +{ =========================================================================== + Read a new buffer from the current input stream, update the adler32 + and total number of bytes read. All deflate() input goes through + this function so some applications may wish to modify it to avoid + allocating a large strm^.next_in buffer and copying from it. + (See also flush_pending()). } + +{local} +function read_buf(strm : z_streamp; buf : pBytef; size : unsigned) : int; +var + len : unsigned; +begin + len := strm^.avail_in; + + if (len > size) then + len := size; + if (len = 0) then + begin + read_buf := 0; + exit; + end; + + Dec(strm^.avail_in, len); + + if deflate_state_ptr(strm^.state)^.noheader = 0 then + begin + strm^.adler := adler32(strm^.adler, strm^.next_in, len); + end; + zmemcpy(buf, strm^.next_in, len); + Inc(strm^.next_in, len); + Inc(strm^.total_in, len); + + read_buf := int(len); +end; + +{ =========================================================================== + Initialize the "longest match" routines for a new zlib stream } + +{local} +procedure lm_init (var s : deflate_state); +begin + s.window_size := ulg( uLong(2)*s.w_size); + + {macro CLEAR_HASH(s);} + s.head^[s.hash_size-1] := ZNIL; + zmemzero(pBytef(s.head), unsigned(s.hash_size-1)*sizeof(s.head^[0])); + + { Set the default configuration parameters: } + + s.max_lazy_match := configuration_table[s.level].max_lazy; + s.good_match := configuration_table[s.level].good_length; + s.nice_match := configuration_table[s.level].nice_length; + s.max_chain_length := configuration_table[s.level].max_chain; + + s.strstart := 0; + s.block_start := long(0); + s.lookahead := 0; + s.prev_length := MIN_MATCH-1; + s.match_length := MIN_MATCH-1; + s.match_available := FALSE; + s.ins_h := 0; +{$ifdef ASMV} + match_init; { initialize the asm code } +{$endif} +end; + +{ =========================================================================== + Set match_start to the longest match starting at the given string and + return its length. Matches shorter or equal to prev_length are discarded, + in which case the result is equal to prev_length and match_start is + garbage. + IN assertions: cur_match is the head of the hash chain for the current + string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1 + OUT assertion: the match length is not greater than s^.lookahead. } + + +{$ifndef ASMV} +{ For 80x86 and 680x0, an optimized version will be provided in match.asm or + match.S. The code will be functionally equivalent. } + +{$ifndef FASTEST} + +{local} +function longest_match(var s : deflate_state; + cur_match : IPos { current match } + ) : uInt; +label + nextstep; +var + chain_length : unsigned; { max hash chain length } + {register} scan : pBytef; { current string } + {register} match : pBytef; { matched string } + {register} len : int; { length of current match } + best_len : int; { best match length so far } + nice_match : int; { stop if match long enough } + limit : IPos; + + prev : pzPosfArray; + wmask : uInt; +{$ifdef UNALIGNED_OK} + {register} strend : pBytef; + {register} scan_start : ush; + {register} scan_end : ush; +{$else} + {register} strend : pBytef; + {register} scan_end1 : Byte; + {register} scan_end : Byte; +{$endif} +var + MAX_DIST : uInt; +begin + chain_length := s.max_chain_length; { max hash chain length } + scan := @(s.window^[s.strstart]); + best_len := s.prev_length; { best match length so far } + nice_match := s.nice_match; { stop if match long enough } + + + MAX_DIST := s.w_size - MIN_LOOKAHEAD; +{In order to simplify the code, particularly on 16 bit machines, match +distances are limited to MAX_DIST instead of WSIZE. } + + if s.strstart > IPos(MAX_DIST) then + limit := s.strstart - IPos(MAX_DIST) + else + limit := ZNIL; + { Stop when cur_match becomes <= limit. To simplify the code, + we prevent matches with the string of window index 0. } + + prev := s.prev; + wmask := s.w_mask; + +{$ifdef UNALIGNED_OK} + { Compare two bytes at a time. Note: this is not always beneficial. + Try with and without -DUNALIGNED_OK to check. } + + strend := pBytef(@(s.window^[s.strstart + MAX_MATCH - 1])); + scan_start := pushf(scan)^; + scan_end := pushfArray(scan)^[best_len-1]; { fix } +{$else} + strend := pBytef(@(s.window^[s.strstart + MAX_MATCH])); + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + scan_end1 := pzByteArray(scan)^[best_len-1]; + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + scan_end := pzByteArray(scan)^[best_len]; +{$endif} + + { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. + It is easy to get rid of this optimization if necessary. } + {$IFDEF DEBUG} + Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever'); + {$ENDIF} + { Do not waste too much time if we already have a good match: } + if (s.prev_length >= s.good_match) then + begin + chain_length := chain_length shr 2; + end; + + { Do not look for matches beyond the end of the input. This is necessary + to make deflate deterministic. } + + if (uInt(nice_match) > s.lookahead) then + nice_match := s.lookahead; + {$IFDEF DEBUG} + Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead'); + {$ENDIF} + repeat + {$IFDEF DEBUG} + Assert(cur_match < s.strstart, 'no future'); + {$ENDIF} + match := @(s.window^[cur_match]); + + { Skip to next match if the match length cannot increase + or if the match length is less than 2: } + +{$undef DO_UNALIGNED_OK} +{$ifdef UNALIGNED_OK} + {$ifdef MAX_MATCH_IS_258} + {$define DO_UNALIGNED_OK} + {$endif} +{$endif} + +{$ifdef DO_UNALIGNED_OK} + { This code assumes sizeof(unsigned short) = 2. Do not use + UNALIGNED_OK if your compiler uses a different size. } + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + if (pushfArray(match)^[best_len-1] <> scan_end) or + (pushf(match)^ <> scan_start) then + goto nextstep; {continue;} + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + + { It is not necessary to compare scan[2] and match[2] since they are + always equal when the other bytes match, given that the hash keys + are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at + strstart+3, +5, ... up to strstart+257. We check for insufficient + lookahead only every 4th comparison; the 128th check will be made + at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is + necessary to put more guard bytes at the end of the window, or + to check more often for insufficient lookahead. } + {$IFDEF DEBUG} + Assert(pzByteArray(scan)^[2] = pzByteArray(match)^[2], 'scan[2]?'); + {$ENDIF} + Inc(scan); + Inc(match); + + repeat + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + Inc(scan,2); Inc(match,2); if (pushf(scan)^<>pushf(match)^) then break; + until (ptr2int(scan) >= ptr2int(strend)); + { The funny "do while" generates better code on most compilers } + + { Here, scan <= window+strstart+257 } + {$IFDEF DEBUG} + {$ifopt R+} {$define RangeCheck} {$endif} {$R-} + Assert(ptr2int(scan) <= + ptr2int(@(s.window^[unsigned(s.window_size-1)])), + 'wild scan'); + {$ifdef RangeCheck} {$R+} {$undef RangeCheck} {$endif} + {$ENDIF} + if (scan^ = match^) then + Inc(scan); + + len := (MAX_MATCH - 1) - int(ptr2int(strend)) + int(ptr2int(scan)); + scan := strend; + Dec(scan, (MAX_MATCH-1)); + +{$else} { UNALIGNED_OK } + + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} + if (pzByteArray(match)^[best_len] <> scan_end) or + (pzByteArray(match)^[best_len-1] <> scan_end1) or + (match^ <> scan^) then + goto nextstep; {continue;} + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + Inc(match); + if (match^ <> pzByteArray(scan)^[1]) then + goto nextstep; {continue;} + + { The check at best_len-1 can be removed because it will be made + again later. (This heuristic is not always a win.) + It is not necessary to compare scan[2] and match[2] since they + are always equal when the other bytes match, given that + the hash keys are equal and that HASH_BITS >= 8. } + + Inc(scan, 2); + Inc(match); + {$IFDEF DEBUG} + Assert( scan^ = match^, 'match[2]?'); + {$ENDIF} + { We check for insufficient lookahead only every 8th comparison; + the 256th check will be made at strstart+258. } + + repeat + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + Inc(scan); Inc(match); if (scan^ <> match^) then break; + until (ptr2int(scan) >= ptr2int(strend)); + + {$IFDEF DEBUG} + Assert(ptr2int(scan) <= + ptr2int(@(s.window^[unsigned(s.window_size-1)])), + 'wild scan'); + {$ENDIF} + + len := MAX_MATCH - int(ptr2int(strend) - ptr2int(scan)); + scan := strend; + Dec(scan, MAX_MATCH); + +{$endif} { UNALIGNED_OK } + + if (len > best_len) then + begin + s.match_start := cur_match; + best_len := len; + if (len >= nice_match) then + break; + {$IFOPT R+} {$R-} {$DEFINE NoRangeCheck} {$ENDIF} +{$ifdef UNALIGNED_OK} + scan_end := pzByteArray(scan)^[best_len-1]; +{$else} + scan_end1 := pzByteArray(scan)^[best_len-1]; + scan_end := pzByteArray(scan)^[best_len]; +{$endif} + {$IFDEF NoRangeCheck} {$R+} {$UNDEF NoRangeCheck} {$ENDIF} + end; + nextstep: + cur_match := prev^[cur_match and wmask]; + Dec(chain_length); + until (cur_match <= limit) or (chain_length = 0); + + if (uInt(best_len) <= s.lookahead) then + longest_match := uInt(best_len) + else + longest_match := s.lookahead; +end; +{$endif} { ASMV } + +{$else} { FASTEST } +{ --------------------------------------------------------------------------- + Optimized version for level = 1 only } + +{local} +function longest_match(var s : deflate_state; + cur_match : IPos { current match } + ) : uInt; +var + {register} scan : pBytef; { current string } + {register} match : pBytef; { matched string } + {register} len : int; { length of current match } + {register} strend : pBytef; +begin + scan := @s.window^[s.strstart]; + strend := @s.window^[s.strstart + MAX_MATCH]; + + + { The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16. + It is easy to get rid of this optimization if necessary. } + {$IFDEF DEBUG} + Assert((s.hash_bits >= 8) and (MAX_MATCH = 258), 'Code too clever'); + + Assert(ulg(s.strstart) <= s.window_size-MIN_LOOKAHEAD, 'need lookahead'); + + Assert(cur_match < s.strstart, 'no future'); + {$ENDIF} + match := s.window + cur_match; + + { Return failure if the match length is less than 2: } + + if (match[0] <> scan[0]) or (match[1] <> scan[1]) then + begin + longest_match := MIN_MATCH-1; + exit; + end; + + { The check at best_len-1 can be removed because it will be made + again later. (This heuristic is not always a win.) + It is not necessary to compare scan[2] and match[2] since they + are always equal when the other bytes match, given that + the hash keys are equal and that HASH_BITS >= 8. } + + scan += 2, match += 2; + Assert(scan^ = match^, 'match[2]?'); + + { We check for insufficient lookahead only every 8th comparison; + the 256th check will be made at strstart+258. } + + repeat + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + Inc(scan); Inc(match); if scan^<>match^ then break; + until (ptr2int(scan) >= ptr2int(strend)); + + Assert(scan <= s.window+unsigned(s.window_size-1), 'wild scan'); + + len := MAX_MATCH - int(strend - scan); + + if (len < MIN_MATCH) then + begin + return := MIN_MATCH - 1; + exit; + end; + + s.match_start := cur_match; + if len <= s.lookahead then + longest_match := len + else + longest_match := s.lookahead; +end; +{$endif} { FASTEST } + +{$ifdef DEBUG} +{ =========================================================================== + Check that the match at match_start is indeed a match. } + +{local} +procedure check_match(var s : deflate_state; + start, match : IPos; + length : int); +begin + exit; + { check that the match is indeed a match } + if (zmemcmp(pBytef(@s.window^[match]), + pBytef(@s.window^[start]), length) <> EQUAL) then + begin + WriteLn(' start ',start,', match ',match ,' length ', length); + repeat + Write(AnsiChar(s.window^[match]), AnsiChar(s.window^[start])); + Inc(match); + Inc(start); + Dec(length); + Until (length = 0); + z_error('invalid match'); + end; + if (z_verbose > 1) then + begin + Write('\\[',start-match,',',length,']'); + repeat + Write(AnsiChar(s.window^[start])); + Inc(start); + Dec(length); + Until (length = 0); + end; +end; +{$endif} + +{ =========================================================================== + Fill the window when the lookahead becomes insufficient. + Updates strstart and lookahead. + + IN assertion: lookahead < MIN_LOOKAHEAD + OUT assertions: strstart <= window_size-MIN_LOOKAHEAD + At least one byte has been read, or avail_in = 0; reads are + performed for at least two bytes (required for the zip translate_eol + option -- not supported here). } + +{local} +procedure fill_window(var s : deflate_state); +var + {register} n, m : unsigned; + {register} p : pPosf; + more : unsigned; { Amount of free space at the end of the window. } + wsize : uInt; +begin + wsize := s.w_size; + repeat + more := unsigned(s.window_size -ulg(s.lookahead) -ulg(s.strstart)); + + { Deal with !@#$% 64K limit: } + if (more = 0) and (s.strstart = 0) and (s.lookahead = 0) then + more := wsize + else + if (more = unsigned(-1)) then + begin + { Very unlikely, but possible on 16 bit machine if strstart = 0 + and lookahead = 1 (input done one byte at time) } + Dec(more); + + { If the window is almost full and there is insufficient lookahead, + move the upper half to the lower one to make room in the upper half.} + end + else + if (s.strstart >= wsize+ {MAX_DIST}(wsize-MIN_LOOKAHEAD)) then + begin + zmemcpy( pBytef(s.window), pBytef(@(s.window^[wsize])), + unsigned(wsize)); + Dec(s.match_start, wsize); + Dec(s.strstart, wsize); { we now have strstart >= MAX_DIST } + Dec(s.block_start, long(wsize)); + + { Slide the hash table (could be avoided with 32 bit values + at the expense of memory usage). We slide even when level = 0 + to keep the hash table consistent if we switch back to level > 0 + later. (Using level 0 permanently is not an optimal usage of + zlib, so we don't care about this pathological case.) } + + n := s.hash_size; + p := @s.head^[n]; + repeat + Dec(p); + m := p^; + if (m >= wsize) then + p^ := Pos(m-wsize) + else + p^ := Pos(ZNIL); + Dec(n); + Until (n=0); + + n := wsize; +{$ifndef FASTEST} + p := @s.prev^[n]; + repeat + Dec(p); + m := p^; + if (m >= wsize) then + p^ := Pos(m-wsize) + else + p^:= Pos(ZNIL); + { If n is not on any hash chain, prev^[n] is garbage but + its value will never be used. } + Dec(n); + Until (n=0); +{$endif} + Inc(more, wsize); + end; + if (s.strm^.avail_in = 0) then + exit; + + {* If there was no sliding: + * strstart <= WSIZE+MAX_DIST-1 && lookahead <= MIN_LOOKAHEAD - 1 && + * more == window_size - lookahead - strstart + * => more >= window_size - (MIN_LOOKAHEAD-1 + WSIZE + MAX_DIST-1) + * => more >= window_size - 2*WSIZE + 2 + * In the BIG_MEM or MMAP case (not yet supported), + * window_size == input_size + MIN_LOOKAHEAD && + * strstart + s->lookahead <= input_size => more >= MIN_LOOKAHEAD. + * Otherwise, window_size == 2*WSIZE so more >= 2. + * If there was sliding, more >= WSIZE. So in all cases, more >= 2. } + + {$IFDEF DEBUG} + Assert(more >= 2, 'more < 2'); + {$ENDIF} + + n := read_buf(s.strm, pBytef(@(s.window^[s.strstart + s.lookahead])), + more); + Inc(s.lookahead, n); + + { Initialize the hash value now that we have some input: } + if (s.lookahead >= MIN_MATCH) then + begin + s.ins_h := s.window^[s.strstart]; + {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);} + s.ins_h := ((s.ins_h shl s.hash_shift) xor s.window^[s.strstart+1]) + and s.hash_mask; +{$ifdef MIN_MATCH <> 3} + Call UPDATE_HASH() MIN_MATCH-3 more times +{$endif} + end; + { If the whole input has less than MIN_MATCH bytes, ins_h is garbage, + but this is not important since only literal bytes will be emitted. } + + until (s.lookahead >= MIN_LOOKAHEAD) or (s.strm^.avail_in = 0); +end; + +{ =========================================================================== + Flush the current block, with given end-of-file flag. + IN assertion: strstart is set to the end of the current match. } + +procedure FLUSH_BLOCK_ONLY(var s : deflate_state; eof : boolean); {macro} +begin + if (s.block_start >= Long(0)) then + _tr_flush_block(s, pcharf(@s.window^[unsigned(s.block_start)]), + ulg(long(s.strstart) - s.block_start), eof) + else + _tr_flush_block(s, pcharf(Z_NULL), + ulg(long(s.strstart) - s.block_start), eof); + + s.block_start := s.strstart; + flush_pending(s.strm^); + {$IFDEF DEBUG} + Tracev('[FLUSH]'); + {$ENDIF} +end; + +{ Same but force premature exit if necessary. +macro FLUSH_BLOCK(var s : deflate_state; eof : boolean) : boolean; +var + result : block_state; +begin + FLUSH_BLOCK_ONLY(s, eof); + if (s.strm^.avail_out = 0) then + begin + if eof then + result := finish_started + else + result := need_more; + exit; + end; +end; +} + +{ =========================================================================== + Copy without compression as much as possible from the input stream, return + the current block state. + This function does not insert new strings in the dictionary since + uncompressible data is probably not useful. This function is used + only for the level=0 compression option. + NOTE: this function should be optimized to avoid extra copying from + window to pending_buf. } + + +{local} +function deflate_stored(var s : deflate_state; flush : int) : block_state; +{ Stored blocks are limited to 0xffff bytes, pending_buf is limited + to pending_buf_size, and each stored block has a 5 byte header: } +var + max_block_size : ulg; + max_start : ulg; +begin + max_block_size := $ffff; + if (max_block_size > s.pending_buf_size - 5) then + max_block_size := s.pending_buf_size - 5; + + { Copy as much as possible from input to output: } + while TRUE do + begin + { Fill the window as much as possible: } + if (s.lookahead <= 1) then + begin + {$IFDEF DEBUG} + Assert( (s.strstart < s.w_size + {MAX_DIST}s.w_size-MIN_LOOKAHEAD) or + (s.block_start >= long(s.w_size)), 'slide too late'); + {$ENDIF} + fill_window(s); + if (s.lookahead = 0) and (flush = Z_NO_FLUSH) then + begin + deflate_stored := need_more; + exit; + end; + + if (s.lookahead = 0) then + break; { flush the current block } + end; + {$IFDEF DEBUG} + Assert(s.block_start >= long(0), 'block gone'); + {$ENDIF} + Inc(s.strstart, s.lookahead); + s.lookahead := 0; + + { Emit a stored block if pending_buf will be full: } + max_start := s.block_start + max_block_size; + if (s.strstart = 0) or (ulg(s.strstart) >= max_start) then + begin + { strstart = 0 is possible when wraparound on 16-bit machine } + s.lookahead := s.strstart - uInt(max_start); + s.strstart := uInt(max_start); + {FLUSH_BLOCK(s, FALSE);} + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_stored := need_more; + exit; + end; + end; + + { Flush if we may have to slide, otherwise block_start may become + negative and the data will be gone: } + + if (s.strstart - uInt(s.block_start) >= {MAX_DIST} + s.w_size-MIN_LOOKAHEAD) then + begin + {FLUSH_BLOCK(s, FALSE);} + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_stored := need_more; + exit; + end; + end; + end; + + {FLUSH_BLOCK(s, flush = Z_FINISH);} + FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); + if (s.strm^.avail_out = 0) then + begin + if flush = Z_FINISH then + deflate_stored := finish_started + else + deflate_stored := need_more; + exit; + end; + + if flush = Z_FINISH then + deflate_stored := finish_done + else + deflate_stored := block_done; +end; + +{ =========================================================================== + Compress as much as possible from the input stream, return the current + block state. + This function does not perform lazy evaluation of matches and inserts + new strings in the dictionary only for unmatched strings or for short + matches. It is used only for the fast compression options. } + +{local} +function deflate_fast(var s : deflate_state; flush : int) : block_state; +var + hash_head : IPos; { head of the hash chain } + bflush : boolean; { set if current block must be flushed } +begin + hash_head := ZNIL; + while TRUE do + begin + { Make sure that we always have enough lookahead, except + at the end of the input file. We need MAX_MATCH bytes + for the next match, plus MIN_MATCH bytes to insert the + string following the next match. } + + if (s.lookahead < MIN_LOOKAHEAD) then + begin + fill_window(s); + if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then + begin + deflate_fast := need_more; + exit; + end; + + if (s.lookahead = 0) then + break; { flush the current block } + end; + + + { Insert the string window[strstart .. strstart+2] in the + dictionary, and set hash_head to the head of the hash chain: } + + if (s.lookahead >= MIN_MATCH) then + begin + INSERT_STRING(s, s.strstart, hash_head); + end; + + { Find the longest match, discarding those <= prev_length. + At this point we have always match_length < MIN_MATCH } + if (hash_head <> ZNIL) and + (s.strstart - hash_head <= (s.w_size-MIN_LOOKAHEAD){MAX_DIST}) then + begin + { To simplify the code, we prevent matches with the string + of window index 0 (in particular we have to avoid a match + of the string with itself at the start of the input file). } + if (s.strategy <> Z_HUFFMAN_ONLY) then + begin + s.match_length := longest_match (s, hash_head); + end; + { longest_match() sets match_start } + end; + if (s.match_length >= MIN_MATCH) then + begin + {$IFDEF DEBUG} + check_match(s, s.strstart, s.match_start, s.match_length); + {$ENDIF} + + {_tr_tally_dist(s, s.strstart - s.match_start, + s.match_length - MIN_MATCH, bflush);} + bflush := _tr_tally(s, s.strstart - s.match_start, + s.match_length - MIN_MATCH); + + Dec(s.lookahead, s.match_length); + + { Insert new strings in the hash table only if the match length + is not too large. This saves time but degrades compression. } + +{$ifndef FASTEST} + if (s.match_length <= s.max_insert_length) + and (s.lookahead >= MIN_MATCH) then + begin + Dec(s.match_length); { string at strstart already in hash table } + repeat + Inc(s.strstart); + INSERT_STRING(s, s.strstart, hash_head); + { strstart never exceeds WSIZE-MAX_MATCH, so there are + always MIN_MATCH bytes ahead. } + Dec(s.match_length); + until (s.match_length = 0); + Inc(s.strstart); + end + else +{$endif} + + begin + Inc(s.strstart, s.match_length); + s.match_length := 0; + s.ins_h := s.window^[s.strstart]; + {UPDATE_HASH(s, s.ins_h, s.window[s.strstart+1]);} + s.ins_h := (( s.ins_h shl s.hash_shift) xor + s.window^[s.strstart+1]) and s.hash_mask; +if MIN_MATCH <> 3 then { the linker removes this } +begin + {Call UPDATE_HASH() MIN_MATCH-3 more times} +end; + + { If lookahead < MIN_MATCH, ins_h is garbage, but it does not + matter since it will be recomputed at next deflate call. } + + end; + end + else + begin + { No match, output a literal byte } + {$IFDEF DEBUG} + Tracevv(AnsiChar(s.window^[s.strstart])); + {$ENDIF} + {_tr_tally_lit (s, 0, s.window^[s.strstart], bflush);} + bflush := _tr_tally (s, 0, s.window^[s.strstart]); + + Dec(s.lookahead); + Inc(s.strstart); + end; + if bflush then + begin {FLUSH_BLOCK(s, FALSE);} + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_fast := need_more; + exit; + end; + end; + end; + {FLUSH_BLOCK(s, flush = Z_FINISH);} + FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); + if (s.strm^.avail_out = 0) then + begin + if flush = Z_FINISH then + deflate_fast := finish_started + else + deflate_fast := need_more; + exit; + end; + + if flush = Z_FINISH then + deflate_fast := finish_done + else + deflate_fast := block_done; +end; + +{ =========================================================================== + Same as above, but achieves better compression. We use a lazy + evaluation for matches: a match is finally adopted only if there is + no better match at the next window position. } + +{local} +function deflate_slow(var s : deflate_state; flush : int) : block_state; +var + hash_head : IPos; { head of hash chain } + bflush : boolean; { set if current block must be flushed } +var + max_insert : uInt; +begin + hash_head := ZNIL; + + { Process the input block. } + while TRUE do + begin + { Make sure that we always have enough lookahead, except + at the end of the input file. We need MAX_MATCH bytes + for the next match, plus MIN_MATCH bytes to insert the + string following the next match. } + + if (s.lookahead < MIN_LOOKAHEAD) then + begin + fill_window(s); + if (s.lookahead < MIN_LOOKAHEAD) and (flush = Z_NO_FLUSH) then + begin + deflate_slow := need_more; + exit; + end; + + if (s.lookahead = 0) then + break; { flush the current block } + end; + + { Insert the string window[strstart .. strstart+2] in the + dictionary, and set hash_head to the head of the hash chain: } + + if (s.lookahead >= MIN_MATCH) then + begin + INSERT_STRING(s, s.strstart, hash_head); + end; + + { Find the longest match, discarding those <= prev_length. } + + s.prev_length := s.match_length; + s.prev_match := s.match_start; + s.match_length := MIN_MATCH-1; + + if (hash_head <> ZNIL) and (s.prev_length < s.max_lazy_match) and + (s.strstart - hash_head <= {MAX_DIST}(s.w_size-MIN_LOOKAHEAD)) then + begin + { To simplify the code, we prevent matches with the string + of window index 0 (in particular we have to avoid a match + of the string with itself at the start of the input file). } + + if (s.strategy <> Z_HUFFMAN_ONLY) then + begin + s.match_length := longest_match (s, hash_head); + end; + { longest_match() sets match_start } + + if (s.match_length <= 5) and ((s.strategy = Z_FILTERED) or + ((s.match_length = MIN_MATCH) and + (s.strstart - s.match_start > TOO_FAR))) then + begin + { If prev_match is also MIN_MATCH, match_start is garbage + but we will ignore the current match anyway. } + + s.match_length := MIN_MATCH-1; + end; + end; + { If there was a match at the previous step and the current + match is not better, output the previous match: } + + if (s.prev_length >= MIN_MATCH) + and (s.match_length <= s.prev_length) then + begin + max_insert := s.strstart + s.lookahead - MIN_MATCH; + { Do not insert strings in hash table beyond this. } + {$ifdef DEBUG} + check_match(s, s.strstart-1, s.prev_match, s.prev_length); + {$endif} + + {_tr_tally_dist(s, s->strstart -1 - s->prev_match, + s->prev_length - MIN_MATCH, bflush);} + bflush := _tr_tally(s, s.strstart -1 - s.prev_match, + s.prev_length - MIN_MATCH); + + { Insert in hash table all strings up to the end of the match. + strstart-1 and strstart are already inserted. If there is not + enough lookahead, the last two strings are not inserted in + the hash table. } + + Dec(s.lookahead, s.prev_length-1); + Dec(s.prev_length, 2); + repeat + Inc(s.strstart); + if (s.strstart <= max_insert) then + begin + INSERT_STRING(s, s.strstart, hash_head); + end; + Dec(s.prev_length); + until (s.prev_length = 0); + s.match_available := FALSE; + s.match_length := MIN_MATCH-1; + Inc(s.strstart); + + if (bflush) then {FLUSH_BLOCK(s, FALSE);} + begin + FLUSH_BLOCK_ONLY(s, FALSE); + if (s.strm^.avail_out = 0) then + begin + deflate_slow := need_more; + exit; + end; + end; + end + else + if (s.match_available) then + begin + { If there was no match at the previous position, output a + single literal. If there was a match but the current match + is longer, truncate the previous match to a single literal. } + {$IFDEF DEBUG} + Tracevv(AnsiChar(s.window^[s.strstart-1])); + {$ENDIF} + bflush := _tr_tally (s, 0, s.window^[s.strstart-1]); + + if bflush then + begin + FLUSH_BLOCK_ONLY(s, FALSE); + end; + Inc(s.strstart); + Dec(s.lookahead); + if (s.strm^.avail_out = 0) then + begin + deflate_slow := need_more; + exit; + end; + end + else + begin + { There is no previous match to compare with, wait for + the next step to decide. } + + s.match_available := TRUE; + Inc(s.strstart); + Dec(s.lookahead); + end; + end; + + {$IFDEF DEBUG} + Assert (flush <> Z_NO_FLUSH, 'no flush?'); + {$ENDIF} + if (s.match_available) then + begin + {$IFDEF DEBUG} + Tracevv(AnsiChar(s.window^[s.strstart-1])); + bflush := + {$ENDIF} + _tr_tally (s, 0, s.window^[s.strstart-1]); + s.match_available := FALSE; + end; + {FLUSH_BLOCK(s, flush = Z_FINISH);} + FLUSH_BLOCK_ONLY(s, flush = Z_FINISH); + if (s.strm^.avail_out = 0) then + begin + if flush = Z_FINISH then + deflate_slow := finish_started + else + deflate_slow := need_more; + exit; + end; + if flush = Z_FINISH then + deflate_slow := finish_done + else + deflate_slow := block_done; +end; + +end. diff --git a/Imaging/ZLib/imzinflate.pas b/Imaging/ZLib/imzinflate.pas index 6984950..3803044 100644 --- a/Imaging/ZLib/imzinflate.pas +++ b/Imaging/ZLib/imzinflate.pas @@ -1,750 +1,750 @@ -Unit imzinflate; - -{ inflate.c -- zlib interface to inflate modules - Copyright (C) 1995-1998 Mark Adler - - Pascal tranlastion - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - -interface - -{$I imzconf.inc} - -uses - imzutil, impaszlib, iminfblock, iminfutil; - -function inflateInit(var z : z_stream) : int; - -{ Initializes the internal stream state for decompression. The fields - zalloc, zfree and opaque must be initialized before by the caller. If - zalloc and zfree are set to Z_NULL, inflateInit updates them to use default - allocation functions. - - inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not - enough memory, Z_VERSION_ERROR if the zlib library version is incompatible - with the version assumed by the caller. msg is set to null if there is no - error message. inflateInit does not perform any decompression: this will be - done by inflate(). } - - - -function inflateInit_(z : z_streamp; - const version : AnsiString; - stream_size : int) : int; - - -function inflateInit2_(var z: z_stream; - w : int; - const version : AnsiString; - stream_size : int) : int; - -function inflateInit2(var z: z_stream; - windowBits : int) : int; - -{ - This is another version of inflateInit with an extra parameter. The - fields next_in, avail_in, zalloc, zfree and opaque must be initialized - before by the caller. - - The windowBits parameter is the base two logarithm of the maximum window - size (the size of the history buffer). It should be in the range 8..15 for - this version of the library. The default value is 15 if inflateInit is used - instead. If a compressed stream with a larger window size is given as - input, inflate() will return with the error code Z_DATA_ERROR instead of - trying to allocate a larger window. - - inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough - memory, Z_STREAM_ERROR if a parameter is invalid (such as a negative - memLevel). msg is set to null if there is no error message. inflateInit2 - does not perform any decompression apart from reading the zlib header if - present: this will be done by inflate(). (So next_in and avail_in may be - modified, but next_out and avail_out are unchanged.) -} - - - -function inflateEnd(var z : z_stream) : int; - -{ - All dynamically allocated data structures for this stream are freed. - This function discards any unprocessed input and does not flush any - pending output. - - inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state - was inconsistent. In the error case, msg may be set but then points to a - static string (which must not be deallocated). -} - -function inflateReset(var z : z_stream) : int; - -{ - This function is equivalent to inflateEnd followed by inflateInit, - but does not free and reallocate all the internal decompression state. - The stream will keep attributes that may have been set by inflateInit2. - - inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source - stream state was inconsistent (such as zalloc or state being NULL). -} - - -function inflate(var z : z_stream; - f : int) : int; -{ - inflate decompresses as much data as possible, and stops when the input - buffer becomes empty or the output buffer becomes full. It may introduce - some output latency (reading input without producing any output) - except when forced to flush. - - The detailed semantics are as follows. inflate performs one or both of the - following actions: - - - Decompress more input starting at next_in and update next_in and avail_in - accordingly. If not all input can be processed (because there is not - enough room in the output buffer), next_in is updated and processing - will resume at this point for the next call of inflate(). - - - Provide more output starting at next_out and update next_out and avail_out - accordingly. inflate() provides as much output as possible, until there - is no more input data or no more space in the output buffer (see below - about the flush parameter). - - Before the call of inflate(), the application should ensure that at least - one of the actions is possible, by providing more input and/or consuming - more output, and updating the next_* and avail_* values accordingly. - The application can consume the uncompressed output when it wants, for - example when the output buffer is full (avail_out == 0), or after each - call of inflate(). If inflate returns Z_OK and with zero avail_out, it - must be called again after making room in the output buffer because there - might be more output pending. - - If the parameter flush is set to Z_SYNC_FLUSH, inflate flushes as much - output as possible to the output buffer. The flushing behavior of inflate is - not specified for values of the flush parameter other than Z_SYNC_FLUSH - and Z_FINISH, but the current implementation actually flushes as much output - as possible anyway. - - inflate() should normally be called until it returns Z_STREAM_END or an - error. However if all decompression is to be performed in a single step - (a single call of inflate), the parameter flush should be set to - Z_FINISH. In this case all pending input is processed and all pending - output is flushed; avail_out must be large enough to hold all the - uncompressed data. (The size of the uncompressed data may have been saved - by the compressor for this purpose.) The next operation on this stream must - be inflateEnd to deallocate the decompression state. The use of Z_FINISH - is never required, but can be used to inform inflate that a faster routine - may be used for the single inflate() call. - - If a preset dictionary is needed at this point (see inflateSetDictionary - below), inflate sets strm-adler to the adler32 checksum of the - dictionary chosen by the compressor and returns Z_NEED_DICT; otherwise - it sets strm->adler to the adler32 checksum of all output produced - so far (that is, total_out bytes) and returns Z_OK, Z_STREAM_END or - an error code as described below. At the end of the stream, inflate() - checks that its computed adler32 checksum is equal to that saved by the - compressor and returns Z_STREAM_END only if the checksum is correct. - - inflate() returns Z_OK if some progress has been made (more input processed - or more output produced), Z_STREAM_END if the end of the compressed data has - been reached and all uncompressed output has been produced, Z_NEED_DICT if a - preset dictionary is needed at this point, Z_DATA_ERROR if the input data was - corrupted (input stream not conforming to the zlib format or incorrect - adler32 checksum), Z_STREAM_ERROR if the stream structure was inconsistent - (for example if next_in or next_out was NULL), Z_MEM_ERROR if there was not - enough memory, Z_BUF_ERROR if no progress is possible or if there was not - enough room in the output buffer when Z_FINISH is used. In the Z_DATA_ERROR - case, the application may then call inflateSync to look for a good - compression block. -} - - -function inflateSetDictionary(var z : z_stream; - dictionary : pBytef; {const array of byte} - dictLength : uInt) : int; - -{ - Initializes the decompression dictionary from the given uncompressed byte - sequence. This function must be called immediately after a call of inflate - if this call returned Z_NEED_DICT. The dictionary chosen by the compressor - can be determined from the Adler32 value returned by this call of - inflate. The compressor and decompressor must use exactly the same - dictionary (see deflateSetDictionary). - - inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a - parameter is invalid (such as NULL dictionary) or the stream state is - inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the - expected one (incorrect Adler32 value). inflateSetDictionary does not - perform any decompression: this will be done by subsequent calls of - inflate(). -} - -function inflateSync(var z : z_stream) : int; - -{ - Skips invalid compressed data until a full flush point (see above the - description of deflate with Z_FULL_FLUSH) can be found, or until all - available input is skipped. No output is provided. - - inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR - if no more input was provided, Z_DATA_ERROR if no flush point has been found, - or Z_STREAM_ERROR if the stream structure was inconsistent. In the success - case, the application may save the current current value of total_in which - indicates where valid compressed data was found. In the error case, the - application may repeatedly call inflateSync, providing more input each time, - until success or end of the input data. -} - - -function inflateSyncPoint(var z : z_stream) : int; - - -implementation - -uses - imadler; - -function inflateReset(var z : z_stream) : int; -begin - if (z.state = Z_NULL) then - begin - inflateReset := Z_STREAM_ERROR; - exit; - end; - z.total_out := 0; - z.total_in := 0; - z.msg := ''; - if z.state^.nowrap then - z.state^.mode := BLOCKS - else - z.state^.mode := METHOD; - inflate_blocks_reset(z.state^.blocks^, z, Z_NULL); - {$IFDEF DEBUG} - Tracev('inflate: reset'); - {$ENDIF} - inflateReset := Z_OK; -end; - - -function inflateEnd(var z : z_stream) : int; -begin - if (z.state = Z_NULL) or not Assigned(z.zfree) then - begin - inflateEnd := Z_STREAM_ERROR; - exit; - end; - if (z.state^.blocks <> Z_NULL) then - inflate_blocks_free(z.state^.blocks, z); - ZFREE(z, z.state); - z.state := Z_NULL; - {$IFDEF DEBUG} - Tracev('inflate: end'); - {$ENDIF} - inflateEnd := Z_OK; -end; - - -function inflateInit2_(var z: z_stream; - w : int; - const version : AnsiString; - stream_size : int) : int; -begin - if (version = '') or (version[1] <> ZLIB_VERSION[1]) or - (stream_size <> sizeof(z_stream)) then - begin - inflateInit2_ := Z_VERSION_ERROR; - exit; - end; - { initialize state } - { SetLength(strm.msg, 255); } - z.msg := ''; - if not Assigned(z.zalloc) then - begin - {$IFDEF FPC} z.zalloc := @zcalloc; {$ELSE} - z.zalloc := zcalloc; - {$endif} - z.opaque := voidpf(0); - end; - if not Assigned(z.zfree) then - {$IFDEF FPC} z.zfree := @zcfree; {$ELSE} - z.zfree := zcfree; - {$ENDIF} - - z.state := pInternal_state( ZALLOC(z,1,sizeof(internal_state)) ); - if (z.state = Z_NULL) then - begin - inflateInit2_ := Z_MEM_ERROR; - exit; - end; - - z.state^.blocks := Z_NULL; - - { handle undocumented nowrap option (no zlib header or check) } - z.state^.nowrap := FALSE; - if (w < 0) then - begin - w := - w; - z.state^.nowrap := TRUE; - end; - - { set window size } - if (w < 8) or (w > 15) then - begin - inflateEnd(z); - inflateInit2_ := Z_STREAM_ERROR; - exit; - end; - z.state^.wbits := uInt(w); - - { create inflate_blocks state } - if z.state^.nowrap then - z.state^.blocks := inflate_blocks_new(z, NIL, uInt(1) shl w) - else - {$IFDEF FPC} - z.state^.blocks := inflate_blocks_new(z, @adler32, uInt(1) shl w); - {$ELSE} - z.state^.blocks := inflate_blocks_new(z, adler32, uInt(1) shl w); - {$ENDIF} - if (z.state^.blocks = Z_NULL) then - begin - inflateEnd(z); - inflateInit2_ := Z_MEM_ERROR; - exit; - end; - {$IFDEF DEBUG} - Tracev('inflate: allocated'); - {$ENDIF} - { reset state } - inflateReset(z); - inflateInit2_ := Z_OK; -end; - -function inflateInit2(var z: z_stream; windowBits : int) : int; -begin - inflateInit2 := inflateInit2_(z, windowBits, ZLIB_VERSION, sizeof(z_stream)); -end; - - -function inflateInit(var z : z_stream) : int; -{ inflateInit is a macro to allow checking the zlib version - and the compiler's view of z_stream: } -begin - inflateInit := inflateInit2_(z, DEF_WBITS, ZLIB_VERSION, sizeof(z_stream)); -end; - -function inflateInit_(z : z_streamp; - const version : AnsiString; - stream_size : int) : int; -begin - { initialize state } - if (z = Z_NULL) then - inflateInit_ := Z_STREAM_ERROR - else - inflateInit_ := inflateInit2_(z^, DEF_WBITS, version, stream_size); -end; - -function inflate(var z : z_stream; - f : int) : int; -var - r : int; - b : uInt; -begin - if (z.state = Z_NULL) or (z.next_in = Z_NULL) then - begin - inflate := Z_STREAM_ERROR; - exit; - end; - if f = Z_FINISH then - f := Z_BUF_ERROR - else - f := Z_OK; - r := Z_BUF_ERROR; - while True do - case (z.state^.mode) of - BLOCKS: - begin - r := inflate_blocks(z.state^.blocks^, z, r); - if (r = Z_DATA_ERROR) then - begin - z.state^.mode := BAD; - z.state^.sub.marker := 0; { can try inflateSync } - continue; { break C-switch } - end; - if (r = Z_OK) then - r := f; - if (r <> Z_STREAM_END) then - begin - inflate := r; - exit; - end; - r := f; - inflate_blocks_reset(z.state^.blocks^, z, @z.state^.sub.check.was); - if (z.state^.nowrap) then - begin - z.state^.mode := DONE; - continue; { break C-switch } - end; - z.state^.mode := CHECK4; { falltrough } - end; - CHECK4: - begin - {NEEDBYTE} - if (z.avail_in = 0) then - begin - inflate := r; - exit; - end; - r := f; - - {z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;} - Dec(z.avail_in); - Inc(z.total_in); - z.state^.sub.check.need := uLong(z.next_in^) shl 24; - Inc(z.next_in); - - z.state^.mode := CHECK3; { falltrough } - end; - CHECK3: - begin - {NEEDBYTE} - if (z.avail_in = 0) then - begin - inflate := r; - exit; - end; - r := f; - {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);} - Dec(z.avail_in); - Inc(z.total_in); - Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16); - Inc(z.next_in); - - z.state^.mode := CHECK2; { falltrough } - end; - CHECK2: - begin - {NEEDBYTE} - if (z.avail_in = 0) then - begin - inflate := r; - exit; - end; - r := f; - - {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);} - Dec(z.avail_in); - Inc(z.total_in); - Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8); - Inc(z.next_in); - - z.state^.mode := CHECK1; { falltrough } - end; - CHECK1: - begin - {NEEDBYTE} - if (z.avail_in = 0) then - begin - inflate := r; - exit; - end; - r := f; - {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) );} - Dec(z.avail_in); - Inc(z.total_in); - Inc(z.state^.sub.check.need, uLong(z.next_in^) ); - Inc(z.next_in); - - - if (z.state^.sub.check.was <> z.state^.sub.check.need) then - begin - z.state^.mode := BAD; - z.msg := 'incorrect data check'; - z.state^.sub.marker := 5; { can't try inflateSync } - continue; { break C-switch } - end; - {$IFDEF DEBUG} - Tracev('inflate: zlib check ok'); - {$ENDIF} - z.state^.mode := DONE; { falltrough } - end; - DONE: - begin - inflate := Z_STREAM_END; - exit; - end; - METHOD: - begin - {NEEDBYTE} - if (z.avail_in = 0) then - begin - inflate := r; - exit; - end; - r := f; {} - - {z.state^.sub.method := NEXTBYTE(z);} - Dec(z.avail_in); - Inc(z.total_in); - z.state^.sub.method := z.next_in^; - Inc(z.next_in); - - if ((z.state^.sub.method and $0f) <> Z_DEFLATED) then - begin - z.state^.mode := BAD; - z.msg := 'unknown compression method'; - z.state^.sub.marker := 5; { can't try inflateSync } - continue; { break C-switch } - end; - if ((z.state^.sub.method shr 4) + 8 > z.state^.wbits) then - begin - z.state^.mode := BAD; - z.msg := 'invalid window size'; - z.state^.sub.marker := 5; { can't try inflateSync } - continue; { break C-switch } - end; - z.state^.mode := FLAG; - { fall trough } - end; - FLAG: - begin - {NEEDBYTE} - if (z.avail_in = 0) then - begin - inflate := r; - exit; - end; - r := f; {} - {b := NEXTBYTE(z);} - Dec(z.avail_in); - Inc(z.total_in); - b := z.next_in^; - Inc(z.next_in); - - if (((z.state^.sub.method shl 8) + b) mod 31) <> 0 then {% mod ?} - begin - z.state^.mode := BAD; - z.msg := 'incorrect header check'; - z.state^.sub.marker := 5; { can't try inflateSync } - continue; { break C-switch } - end; - {$IFDEF DEBUG} - Tracev('inflate: zlib header ok'); - {$ENDIF} - if ((b and PRESET_DICT) = 0) then - begin - z.state^.mode := BLOCKS; - continue; { break C-switch } - end; - z.state^.mode := DICT4; - { falltrough } - end; - DICT4: - begin - if (z.avail_in = 0) then - begin - inflate := r; - exit; - end; - r := f; - - {z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;} - Dec(z.avail_in); - Inc(z.total_in); - z.state^.sub.check.need := uLong(z.next_in^) shl 24; - Inc(z.next_in); - - z.state^.mode := DICT3; { falltrough } - end; - DICT3: - begin - if (z.avail_in = 0) then - begin - inflate := r; - exit; - end; - r := f; - {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);} - Dec(z.avail_in); - Inc(z.total_in); - Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16); - Inc(z.next_in); - - z.state^.mode := DICT2; { falltrough } - end; - DICT2: - begin - if (z.avail_in = 0) then - begin - inflate := r; - exit; - end; - r := f; - - {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);} - Dec(z.avail_in); - Inc(z.total_in); - Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8); - Inc(z.next_in); - - z.state^.mode := DICT1; { falltrough } - end; - DICT1: - begin - if (z.avail_in = 0) then - begin - inflate := r; - exit; - end; - { r := f; --- wird niemals benutzt } - {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) );} - Dec(z.avail_in); - Inc(z.total_in); - Inc(z.state^.sub.check.need, uLong(z.next_in^) ); - Inc(z.next_in); - - z.adler := z.state^.sub.check.need; - z.state^.mode := DICT0; - inflate := Z_NEED_DICT; - exit; - end; - DICT0: - begin - z.state^.mode := BAD; - z.msg := 'need dictionary'; - z.state^.sub.marker := 0; { can try inflateSync } - inflate := Z_STREAM_ERROR; - exit; - end; - BAD: - begin - inflate := Z_DATA_ERROR; - exit; - end; - else - begin - inflate := Z_STREAM_ERROR; - exit; - end; - end; -{$ifdef NEED_DUMMY_result} - result := Z_STREAM_ERROR; { Some dumb compilers complain without this } -{$endif} -end; - -function inflateSetDictionary(var z : z_stream; - dictionary : pBytef; {const array of byte} - dictLength : uInt) : int; -var - length : uInt; -begin - length := dictLength; - - if (z.state = Z_NULL) or (z.state^.mode <> DICT0) then - begin - inflateSetDictionary := Z_STREAM_ERROR; - exit; - end; - if (adler32(Long(1), dictionary, dictLength) <> z.adler) then - begin - inflateSetDictionary := Z_DATA_ERROR; - exit; - end; - z.adler := Long(1); - - if (length >= (uInt(1) shl z.state^.wbits)) then - begin - length := (1 shl z.state^.wbits)-1; - Inc( dictionary, dictLength - length); - end; - inflate_set_dictionary(z.state^.blocks^, dictionary^, length); - z.state^.mode := BLOCKS; - inflateSetDictionary := Z_OK; -end; - - -function inflateSync(var z : z_stream) : int; -const - mark : packed array[0..3] of byte = (0, 0, $ff, $ff); -var - n : uInt; { number of bytes to look at } - p : pBytef; { pointer to bytes } - m : uInt; { number of marker bytes found in a row } - r, w : uLong; { temporaries to save total_in and total_out } -begin - { set up } - if (z.state = Z_NULL) then - begin - inflateSync := Z_STREAM_ERROR; - exit; - end; - if (z.state^.mode <> BAD) then - begin - z.state^.mode := BAD; - z.state^.sub.marker := 0; - end; - n := z.avail_in; - if (n = 0) then - begin - inflateSync := Z_BUF_ERROR; - exit; - end; - p := z.next_in; - m := z.state^.sub.marker; - - { search } - while (n <> 0) and (m < 4) do - begin - if (p^ = mark[m]) then - Inc(m) - else - if (p^ <> 0) then - m := 0 - else - m := 4 - m; - Inc(p); - Dec(n); - end; - - { restore } - Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); - z.next_in := p; - z.avail_in := n; - z.state^.sub.marker := m; - - - { return no joy or set up to restart on a new block } - if (m <> 4) then - begin - inflateSync := Z_DATA_ERROR; - exit; - end; - r := z.total_in; - w := z.total_out; - inflateReset(z); - z.total_in := r; - z.total_out := w; - z.state^.mode := BLOCKS; - inflateSync := Z_OK; -end; - - -{ - returns true if inflate is currently at the end of a block generated - by Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP - implementation to provide an additional safety check. PPP uses Z_SYNC_FLUSH - but removes the length bytes of the resulting empty stored block. When - decompressing, PPP checks that at the end of input packet, inflate is - waiting for these length bytes. -} - -function inflateSyncPoint(var z : z_stream) : int; -begin - if (z.state = Z_NULL) or (z.state^.blocks = Z_NULL) then - begin - inflateSyncPoint := Z_STREAM_ERROR; - exit; - end; - inflateSyncPoint := inflate_blocks_sync_point(z.state^.blocks^); -end; - -end. +Unit imzinflate; + +{ inflate.c -- zlib interface to inflate modules + Copyright (C) 1995-1998 Mark Adler + + Pascal tranlastion + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I imzconf.inc} + +uses + imzutil, impaszlib, iminfblock, iminfutil; + +function inflateInit(var z : z_stream) : int; + +{ Initializes the internal stream state for decompression. The fields + zalloc, zfree and opaque must be initialized before by the caller. If + zalloc and zfree are set to Z_NULL, inflateInit updates them to use default + allocation functions. + + inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not + enough memory, Z_VERSION_ERROR if the zlib library version is incompatible + with the version assumed by the caller. msg is set to null if there is no + error message. inflateInit does not perform any decompression: this will be + done by inflate(). } + + + +function inflateInit_(z : z_streamp; + const version : AnsiString; + stream_size : int) : int; + + +function inflateInit2_(var z: z_stream; + w : int; + const version : AnsiString; + stream_size : int) : int; + +function inflateInit2(var z: z_stream; + windowBits : int) : int; + +{ + This is another version of inflateInit with an extra parameter. The + fields next_in, avail_in, zalloc, zfree and opaque must be initialized + before by the caller. + + The windowBits parameter is the base two logarithm of the maximum window + size (the size of the history buffer). It should be in the range 8..15 for + this version of the library. The default value is 15 if inflateInit is used + instead. If a compressed stream with a larger window size is given as + input, inflate() will return with the error code Z_DATA_ERROR instead of + trying to allocate a larger window. + + inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough + memory, Z_STREAM_ERROR if a parameter is invalid (such as a negative + memLevel). msg is set to null if there is no error message. inflateInit2 + does not perform any decompression apart from reading the zlib header if + present: this will be done by inflate(). (So next_in and avail_in may be + modified, but next_out and avail_out are unchanged.) +} + + + +function inflateEnd(var z : z_stream) : int; + +{ + All dynamically allocated data structures for this stream are freed. + This function discards any unprocessed input and does not flush any + pending output. + + inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state + was inconsistent. In the error case, msg may be set but then points to a + static string (which must not be deallocated). +} + +function inflateReset(var z : z_stream) : int; + +{ + This function is equivalent to inflateEnd followed by inflateInit, + but does not free and reallocate all the internal decompression state. + The stream will keep attributes that may have been set by inflateInit2. + + inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source + stream state was inconsistent (such as zalloc or state being NULL). +} + + +function inflate(var z : z_stream; + f : int) : int; +{ + inflate decompresses as much data as possible, and stops when the input + buffer becomes empty or the output buffer becomes full. It may introduce + some output latency (reading input without producing any output) + except when forced to flush. + + The detailed semantics are as follows. inflate performs one or both of the + following actions: + + - Decompress more input starting at next_in and update next_in and avail_in + accordingly. If not all input can be processed (because there is not + enough room in the output buffer), next_in is updated and processing + will resume at this point for the next call of inflate(). + + - Provide more output starting at next_out and update next_out and avail_out + accordingly. inflate() provides as much output as possible, until there + is no more input data or no more space in the output buffer (see below + about the flush parameter). + + Before the call of inflate(), the application should ensure that at least + one of the actions is possible, by providing more input and/or consuming + more output, and updating the next_* and avail_* values accordingly. + The application can consume the uncompressed output when it wants, for + example when the output buffer is full (avail_out == 0), or after each + call of inflate(). If inflate returns Z_OK and with zero avail_out, it + must be called again after making room in the output buffer because there + might be more output pending. + + If the parameter flush is set to Z_SYNC_FLUSH, inflate flushes as much + output as possible to the output buffer. The flushing behavior of inflate is + not specified for values of the flush parameter other than Z_SYNC_FLUSH + and Z_FINISH, but the current implementation actually flushes as much output + as possible anyway. + + inflate() should normally be called until it returns Z_STREAM_END or an + error. However if all decompression is to be performed in a single step + (a single call of inflate), the parameter flush should be set to + Z_FINISH. In this case all pending input is processed and all pending + output is flushed; avail_out must be large enough to hold all the + uncompressed data. (The size of the uncompressed data may have been saved + by the compressor for this purpose.) The next operation on this stream must + be inflateEnd to deallocate the decompression state. The use of Z_FINISH + is never required, but can be used to inform inflate that a faster routine + may be used for the single inflate() call. + + If a preset dictionary is needed at this point (see inflateSetDictionary + below), inflate sets strm-adler to the adler32 checksum of the + dictionary chosen by the compressor and returns Z_NEED_DICT; otherwise + it sets strm->adler to the adler32 checksum of all output produced + so far (that is, total_out bytes) and returns Z_OK, Z_STREAM_END or + an error code as described below. At the end of the stream, inflate() + checks that its computed adler32 checksum is equal to that saved by the + compressor and returns Z_STREAM_END only if the checksum is correct. + + inflate() returns Z_OK if some progress has been made (more input processed + or more output produced), Z_STREAM_END if the end of the compressed data has + been reached and all uncompressed output has been produced, Z_NEED_DICT if a + preset dictionary is needed at this point, Z_DATA_ERROR if the input data was + corrupted (input stream not conforming to the zlib format or incorrect + adler32 checksum), Z_STREAM_ERROR if the stream structure was inconsistent + (for example if next_in or next_out was NULL), Z_MEM_ERROR if there was not + enough memory, Z_BUF_ERROR if no progress is possible or if there was not + enough room in the output buffer when Z_FINISH is used. In the Z_DATA_ERROR + case, the application may then call inflateSync to look for a good + compression block. +} + + +function inflateSetDictionary(var z : z_stream; + dictionary : pBytef; {const array of byte} + dictLength : uInt) : int; + +{ + Initializes the decompression dictionary from the given uncompressed byte + sequence. This function must be called immediately after a call of inflate + if this call returned Z_NEED_DICT. The dictionary chosen by the compressor + can be determined from the Adler32 value returned by this call of + inflate. The compressor and decompressor must use exactly the same + dictionary (see deflateSetDictionary). + + inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a + parameter is invalid (such as NULL dictionary) or the stream state is + inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the + expected one (incorrect Adler32 value). inflateSetDictionary does not + perform any decompression: this will be done by subsequent calls of + inflate(). +} + +function inflateSync(var z : z_stream) : int; + +{ + Skips invalid compressed data until a full flush point (see above the + description of deflate with Z_FULL_FLUSH) can be found, or until all + available input is skipped. No output is provided. + + inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR + if no more input was provided, Z_DATA_ERROR if no flush point has been found, + or Z_STREAM_ERROR if the stream structure was inconsistent. In the success + case, the application may save the current current value of total_in which + indicates where valid compressed data was found. In the error case, the + application may repeatedly call inflateSync, providing more input each time, + until success or end of the input data. +} + + +function inflateSyncPoint(var z : z_stream) : int; + + +implementation + +uses + imadler; + +function inflateReset(var z : z_stream) : int; +begin + if (z.state = Z_NULL) then + begin + inflateReset := Z_STREAM_ERROR; + exit; + end; + z.total_out := 0; + z.total_in := 0; + z.msg := ''; + if z.state^.nowrap then + z.state^.mode := BLOCKS + else + z.state^.mode := METHOD; + inflate_blocks_reset(z.state^.blocks^, z, Z_NULL); + {$IFDEF DEBUG} + Tracev('inflate: reset'); + {$ENDIF} + inflateReset := Z_OK; +end; + + +function inflateEnd(var z : z_stream) : int; +begin + if (z.state = Z_NULL) or not Assigned(z.zfree) then + begin + inflateEnd := Z_STREAM_ERROR; + exit; + end; + if (z.state^.blocks <> Z_NULL) then + inflate_blocks_free(z.state^.blocks, z); + ZFREE(z, z.state); + z.state := Z_NULL; + {$IFDEF DEBUG} + Tracev('inflate: end'); + {$ENDIF} + inflateEnd := Z_OK; +end; + + +function inflateInit2_(var z: z_stream; + w : int; + const version : AnsiString; + stream_size : int) : int; +begin + if (version = '') or (version[1] <> ZLIB_VERSION[1]) or + (stream_size <> sizeof(z_stream)) then + begin + inflateInit2_ := Z_VERSION_ERROR; + exit; + end; + { initialize state } + { SetLength(strm.msg, 255); } + z.msg := ''; + if not Assigned(z.zalloc) then + begin + {$IFDEF FPC} z.zalloc := @zcalloc; {$ELSE} + z.zalloc := zcalloc; + {$endif} + z.opaque := voidpf(0); + end; + if not Assigned(z.zfree) then + {$IFDEF FPC} z.zfree := @zcfree; {$ELSE} + z.zfree := zcfree; + {$ENDIF} + + z.state := pInternal_state( ZALLOC(z,1,sizeof(internal_state)) ); + if (z.state = Z_NULL) then + begin + inflateInit2_ := Z_MEM_ERROR; + exit; + end; + + z.state^.blocks := Z_NULL; + + { handle undocumented nowrap option (no zlib header or check) } + z.state^.nowrap := FALSE; + if (w < 0) then + begin + w := - w; + z.state^.nowrap := TRUE; + end; + + { set window size } + if (w < 8) or (w > 15) then + begin + inflateEnd(z); + inflateInit2_ := Z_STREAM_ERROR; + exit; + end; + z.state^.wbits := uInt(w); + + { create inflate_blocks state } + if z.state^.nowrap then + z.state^.blocks := inflate_blocks_new(z, NIL, uInt(1) shl w) + else + {$IFDEF FPC} + z.state^.blocks := inflate_blocks_new(z, @adler32, uInt(1) shl w); + {$ELSE} + z.state^.blocks := inflate_blocks_new(z, adler32, uInt(1) shl w); + {$ENDIF} + if (z.state^.blocks = Z_NULL) then + begin + inflateEnd(z); + inflateInit2_ := Z_MEM_ERROR; + exit; + end; + {$IFDEF DEBUG} + Tracev('inflate: allocated'); + {$ENDIF} + { reset state } + inflateReset(z); + inflateInit2_ := Z_OK; +end; + +function inflateInit2(var z: z_stream; windowBits : int) : int; +begin + inflateInit2 := inflateInit2_(z, windowBits, ZLIB_VERSION, sizeof(z_stream)); +end; + + +function inflateInit(var z : z_stream) : int; +{ inflateInit is a macro to allow checking the zlib version + and the compiler's view of z_stream: } +begin + inflateInit := inflateInit2_(z, DEF_WBITS, ZLIB_VERSION, sizeof(z_stream)); +end; + +function inflateInit_(z : z_streamp; + const version : AnsiString; + stream_size : int) : int; +begin + { initialize state } + if (z = Z_NULL) then + inflateInit_ := Z_STREAM_ERROR + else + inflateInit_ := inflateInit2_(z^, DEF_WBITS, version, stream_size); +end; + +function inflate(var z : z_stream; + f : int) : int; +var + r : int; + b : uInt; +begin + if (z.state = Z_NULL) or (z.next_in = Z_NULL) then + begin + inflate := Z_STREAM_ERROR; + exit; + end; + if f = Z_FINISH then + f := Z_BUF_ERROR + else + f := Z_OK; + r := Z_BUF_ERROR; + while True do + case (z.state^.mode) of + BLOCKS: + begin + r := inflate_blocks(z.state^.blocks^, z, r); + if (r = Z_DATA_ERROR) then + begin + z.state^.mode := BAD; + z.state^.sub.marker := 0; { can try inflateSync } + continue; { break C-switch } + end; + if (r = Z_OK) then + r := f; + if (r <> Z_STREAM_END) then + begin + inflate := r; + exit; + end; + r := f; + inflate_blocks_reset(z.state^.blocks^, z, @z.state^.sub.check.was); + if (z.state^.nowrap) then + begin + z.state^.mode := DONE; + continue; { break C-switch } + end; + z.state^.mode := CHECK4; { falltrough } + end; + CHECK4: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;} + Dec(z.avail_in); + Inc(z.total_in); + z.state^.sub.check.need := uLong(z.next_in^) shl 24; + Inc(z.next_in); + + z.state^.mode := CHECK3; { falltrough } + end; + CHECK3: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16); + Inc(z.next_in); + + z.state^.mode := CHECK2; { falltrough } + end; + CHECK2: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8); + Inc(z.next_in); + + z.state^.mode := CHECK1; { falltrough } + end; + CHECK1: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + {Inc( z.state^.sub.check.need, uLong(NEXTBYTE(z)) );} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) ); + Inc(z.next_in); + + + if (z.state^.sub.check.was <> z.state^.sub.check.need) then + begin + z.state^.mode := BAD; + z.msg := 'incorrect data check'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + {$IFDEF DEBUG} + Tracev('inflate: zlib check ok'); + {$ENDIF} + z.state^.mode := DONE; { falltrough } + end; + DONE: + begin + inflate := Z_STREAM_END; + exit; + end; + METHOD: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; {} + + {z.state^.sub.method := NEXTBYTE(z);} + Dec(z.avail_in); + Inc(z.total_in); + z.state^.sub.method := z.next_in^; + Inc(z.next_in); + + if ((z.state^.sub.method and $0f) <> Z_DEFLATED) then + begin + z.state^.mode := BAD; + z.msg := 'unknown compression method'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + if ((z.state^.sub.method shr 4) + 8 > z.state^.wbits) then + begin + z.state^.mode := BAD; + z.msg := 'invalid window size'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + z.state^.mode := FLAG; + { fall trough } + end; + FLAG: + begin + {NEEDBYTE} + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; {} + {b := NEXTBYTE(z);} + Dec(z.avail_in); + Inc(z.total_in); + b := z.next_in^; + Inc(z.next_in); + + if (((z.state^.sub.method shl 8) + b) mod 31) <> 0 then {% mod ?} + begin + z.state^.mode := BAD; + z.msg := 'incorrect header check'; + z.state^.sub.marker := 5; { can't try inflateSync } + continue; { break C-switch } + end; + {$IFDEF DEBUG} + Tracev('inflate: zlib header ok'); + {$ENDIF} + if ((b and PRESET_DICT) = 0) then + begin + z.state^.mode := BLOCKS; + continue; { break C-switch } + end; + z.state^.mode := DICT4; + { falltrough } + end; + DICT4: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {z.state^.sub.check.need := uLong(NEXTBYTE(z)) shl 24;} + Dec(z.avail_in); + Inc(z.total_in); + z.state^.sub.check.need := uLong(z.next_in^) shl 24; + Inc(z.next_in); + + z.state^.mode := DICT3; { falltrough } + end; + DICT3: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 16);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 16); + Inc(z.next_in); + + z.state^.mode := DICT2; { falltrough } + end; + DICT2: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + r := f; + + {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) shl 8);} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) shl 8); + Inc(z.next_in); + + z.state^.mode := DICT1; { falltrough } + end; + DICT1: + begin + if (z.avail_in = 0) then + begin + inflate := r; + exit; + end; + { r := f; --- wird niemals benutzt } + {Inc(z.state^.sub.check.need, uLong(NEXTBYTE(z)) );} + Dec(z.avail_in); + Inc(z.total_in); + Inc(z.state^.sub.check.need, uLong(z.next_in^) ); + Inc(z.next_in); + + z.adler := z.state^.sub.check.need; + z.state^.mode := DICT0; + inflate := Z_NEED_DICT; + exit; + end; + DICT0: + begin + z.state^.mode := BAD; + z.msg := 'need dictionary'; + z.state^.sub.marker := 0; { can try inflateSync } + inflate := Z_STREAM_ERROR; + exit; + end; + BAD: + begin + inflate := Z_DATA_ERROR; + exit; + end; + else + begin + inflate := Z_STREAM_ERROR; + exit; + end; + end; +{$ifdef NEED_DUMMY_result} + result := Z_STREAM_ERROR; { Some dumb compilers complain without this } +{$endif} +end; + +function inflateSetDictionary(var z : z_stream; + dictionary : pBytef; {const array of byte} + dictLength : uInt) : int; +var + length : uInt; +begin + length := dictLength; + + if (z.state = Z_NULL) or (z.state^.mode <> DICT0) then + begin + inflateSetDictionary := Z_STREAM_ERROR; + exit; + end; + if (adler32(Long(1), dictionary, dictLength) <> z.adler) then + begin + inflateSetDictionary := Z_DATA_ERROR; + exit; + end; + z.adler := Long(1); + + if (length >= (uInt(1) shl z.state^.wbits)) then + begin + length := (1 shl z.state^.wbits)-1; + Inc( dictionary, dictLength - length); + end; + inflate_set_dictionary(z.state^.blocks^, dictionary^, length); + z.state^.mode := BLOCKS; + inflateSetDictionary := Z_OK; +end; + + +function inflateSync(var z : z_stream) : int; +const + mark : packed array[0..3] of byte = (0, 0, $ff, $ff); +var + n : uInt; { number of bytes to look at } + p : pBytef; { pointer to bytes } + m : uInt; { number of marker bytes found in a row } + r, w : uLong; { temporaries to save total_in and total_out } +begin + { set up } + if (z.state = Z_NULL) then + begin + inflateSync := Z_STREAM_ERROR; + exit; + end; + if (z.state^.mode <> BAD) then + begin + z.state^.mode := BAD; + z.state^.sub.marker := 0; + end; + n := z.avail_in; + if (n = 0) then + begin + inflateSync := Z_BUF_ERROR; + exit; + end; + p := z.next_in; + m := z.state^.sub.marker; + + { search } + while (n <> 0) and (m < 4) do + begin + if (p^ = mark[m]) then + Inc(m) + else + if (p^ <> 0) then + m := 0 + else + m := 4 - m; + Inc(p); + Dec(n); + end; + + { restore } + Inc(z.total_in, ptr2int(p) - ptr2int(z.next_in)); + z.next_in := p; + z.avail_in := n; + z.state^.sub.marker := m; + + + { return no joy or set up to restart on a new block } + if (m <> 4) then + begin + inflateSync := Z_DATA_ERROR; + exit; + end; + r := z.total_in; + w := z.total_out; + inflateReset(z); + z.total_in := r; + z.total_out := w; + z.state^.mode := BLOCKS; + inflateSync := Z_OK; +end; + + +{ + returns true if inflate is currently at the end of a block generated + by Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP + implementation to provide an additional safety check. PPP uses Z_SYNC_FLUSH + but removes the length bytes of the resulting empty stored block. When + decompressing, PPP checks that at the end of input packet, inflate is + waiting for these length bytes. +} + +function inflateSyncPoint(var z : z_stream) : int; +begin + if (z.state = Z_NULL) or (z.state^.blocks = Z_NULL) then + begin + inflateSyncPoint := Z_STREAM_ERROR; + exit; + end; + inflateSyncPoint := inflate_blocks_sync_point(z.state^.blocks^); +end; + +end. diff --git a/Imaging/ZLib/imzutil.pas b/Imaging/ZLib/imzutil.pas index 420b5fb..a53ef7c 100644 --- a/Imaging/ZLib/imzutil.pas +++ b/Imaging/ZLib/imzutil.pas @@ -1,191 +1,195 @@ -Unit imzutil; - -{ - Copyright (C) 1998 by Jacques Nomssi Nzali - For conditions of distribution and use, see copyright notice in readme.txt -} - -interface - -{$I imzconf.inc} - -{ Type declarations } - -type - {Byte = usigned char; 8 bits} - Bytef = byte; - charf = byte; - - int = longint; - intf = int; - uInt = cardinal; { 16 bits or more } - uIntf = uInt; - - Long = longint; - uLong = Cardinal; - uLongf = uLong; - - voidp = pointer; - voidpf = voidp; - pBytef = ^Bytef; - pIntf = ^intf; - puIntf = ^uIntf; - puLong = ^uLongf; - - ptr2int = uInt; -{ a pointer to integer casting is used to do pointer arithmetic. - ptr2int must be an integer type and sizeof(ptr2int) must be less - than sizeof(pointer) - Nomssi } - -type - zByteArray = array[0..(MaxInt div SizeOf(Bytef))-1] of Bytef; - pzByteArray = ^zByteArray; -type - zIntfArray = array[0..(MaxInt div SizeOf(Intf))-1] of Intf; - pzIntfArray = ^zIntfArray; -type - zuIntArray = array[0..(MaxInt div SizeOf(uInt))-1] of uInt; - PuIntArray = ^zuIntArray; - -{ Type declarations - only for deflate } - -type - uch = Byte; - uchf = uch; { FAR } - ush = Word; - ushf = ush; - ulg = LongInt; - - unsigned = uInt; - - pcharf = ^charf; - puchf = ^uchf; - pushf = ^ushf; - -type - zuchfArray = zByteArray; - puchfArray = ^zuchfArray; -type - zushfArray = array[0..(MaxInt div SizeOf(ushf))-1] of ushf; - pushfArray = ^zushfArray; - -procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt); -function zmemcmp(s1p, s2p : pBytef; len : uInt) : int; -procedure zmemzero(destp : pBytef; len : uInt); -procedure zcfree(opaque : voidpf; ptr : voidpf); -function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf; - -implementation - -procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt); -begin - Move(sourcep^, destp^, len); -end; - -function zmemcmp(s1p, s2p : pBytef; len : uInt) : int; -var - j : uInt; - source, - dest : pBytef; -begin - source := s1p; - dest := s2p; - for j := 0 to pred(len) do - begin - if (source^ <> dest^) then - begin - zmemcmp := 2*Ord(source^ > dest^)-1; - exit; - end; - Inc(source); - Inc(dest); - end; - zmemcmp := 0; -end; - -procedure zmemzero(destp : pBytef; len : uInt); -begin - FillChar(destp^, len, 0); -end; - -procedure zcfree(opaque : voidpf; ptr : voidpf); -{$ifdef Delphi16} -var - Handle : THandle; -{$endif} -{$IFDEF FPC} -var - memsize : uint; -{$ENDIF} -begin - (* - {$IFDEF DPMI} - {h :=} GlobalFreePtr(ptr); - {$ELSE} - {$IFDEF CALL_DOS} - dosFree(ptr); - {$ELSE} - {$ifdef HugeMem} - FreeMemHuge(ptr); - {$else} - {$ifdef Delphi16} - Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) } - GlobalUnLock(Handle); - GlobalFree(Handle); - {$else} - {$IFDEF FPC} - Dec(puIntf(ptr)); - memsize := puIntf(ptr)^; - FreeMem(ptr, memsize+SizeOf(uInt)); - {$ELSE} - FreeMem(ptr); { Delphi 2,3,4 } - {$ENDIF} - {$endif} - {$endif} - {$ENDIF} - {$ENDIF} - *) - FreeMem(ptr); -end; - -function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf; -var - p : voidpf; - memsize : uLong; -{$ifdef Delphi16} - handle : THandle; -{$endif} -begin - memsize := uLong(items) * size; - (* - { $IFDEF DPMI} - p := GlobalAllocPtr(gmem_moveable, memsize); - { $ELSE} - { $IFDEF CALLDOS} - p := dosAlloc(memsize); - { $ELSE} - {$ifdef HugeMem} - GetMemHuge(p, memsize); - { $else} - { $ifdef Delphi16} - Handle := GlobalAlloc(HeapAllocFlags, memsize); - p := GlobalLock(Handle); - { $else} - { $IFDEF FPC} - GetMem(p, memsize+SizeOf(uInt)); - puIntf(p)^:= memsize; - Inc(puIntf(p)); - { $ELSE} - GetMem(p, memsize); { Delphi: p := AllocMem(memsize); } - { $ENDIF} - { $endif} - { $endif} - { $ENDIF} - { $ENDIF} - *) - GetMem(p, memsize); - zcalloc := p; -end; - -end. - +Unit imzutil; + +{ + Copyright (C) 1998 by Jacques Nomssi Nzali + For conditions of distribution and use, see copyright notice in readme.txt +} + +interface + +{$I imzconf.inc} + +{ Type declarations } + +type + {Byte = usigned char; 8 bits} + Bytef = byte; + charf = byte; + + int = longint; + intf = int; + uInt = cardinal; { 16 bits or more } + uIntf = uInt; + + Long = longint; + uLong = Cardinal; + uLongf = uLong; + + voidp = pointer; + voidpf = voidp; + pBytef = ^Bytef; + pIntf = ^intf; + puIntf = ^uIntf; + puLong = ^uLongf; + +{$IF Defined(FPC)} + ptr2int = PtrUInt; +{$ELSEIF CompilerVersion >= 20} + ptr2int = NativeUInt; +{$ELSE} + ptr2int = Cardinal; +{$IFEND} +{ a pointer to integer casting is used to do pointer arithmetic. } + +type + zByteArray = array[0..(MaxInt div SizeOf(Bytef))-1] of Bytef; + pzByteArray = ^zByteArray; +type + zIntfArray = array[0..(MaxInt div SizeOf(Intf))-1] of Intf; + pzIntfArray = ^zIntfArray; +type + zuIntArray = array[0..(MaxInt div SizeOf(uInt))-1] of uInt; + PuIntArray = ^zuIntArray; + +{ Type declarations - only for deflate } + +type + uch = Byte; + uchf = uch; { FAR } + ush = Word; + ushf = ush; + ulg = LongInt; + + unsigned = uInt; + + pcharf = ^charf; + puchf = ^uchf; + pushf = ^ushf; + +type + zuchfArray = zByteArray; + puchfArray = ^zuchfArray; +type + zushfArray = array[0..(MaxInt div SizeOf(ushf))-1] of ushf; + pushfArray = ^zushfArray; + +procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt); +function zmemcmp(s1p, s2p : pBytef; len : uInt) : int; +procedure zmemzero(destp : pBytef; len : uInt); +procedure zcfree(opaque : voidpf; ptr : voidpf); +function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf; + +implementation + +procedure zmemcpy(destp : pBytef; sourcep : pBytef; len : uInt); +begin + Move(sourcep^, destp^, len); +end; + +function zmemcmp(s1p, s2p : pBytef; len : uInt) : int; +var + j : uInt; + source, + dest : pBytef; +begin + source := s1p; + dest := s2p; + for j := 0 to pred(len) do + begin + if (source^ <> dest^) then + begin + zmemcmp := 2*Ord(source^ > dest^)-1; + exit; + end; + Inc(source); + Inc(dest); + end; + zmemcmp := 0; +end; + +procedure zmemzero(destp : pBytef; len : uInt); +begin + FillChar(destp^, len, 0); +end; + +procedure zcfree(opaque : voidpf; ptr : voidpf); +{$ifdef Delphi16} +var + Handle : THandle; +{$endif} +{$IFDEF FPC} +var + memsize : uint; +{$ENDIF} +begin + (* + {$IFDEF DPMI} + {h :=} GlobalFreePtr(ptr); + {$ELSE} + {$IFDEF CALL_DOS} + dosFree(ptr); + {$ELSE} + {$ifdef HugeMem} + FreeMemHuge(ptr); + {$else} + {$ifdef Delphi16} + Handle := GlobalHandle(LH(ptr).H); { HiWord(LongInt(ptr)) } + GlobalUnLock(Handle); + GlobalFree(Handle); + {$else} + {$IFDEF FPC} + Dec(puIntf(ptr)); + memsize := puIntf(ptr)^; + FreeMem(ptr, memsize+SizeOf(uInt)); + {$ELSE} + FreeMem(ptr); { Delphi 2,3,4 } + {$ENDIF} + {$endif} + {$endif} + {$ENDIF} + {$ENDIF} + *) + FreeMem(ptr); +end; + +function zcalloc (opaque : voidpf; items : uInt; size : uInt) : voidpf; +var + p : voidpf; + memsize : uLong; +{$ifdef Delphi16} + handle : THandle; +{$endif} +begin + memsize := uLong(items) * size; + (* + { $IFDEF DPMI} + p := GlobalAllocPtr(gmem_moveable, memsize); + { $ELSE} + { $IFDEF CALLDOS} + p := dosAlloc(memsize); + { $ELSE} + {$ifdef HugeMem} + GetMemHuge(p, memsize); + { $else} + { $ifdef Delphi16} + Handle := GlobalAlloc(HeapAllocFlags, memsize); + p := GlobalLock(Handle); + { $else} + { $IFDEF FPC} + GetMem(p, memsize+SizeOf(uInt)); + puIntf(p)^:= memsize; + Inc(puIntf(p)); + { $ELSE} + GetMem(p, memsize); { Delphi: p := AllocMem(memsize); } + { $ENDIF} + { $endif} + { $endif} + { $ENDIF} + { $ENDIF} + *) + GetMem(p, memsize); + zcalloc := p; +end; + +end. + diff --git a/Imaging/ZLib/readme.txt b/Imaging/ZLib/readme.txt index f9d8087..887d9ca 100644 --- a/Imaging/ZLib/readme.txt +++ b/Imaging/ZLib/readme.txt @@ -1,129 +1,129 @@ -_____________________________________________________________________________ - -PASZLIB 1.0 May 11th, 1998 - -Based on the zlib 1.1.2, a general purpose data compression library. - -Copyright (C) 1998,1999,2000 by NOMSSI NZALI Jacques H. C. -[kn&n DES] See "Legal issues" for conditions of distribution and use. -_____________________________________________________________________________ - - -Introduction -============ - -The 'zlib' compression library provides in-memory compression and -decompression functions, including integrity checks of the uncompressed -data. This version of the library supports only one compression method -(deflation) but other algorithms will be added later and will have the same -stream interface. - -Compression can be done in a single step if the buffers are large -enough (for example if an input file is mmap'ed), or can be done by -repeated calls of the compression function. In the latter case, the -application must provide more input and/or consume the output -(providing more output space) before each call. - -The default memory requirements for deflate are 256K plus a few kilobytes -for small objects. The default memory requirements for inflate are 32K -plus a few kilobytes for small objects. - -Change Log -========== - -March 24th 2000 - minizip code by Gilles Vollant ported to Pascal. - z_stream.msg defined as string[255] to avoid problems - with Delphi 2+ dynamic string handling. - changes to silence Delphi 5 compiler warning. If you - have Delphi 5, defines Delphi5 in zconf.inc - -May 7th 1999 - Some changes for FPC - deflateCopy() has new parameters - trees.pas - record constant definition -June 17th 1998 - Applied official 1.1.2 patch. - Memcheck turned off by default. - zutil.pas patch for Delphi 1 memory allocation corrected. - dzlib.txt file added. - compress2() is now exported - -June 25th 1998 - fixed a conversion bug: in inftrees.pas, ZFREE(z, v) was - missing in line 574; - -File list -========= - -Here is a road map to the files in the Paszlib distribution. - -readme.txt Introduction, Documentation -dzlib.txt Changes to Delphi sources for Paszlib stream classes - -include file - -zconf.inc Configuration declarations. - -Pascal source code files: - -adler.pas compute the Adler-32 checksum of a data stream -crc.pas compute the CRC-32 of a data stream -gzio.pas IO on .gz files -infblock.pas interpret and process block types to last block -infcodes.pas process literals and length/distance pairs -inffast.pas process literals and length/distance pairs fast -inftrees.pas generate Huffman trees for efficient decoding -infutil.pas types and macros common to blocks and codes -strutils.pas string utilities -trees.pas output deflated data using Huffman coding -zcompres.pas compress a memory buffer -zdeflate.pas compress data using the deflation algorithm -zinflate.pas zlib interface to inflate modules -zlib.pas zlib data structures. read the comments there! -zuncompr.pas decompress a memory buffer -zutil.pas - -minizip/ziputils.pas data structure and IO on .zip file -minizip/unzip.pas -minizip/zip.pas - -Test applications - -example.pas usage example of the zlib compression library -minigzip.pas simulate gzip using the zlib compression library -minizip/miniunz.pas simulates unzip using the zlib compression library -minizip/minizip.pas simulates zip using the zlib compression library - -Legal issues -============ - -Copyright (C) 1998,1999,2000 by Jacques Nomssi Nzali - - This software is provided 'as-is', without any express or implied - warranty. In no event will the author be held liable for any damages - arising from the use of this software. - - Permission is granted to anyone to use this software for any purpose, - including commercial applications, and to alter it and redistribute it - freely, subject to the following restrictions: - - 1. The origin of this software must not be misrepresented; you must not - claim that you wrote the original software. If you use this software - in a product, an acknowledgment in the product documentation would be - appreciated but is not required. - 2. Altered source versions must be plainly marked as such, and must not be - misrepresented as being the original software. - 3. This notice may not be removed or altered from any source distribution. - - -Archive Locations: -================== - -Check the Paszlib home page with links - - http://www.tu-chemnitz.de/~nomssi/paszlib.html - -The data format used by the zlib library is described by RFCs (Request for -Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt -(zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format). -These documents are also available in other formats from -ftp://ftp.uu.net/graphics/png/documents/zlib/zdoc-index.html. -____________________________________________________________________________ +_____________________________________________________________________________ + +PASZLIB 1.0 May 11th, 1998 + +Based on the zlib 1.1.2, a general purpose data compression library. + +Copyright (C) 1998,1999,2000 by NOMSSI NZALI Jacques H. C. +[kn&n DES] See "Legal issues" for conditions of distribution and use. +_____________________________________________________________________________ + + +Introduction +============ + +The 'zlib' compression library provides in-memory compression and +decompression functions, including integrity checks of the uncompressed +data. This version of the library supports only one compression method +(deflation) but other algorithms will be added later and will have the same +stream interface. + +Compression can be done in a single step if the buffers are large +enough (for example if an input file is mmap'ed), or can be done by +repeated calls of the compression function. In the latter case, the +application must provide more input and/or consume the output +(providing more output space) before each call. + +The default memory requirements for deflate are 256K plus a few kilobytes +for small objects. The default memory requirements for inflate are 32K +plus a few kilobytes for small objects. + +Change Log +========== + +March 24th 2000 - minizip code by Gilles Vollant ported to Pascal. + z_stream.msg defined as string[255] to avoid problems + with Delphi 2+ dynamic string handling. + changes to silence Delphi 5 compiler warning. If you + have Delphi 5, defines Delphi5 in zconf.inc + +May 7th 1999 - Some changes for FPC + deflateCopy() has new parameters + trees.pas - record constant definition +June 17th 1998 - Applied official 1.1.2 patch. + Memcheck turned off by default. + zutil.pas patch for Delphi 1 memory allocation corrected. + dzlib.txt file added. + compress2() is now exported + +June 25th 1998 - fixed a conversion bug: in inftrees.pas, ZFREE(z, v) was + missing in line 574; + +File list +========= + +Here is a road map to the files in the Paszlib distribution. + +readme.txt Introduction, Documentation +dzlib.txt Changes to Delphi sources for Paszlib stream classes + +include file + +zconf.inc Configuration declarations. + +Pascal source code files: + +adler.pas compute the Adler-32 checksum of a data stream +crc.pas compute the CRC-32 of a data stream +gzio.pas IO on .gz files +infblock.pas interpret and process block types to last block +infcodes.pas process literals and length/distance pairs +inffast.pas process literals and length/distance pairs fast +inftrees.pas generate Huffman trees for efficient decoding +infutil.pas types and macros common to blocks and codes +strutils.pas string utilities +trees.pas output deflated data using Huffman coding +zcompres.pas compress a memory buffer +zdeflate.pas compress data using the deflation algorithm +zinflate.pas zlib interface to inflate modules +zlib.pas zlib data structures. read the comments there! +zuncompr.pas decompress a memory buffer +zutil.pas + +minizip/ziputils.pas data structure and IO on .zip file +minizip/unzip.pas +minizip/zip.pas + +Test applications + +example.pas usage example of the zlib compression library +minigzip.pas simulate gzip using the zlib compression library +minizip/miniunz.pas simulates unzip using the zlib compression library +minizip/minizip.pas simulates zip using the zlib compression library + +Legal issues +============ + +Copyright (C) 1998,1999,2000 by Jacques Nomssi Nzali + + This software is provided 'as-is', without any express or implied + warranty. In no event will the author be held liable for any damages + arising from the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software + in a product, an acknowledgment in the product documentation would be + appreciated but is not required. + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + 3. This notice may not be removed or altered from any source distribution. + + +Archive Locations: +================== + +Check the Paszlib home page with links + + http://www.tu-chemnitz.de/~nomssi/paszlib.html + +The data format used by the zlib library is described by RFCs (Request for +Comments) 1950 to 1952 in the files ftp://ds.internic.net/rfc/rfc1950.txt +(zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format). +These documents are also available in other formats from +ftp://ftp.uu.net/graphics/png/documents/zlib/zdoc-index.html. +____________________________________________________________________________ Jacques Nomssi Nzali March 24th, 2000 \ No newline at end of file diff --git a/UOLib/ULight.pas b/UOLib/ULight.pas index 1a4ffc2..b782405 100644 --- a/UOLib/ULight.pas +++ b/UOLib/ULight.pas @@ -84,7 +84,7 @@ begin color32.A := 255 else color32.A := 0; - PColor32(FGraphic.PixelPointers[x, y])^ := color32.Color; + PColor32(FGraphic.PixelPointer[x, y])^ := color32.Color; end; buffer.Free; end;