diff --git a/Client/CentrED.lpi b/Client/CentrED.lpi index 4efae26..a847023 100644 --- a/Client/CentrED.lpi +++ b/Client/CentrED.lpi @@ -56,7 +56,7 @@ - + @@ -273,6 +273,11 @@ + + + + + diff --git a/Client/CentrED.lpr b/Client/CentrED.lpr index 515bcdb..cca994d 100644 --- a/Client/CentrED.lpr +++ b/Client/CentrED.lpr @@ -40,7 +40,7 @@ uses UfrmLargeScaleCommand, UfrmVirtualLayer, UfrmFilter, UfrmTileInfo, UGUIPlatformUtils, UPlatformTypes, UfrmRegionControl, UPackets, UPacketHandlers, UAdminHandling, UGameResources, ULandscape, UfrmToolWindow, - Logging, UMap, UWorldItem, UStatics, UTiledata; + Logging, UMap, UWorldItem, UStatics, UTiledata, UGLFont; {$IFDEF WINDOWS}{$R CentrED.rc}{$ENDIF} diff --git a/Client/GLFont/DejaVu.fnt b/Client/GLFont/DejaVu.fnt new file mode 100644 index 0000000..dd8bb1f Binary files /dev/null and b/Client/GLFont/DejaVu.fnt differ diff --git a/Client/GLFont/DejaVu.png b/Client/GLFont/DejaVu.png new file mode 100644 index 0000000..8794ac3 Binary files /dev/null and b/Client/GLFont/DejaVu.png differ diff --git a/Client/ResourceList.txt b/Client/ResourceList.txt index cc16b95..42f9920 100644 --- a/Client/ResourceList.txt +++ b/Client/ResourceList.txt @@ -1,3 +1,5 @@ -Overlay/LeftTopArrow.tga -Overlay/TopArrow.tga -Overlay/VirtualLayer.tga +Overlay/LeftTopArrow.tga +Overlay/TopArrow.tga +Overlay/VirtualLayer.tga +GLFont/DejaVu.png +GLFont/DejaVu.fnt diff --git a/Client/UGLFont.pas b/Client/UGLFont.pas new file mode 100644 index 0000000..550b880 --- /dev/null +++ b/Client/UGLFont.pas @@ -0,0 +1,205 @@ +(* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License, Version 1.0 only + * (the "License"). You may not use this file except in compliance + * with the License. + * + * You can obtain a copy of the license at + * http://www.opensource.org/licenses/cddl1.php. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at + * http://www.opensource.org/licenses/cddl1.php. If applicable, + * add the following below this CDDL HEADER, with the fields enclosed + * by brackets "[]" replaced with your own identifying * information: + * Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + * + * + * Portions Copyright 2009 Andreas Schneider + *) +unit UGLFont; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Math, ImagingClasses, ImagingTypes, ImagingOpenGL, GL; + +type + + TFontInfo = packed record + Character: Char; + LeftOffset: SmallInt; + CharWidth: Word; + Width: Word; + Height: Word; + X1: Single; + Y1: Single; + X2: Single; + Y2: Single; + end; + + { TGLFont } + + TGLFont = class + constructor Create; + destructor Destroy; override; + protected + FFontImage: TSingleImage; + FFontTexture: TGLuint; + FSpaceWidth: Word; + FFontInfo: array of TFontInfo; + function FindCharInfo(AChar: Char): Integer; + public + function GetTextHeight(AText: String): Integer; + function GetTextWidth(AText: String): Integer; + procedure DrawText(AX, AY: Integer; AText: String); + procedure LoadImage(AImage: TStream); + procedure LoadFontInfo(AFontInfo: TStream); + procedure UpdateTexture; + end; + +implementation + +uses + Logging; + +{ TGLFont } + + +constructor TGLFont.Create; +begin + FFontTexture := 0; +end; + +destructor TGLFont.Destroy; +begin + FreeAndNil(FFontImage); + if FFontTexture <> 0 then + glDeleteTextures(1, @FFontTexture); + inherited Destroy; +end; + +function TGLFont.FindCharInfo(AChar: Char): Integer; +var + i: Integer; +begin + Result := -1; + i := 0; + while (i < Length(FFontInfo)) and (Result = -1) do + begin + if FFontInfo[i].Character = AChar then + Result := i + else + Inc(i); + end; +end; + +function TGLFont.GetTextHeight(AText: String): Integer; +var + i, charInfo: Integer; +begin + Result := 0; + for i := 1 to Length(AText) do + begin + if AText[i] <> ' ' then + begin + charInfo := FindCharInfo(AText[i]); + if charInfo > -1 then + Result := Max(Result, FFontInfo[charInfo].Height); + end; + end; +end; + +function TGLFont.GetTextWidth(AText: String): Integer; +var + i, charInfo: Integer; +begin + Result := 0; + for i := 1 to Length(AText) do + begin + if AText[i] = ' ' then + Inc(Result, FSpaceWidth) + else + begin + charInfo := FindCharInfo(AText[i]); + if charInfo > -1 then + Result := Result + FFontInfo[charInfo].LeftOffset + + FFontInfo[charInfo].CharWidth; + end; + end; +end; + +procedure TGLFont.DrawText(AX, AY: Integer; AText: String); +var + i, charInfo: Integer; + curX: Integer; + x1, y1, x2, y2: Single; +begin + if FFontTexture = 0 then UpdateTexture; + glBindTexture(GL_TEXTURE_2D, FFontTexture); + + curX := AX; + for i := 1 to Length(AText) do + begin + if AText[i] = ' ' then + Inc(curX, FSpaceWidth) + else + begin + charInfo := FindCharInfo(AText[i]); + if charInfo > -1 then + begin + x1 := FFontInfo[charInfo].X1; + y1 := FFontInfo[charInfo].Y1; + x2 := FFontInfo[charInfo].X2; + y2 := FFontInfo[charInfo].Y2; + + Inc(curX, FFontInfo[charInfo].LeftOffset); + glBegin(GL_QUADS); + glTexCoord2f(x1, y1); glVertex2i(curX, AY); + glTexCoord2f(x2, y1); glVertex2i(curX + FFontInfo[charInfo].Width, AY); + glTexCoord2f(x2, y2); glVertex2i(curX + FFontInfo[charInfo].Width, + AY + FFontInfo[charInfo].Height); + glTexCoord2f(x1, y2); glVertex2i(curX, AY + FFontInfo[charInfo].Height); + glEnd; + Inc(curX, FFontInfo[charInfo].CharWidth); + end; + end; + end; +end; + +procedure TGLFont.LoadImage(AImage: TStream); +begin + FFontImage := TSingleImage.CreateFromStream(AImage); +end; + +procedure TGLFont.LoadFontInfo(AFontInfo: TStream); +begin + AFontInfo.Read(FSpaceWidth, SizeOf(FSpaceWidth)); + SetLength(FFontInfo, (AFontInfo.Size - AFontInfo.Position) div + SizeOf(TFontInfo)); + AFontInfo.Read(FFontInfo[0], Length(FFontInfo) * SizeOf(TFontInfo)); +end; + +procedure TGLFont.UpdateTexture; +begin + Logger.Send('UpdateTexture'); + if FFontTexture <> 0 then glDeleteTextures(1, @FFontTexture); + + FFontTexture := CreateGLTextureFromImage(FFontImage.ImageDataPointer^, 0, 0, + True, ifUnknown); + glBindTexture(GL_TEXTURE_2D, FFontTexture); + glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR); +end; + +end. + diff --git a/Client/ULandscape.pas b/Client/ULandscape.pas index 41e0ee6..3615b22 100644 --- a/Client/ULandscape.pas +++ b/Client/ULandscape.pas @@ -30,11 +30,11 @@ unit ULandscape; interface uses - SysUtils, Classes, math, LCLIntf, GL, GLU, ImagingOpenGL, Imaging, + SysUtils, Classes, math, LCLIntf, GL, GLu, ImagingOpenGL, Imaging, ImagingClasses, ImagingTypes, ImagingUtility, UGenericIndex, UMap, UStatics, UArt, UTexture, UTiledata, UHue, UWorldItem, UMulBlock, - UVector, UEnhancedMemoryStream, + UVector, UEnhancedMemoryStream, UGLFont, UCacheManager; type @@ -196,6 +196,19 @@ type procedure UpdateWriteMap(AStream: TEnhancedMemoryStream); end; + { TGLText } + + TGLText = class + constructor Create(AFont: TGLFont; AText: String); + protected + FFont: TGLFont; + FText: String; + FWidth: Integer; + FHeight: Integer; + public + procedure Render(AScreenRect: TRect); + end; + TScreenState = (ssNormal, ssFiltered, ssGhost); PBlockInfo = ^TBlockInfo; @@ -212,6 +225,7 @@ type HueOverride: Boolean; CheckRealQuad: Boolean; Translucent: Boolean; + Text: TGLText; Next: PBlockInfo; end; @@ -1213,6 +1227,7 @@ begin Result^.State := ssNormal; Result^.Highlighted := False; Result^.Translucent := False; + Result^.Text := nil; Result^.Next := nil; if FShortCuts[0] = nil then //First element @@ -1239,6 +1254,7 @@ begin current^.Item.Locked := False; current^.Item.OnDestroy.UnregisterEvent(@OnTileRemoved); if current^.Normals <> nil then Dispose(current^.Normals); + current^.Text.Free; Dispose(current); current := next; end; @@ -1266,6 +1282,7 @@ begin if last <> nil then last^.Next := current^.Next; if current^.Normals <> nil then Dispose(current^.Normals); + current^.Text.Free; Dispose(current); Dec(FCount); @@ -1356,6 +1373,7 @@ begin Result^.State := ssNormal; Result^.Highlighted := False; Result^.Translucent := False; + Result^.Text := nil; if (FShortCuts[0] = nil) or (CompareWorldItems(AItem, FShortCuts[0]^.Item) < 0) then begin @@ -1490,5 +1508,27 @@ begin Delete(TWorldItem(ATile)); end; +{ TGLText } + +constructor TGLText.Create(AFont: TGLFont; AText: String); +var + i: Integer; +begin + FFont := AFont; + FText := AText; + FWidth := FFont.GetTextWidth(AText); + FHeight := FFont.GetTextHeight('A'); +end; + +procedure TGLText.Render(AScreenRect: TRect); +var + x, y: Integer; + i: Integer; +begin + y := AScreenRect.Top + (AScreenRect.Bottom - AScreenRect.Top - FHeight) div 2; + x := AScreenRect.Left + (AScreenRect.Right - AScreenRect.Left - FWidth) div 2; + FFont.DrawText(x, y, FText); +end; + end. diff --git a/Client/UResourceManager.pas b/Client/UResourceManager.pas index 96c48fc..4c47aa3 100644 --- a/Client/UResourceManager.pas +++ b/Client/UResourceManager.pas @@ -1,106 +1,105 @@ -(* - * CDDL HEADER START - * - * The contents of this file are subject to the terms of the - * Common Development and Distribution License, Version 1.0 only - * (the "License"). You may not use this file except in compliance - * with the License. - * - * You can obtain a copy of the license at - * http://www.opensource.org/licenses/cddl1.php. - * See the License for the specific language governing permissions - * and limitations under the License. - * - * When distributing Covered Code, include this CDDL HEADER in each - * file and include the License file at - * http://www.opensource.org/licenses/cddl1.php. If applicable, - * add the following below this CDDL HEADER, with the fields enclosed - * by brackets "[]" replaced with your own identifying * information: - * Portions Copyright [yyyy] [name of copyright owner] - * - * CDDL HEADER END - * - * - * Portions Copyright 2007 Andreas Schneider - *) -unit UResourceManager; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils; - -type - - { TResourceManager } - - TResourceManager = class(TObject) - constructor Create(AFileName: string); - destructor Destroy; override; - protected - FFileStream: TFileStream; - FCount: Integer; - FLookupTable: array of Cardinal; - FCurrentResource: Integer; - FResourceStream: TMemoryStream; - public - function GetResource(AIndex: Integer): TStream; - end; - -var - ResourceManager: TResourceManager; - -implementation - -{ TResourceManager } - -constructor TResourceManager.Create(AFileName: string); -begin - inherited Create; - FFileStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite); - FFileStream.Position := 0; - FFileStream.Read(FCount, SizeOf(Integer)); - SetLength(FLookupTable, FCount); - FFileStream.Read(FLookupTable[0], FCount * SizeOf(Cardinal)); - FCurrentResource := -1; -end; - -destructor TResourceManager.Destroy; -begin - if FFileStream <> nil then FreeAndNil(FFileStream); - if FResourceStream <> nil then FreeAndNil(FResourceStream); - inherited Destroy; -end; - -function TResourceManager.GetResource(AIndex: Integer): TStream; -var - size: Cardinal; -begin - if AIndex <> FCurrentResource then - begin - FFileStream.Position := FLookupTable[AIndex]; - if FResourceStream <> nil then - FResourceStream.Free; - FResourceStream := TMemoryStream.Create; - FFileStream.Read(size, SizeOf(Cardinal)); - FResourceStream.CopyFrom(FFileStream, size); - FCurrentResource := AIndex; - end; - FResourceStream.Position := 0; - Result := FResourceStream; -end; - -initialization -begin - ResourceManager := TResourceManager.Create(ChangeFileExt(ParamStr(0), '.dat')); -end; - -finalization -begin - if ResourceManager <> nil then FreeAndNil(ResourceManager); -end; - -end. - +(* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License, Version 1.0 only + * (the "License"). You may not use this file except in compliance + * with the License. + * + * You can obtain a copy of the license at + * http://www.opensource.org/licenses/cddl1.php. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at + * http://www.opensource.org/licenses/cddl1.php. If applicable, + * add the following below this CDDL HEADER, with the fields enclosed + * by brackets "[]" replaced with your own identifying * information: + * Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + * + * + * Portions Copyright 2009 Andreas Schneider + *) +unit UResourceManager; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils; + +type + + { TResourceManager } + + TResourceManager = class(TObject) + constructor Create(AFileName: string); + destructor Destroy; override; + protected + FFileStream: TFileStream; + FCount: Integer; + FLookupTable: array of Cardinal; + FCurrentResource: Integer; + FResourceStream: TMemoryStream; + public + function GetResource(AIndex: Integer): TStream; + end; + +var + ResourceManager: TResourceManager; + +implementation + +{ TResourceManager } + +constructor TResourceManager.Create(AFileName: string); +begin + inherited Create; + FFileStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite); + FFileStream.Position := 0; + FFileStream.Read(FCount, SizeOf(Integer)); + SetLength(FLookupTable, FCount); + FFileStream.Read(FLookupTable[0], FCount * SizeOf(Cardinal)); + FCurrentResource := -1; +end; + +destructor TResourceManager.Destroy; +begin + FreeAndNil(FFileStream); + FreeAndNil(FResourceStream); + inherited Destroy; +end; + +function TResourceManager.GetResource(AIndex: Integer): TStream; +var + size: Cardinal; +begin + if AIndex <> FCurrentResource then + begin + FFileStream.Position := FLookupTable[AIndex]; + FResourceStream.Free; + FResourceStream := TMemoryStream.Create; + FFileStream.Read(size, SizeOf(Cardinal)); + FResourceStream.CopyFrom(FFileStream, size); + FCurrentResource := AIndex; + end; + FResourceStream.Position := 0; + Result := FResourceStream; +end; + +initialization +begin + ResourceManager := TResourceManager.Create(ChangeFileExt(ParamStr(0), '.dat')); +end; + +finalization +begin + if ResourceManager <> nil then FreeAndNil(ResourceManager); +end; + +end. + diff --git a/Client/UfrmMain.pas b/Client/UfrmMain.pas index 8427f0a..f8dd161 100644 --- a/Client/UfrmMain.pas +++ b/Client/UfrmMain.pas @@ -31,10 +31,10 @@ interface uses Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Menus, - ComCtrls, OpenGLContext, GL, GLU, UGameResources, ULandscape, ExtCtrls, + ComCtrls, OpenGLContext, GL, GLu, UGameResources, ULandscape, ExtCtrls, StdCtrls, Spin, UEnums, VirtualTrees, Buttons, UMulBlock, UWorldItem, math, LCLIntf, UOverlayUI, UStatics, UEnhancedMemoryStream, ActnList, fgl, - ImagingClasses, dateutils, UPlatformTypes, UMap, UPacket; + ImagingClasses, dateutils, UPlatformTypes, UMap, UPacket, UGLFont; type TAccessChangedListener = procedure(AAccessLevel: TAccessLevel) of object; @@ -269,6 +269,7 @@ type Node: PVirtualNode; Stream: TStream); protected { Members } + FAppDir: String; FX: Integer; FY: Integer; FDrawDistance: Integer; @@ -294,6 +295,7 @@ type FRepaintNeeded: Boolean; FSelection: TRect; FUndoList: TPacketList; + FGLFont: TGLFont; { Methods } procedure BuildTileList; function ConfirmAction: Boolean; @@ -784,6 +786,8 @@ var virtualLayerGraphic: TSingleImage; searchRec: TSearchRec; begin + FAppDir := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)); + FLandscape := ResMan.Landscape; FLandscape.OnChange := @OnLandscapeChanged; FLandscape.OnMapChanged := @OnMapChanged; @@ -812,8 +816,7 @@ begin vstChat.NodeDataSize := SizeOf(TChatInfo); pnlChatHeader.AnchorSide[akBottom].Control := pnlBottom; - FLocationsFile := IncludeTrailingPathDelimiter(ExtractFilePath( - Application.ExeName)) + 'Locations.dat'; + FLocationsFile := FAppDir + 'Locations.dat'; vstLocations.NodeDataSize := SizeOf(TLocationInfo); if FileExists(FLocationsFile) then vstLocations.LoadFromFile(FLocationsFile); @@ -824,11 +827,14 @@ begin virtualLayerGraphic.Height, virtualLayerGraphic); virtualLayerGraphic.Free; + FGLFont := TGLFont.Create; + FGLFont.LoadImage(ResourceManager.GetResource(3)); + FGLFont.LoadFontInfo(ResourceManager.GetResource(4)); + FVirtualTiles := TWorldItemList.Create(True); FUndoList := TPacketList.Create(True); - FRandomPresetLocation := IncludeTrailingPathDelimiter(ExtractFilePath( - Application.ExeName)) + 'RandomPresets' + PathDelim; + FRandomPresetLocation := FAppDir + 'RandomPresets' + PathDelim; if not DirectoryExists(FRandomPresetLocation) then CreateDir(FRandomPresetLocation); @@ -1116,6 +1122,7 @@ begin FreeAndNil(FVLayerMaterial); FreeAndNil(FVirtualTiles); FreeAndNil(FUndoList); + FreeAndNil(FGLFont); RegisterPacketHandler($0C, nil); end; @@ -1783,9 +1790,11 @@ procedure TfrmMain.InitSize; begin glViewport(0, 0, oglGameWindow.Width, oglGameWindow.Height); glMatrixMode(GL_PROJECTION); + glPushMatrix; glLoadIdentity; gluOrtho2D(0, oglGameWindow.Width, oglGameWindow.Height, 0); glMatrixMode(GL_MODELVIEW); + glPushMatrix; glLoadIdentity; end; @@ -1923,6 +1932,10 @@ begin CheckRealQuad := True; end; end; + end else + begin + ABlockInfo^.Text.Free; + ABlockInfo^.Text := TGLText.Create(FGLFont, IntToStr(item.Z)); end; if not ABlockInfo^.CheckRealQuad then @@ -2082,6 +2095,9 @@ begin if highlight then glDisable(GL_COLOR_LOGIC_OP); + + if (blockInfo^.Text <> nil) then + blockInfo^.Text.Render(blockInfo^.ScreenRect); end; FOverlayUI.Draw(oglGameWindow); diff --git a/Imaging/Imaging.pas b/Imaging/Imaging.pas index 7a2bfe4..3d67690 100644 --- a/Imaging/Imaging.pas +++ b/Imaging/Imaging.pas @@ -1,3429 +1,3609 @@ -{ - $Id: Imaging.pas 124 2008-04-21 09:47:07Z 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 90, 180, 270, -90, -180, or -270 degrees counterclockwise. - Only multiples of 90 degrees are allowed.} -function RotateImage(var Image: TImageData; Angle: LongInt): 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; var 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 -{$IFDEF LINK_BITMAP} - ImagingBitmap, -{$ENDIF} -{$IFDEF LINK_JPEG} - ImagingJpeg, -{$ENDIF} -{$IF Defined(LINK_PNG) or Defined(LINK_MNG) or Defined(LINK_JNG)} - ImagingNetworkGraphics, -{$IFEND} -{$IFDEF LINK_GIF} - ImagingGif, -{$ENDIF} -{$IFDEF LINK_DDS} - ImagingDds, -{$ENDIF} -{$IFDEF LINK_TARGA} - ImagingTarga, -{$ENDIF} -{$IFDEF LINK_PNM} - ImagingPortableMaps, -{$ENDIF} -{$IFDEF 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 %d degrees'; - SErrorStretchRect = 'Error while stretching rect from image %s to image %s.'; - -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); - 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); - 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 - WorkImage.Palette := Image.Palette; - 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: LongInt): Boolean; -var - X, Y, BytesPerPixel: LongInt; - RotImage: TImageData; - Pix, RotPix: PByte; - OldFmt: TImageFormat; -begin - Assert(Angle mod 90 = 0); - Result := False; - - if TestImage(Image) then - try - if (Angle < -360) or (Angle > 360) then Angle := Angle mod 360; - if (Angle = 0) or (Abs(Angle) = 360) then - begin - Result := True; - Exit; - end; - - Angle := Iff(Angle = -90, 270, Angle); - Angle := Iff(Angle = -270, 90, Angle); - Angle := Iff(Angle = -180, 180, Angle); - - OldFmt := Image.Format; - if ImageFormatInfos[Image.Format].IsSpecial then - ConvertImage(Image, ifDefault); - - 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; - Image := RotImage; - - 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; var 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) then - begin - Options[OptionId] := Variable; - Result := True; - end; -end; - -function FindImageFileFormatByExt(const Ext: string): TImageFileFormat; -var - I: LongInt; -begin - Result := nil; - for I := 0 to ImageFileFormats.Count - 1 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 := 0 to ImageFileFormats.Count - 1 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.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. - +{ + $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); + var + I, J, XPos: Integer; + PixSrc, PixLeft, PixOldLeft: TColor32Rec; + LineDst: PByteArray; + SrcPtr: PColor32; + begin + SrcPtr := @PByteArray(Src.Bits)[Row * Src.Width * Bpp]; + LineDst := @PByteArray(Dst.Bits)[Row * Dst.Width * Bpp]; + PixOldLeft.Color := 0; + + for I := 0 to Src.Width - 1 do + begin + CopyPixel(SrcPtr, @PixSrc, Bpp); + for J := 0 to Bpp - 1 do + PixLeft.Channels[J] := MulDiv(PixSrc.Channels[J], Weight, 256); + + XPos := I + Offset; + 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]); + CopyPixel(@PixSrc, @LineDst[XPos * Bpp], Bpp); + end; + PixOldLeft := PixLeft; + Inc(PByte(SrcPtr), Bpp); + end; + + XPos := Src.Width + Offset; + if XPos < Dst.Width then + CopyPixel(@PixOldLeft, @LineDst[XPos * Bpp], Bpp); + end; + + procedure YShear(var Src, Dst: TImageData; Col, Offset, Weight, Bpp: Integer); + var + I, J, YPos: Integer; + PixSrc, PixLeft, PixOldLeft: TColor32Rec; + SrcPtr: PByte; + begin + SrcPtr := @PByteArray(Src.Bits)[Col * Bpp]; + PixOldLeft.Color := 0; + + for I := 0 to Src.Height - 1 do + begin + CopyPixel(SrcPtr, @PixSrc, Bpp); + for J := 0 to Bpp - 1 do + PixLeft.Channels[J] := MulDiv(PixSrc.Channels[J], Weight, 256); + + YPos := I + Offset; + 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]); + CopyPixel(@PixSrc, @PByteArray(Dst.Bits)[(YPos * Dst.Width + Col) * Bpp], Bpp); + end; + PixOldLeft := PixLeft; + Inc(SrcPtr, Src.Width * Bpp); + end; + + YPos := Src.Height + Offset; + if YPos < Dst.Height then + CopyPixel(@PixOldLeft, @PByteArray(Dst.Bits)[(YPos * Dst.Width + Col) * Bpp], Bpp); + end; + + procedure Rotate45(var Image: TImageData; Angle: Single); + var + TempImage1, TempImage2: TImageData; + AngleRad, AngleTan, AngleSin, AngleCos, Shear: Single; + I, DstWidth, DstHeight, SrcWidth, SrcHeight, Bpp: Integer; + SrcFmt, TempFormat: TImageFormat; + Info: TImageFormatInfo; + begin + AngleRad := Angle * Pi / 180; + AngleSin := Sin(AngleRad); + AngleCos := Cos(AngleRad); + AngleTan := Sin(AngleRad / 2) / Cos(AngleRad / 2); + SrcWidth := Image.Width; + SrcHeight := Image.Height; + SrcFmt := Image.Format; + + if not (SrcFmt in [ifR8G8B8..ifX8R8G8B8, ifGray8..ifGray32, ifA16Gray16]) then + ConvertImage(Image, ifA8R8G8B8); + + TempFormat := Image.Format; + GetImageFormatInfo(TempFormat, Info); + Bpp := Info.BytesPerPixel; + + // 1st shear (horizontal) + DstWidth := Trunc(SrcWidth + SrcHeight * Abs(AngleTan) + 0.5); + DstHeight := SrcHeight; + NewImage(DstWidth, DstHeight, TempFormat, TempImage1); + + for I := 0 to DstHeight - 1 do + begin + if AngleTan >= 0 then + Shear := (I + 0.5) * AngleTan + else + Shear := (I - DstHeight + 0.5) * AngleTan; + XShear(Image, TempImage1, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp); + end; + + // 2nd shear (vertical) + FreeImage(Image); + DstHeight := Trunc(SrcWidth * Abs(AngleSin) + SrcHeight * AngleCos + 0.5) + 1; + NewImage(DstWidth, DstHeight, TempFormat, TempImage2); + + if AngleSin >= 0 then + Shear := (SrcWidth - 1) * AngleSin + else + Shear := (SrcWidth - DstWidth) * -AngleSin; + + for I := 0 to DstWidth - 1 do + begin + YShear(TempImage1, TempImage2, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp); + Shear := Shear - AngleSin; + end; + + // 3rd shear (horizontal) + FreeImage(TempImage1); + DstWidth := Trunc(SrcHeight * Abs(AngleSin) + SrcWidth * AngleCos + 0.5) + 1; + NewImage(DstWidth, DstHeight, TempFormat, Image); + + if AngleSin >= 0 then + Shear := (SrcWidth - 1) * AngleSin * -AngleTan + else + Shear := ((SrcWidth - 1) * -AngleSin + (1 - DstHeight)) * AngleTan; + + for I := 0 to DstHeight - 1 do + begin + XShear(TempImage2, Image, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp); + Shear := Shear + AngleTan; + end; + + FreeImage(TempImage2); + 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 + 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; + Image := RotImage; + end; + +begin + Result := False; + + 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 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. + diff --git a/Imaging/ImagingBitmap.pas b/Imaging/ImagingBitmap.pas index 37166e6..771a698 100644 --- a/Imaging/ImagingBitmap.pas +++ b/Imaging/ImagingBitmap.pas @@ -1,857 +1,857 @@ -{ - $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. - +{ + $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. + diff --git a/Imaging/ImagingCanvases.pas b/Imaging/ImagingCanvases.pas index 65ed33d..c7c238c 100644 --- a/Imaging/ImagingCanvases.pas +++ b/Imaging/ImagingCanvases.pas @@ -1,1644 +1,2177 @@ -{ - $Id: ImagingCanvases.pas 131 2008-08-14 15:14:24Z 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; - - 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 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); - - { 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); - { 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); - { 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.} - procedure InvertColors; - { Simple single level thresholding with threshold level for each color channel.} - procedure Threshold(Red, Green, Blue: Single); - - { 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; - function GetPixel32(X, Y: LongInt): TColor32; override; - procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override; - public - destructor Destroy; override; - - procedure UpdateCanvasState; 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; -begin - DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); - // Blend the two pixels (Src 'over' Dest alpha composition operation) - DestPix.R := SrcPix.R * SrcPix.A + DestPix.R * DestPix.A * (1.0 - SrcPix.A); - DestPix.G := SrcPix.G * SrcPix.A + DestPix.G * DestPix.A * (1.0 - SrcPix.A); - DestPix.B := SrcPix.B * SrcPix.A + DestPix.B * DestPix.A * (1.0 - SrcPix.A); - DestPix.A := SrcPix.A + DestPix.A * (1.0 - SrcPix.A); - // 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, Ignore: 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; A, B, C: 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; - -{ 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.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.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; - -class function TImagingCanvas.GetSupportedFormats: TImageFormats; -begin - Result := [ifIndex8..Pred(ifDXT1)]; -end; - -{ TFastARGB32Canvas } - -destructor TFastARGB32Canvas.Destroy; -begin - FreeMem(FScanlines); - inherited Destroy; -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.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; - -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.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. - +{ + $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. + diff --git a/Imaging/ImagingClasses.pas b/Imaging/ImagingClasses.pas index 08c9b00..6a49c30 100644 --- a/Imaging/ImagingClasses.pas +++ b/Imaging/ImagingClasses.pas @@ -1,997 +1,997 @@ -{ - $Id: ImagingClasses.pas 124 2008-04-21 09:47:07Z 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 90, 180, 270, -90, -180, or -270 degrees counterclockwise.} - procedure Rotate(Angle: LongInt); - { 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: LongInt); -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. - +{ + $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; {$IF Defined(DCC) and (CompilerVersion >= 20.0)}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: 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. + diff --git a/Imaging/ImagingColors.pas b/Imaging/ImagingColors.pas index 86a6c73..941808b 100644 --- a/Imaging/ImagingColors.pas +++ b/Imaging/ImagingColors.pas @@ -1,204 +1,245 @@ -{ - $Id: ImagingColors.pas 74 2007-03-12 15:04:04Z 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); - -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 > 0 then - begin - C := C - K; - M := M - K; - Y := Y - K; - 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 > 0 then - begin - C := C - K; - M := M - K; - Y := Y - K; - 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; - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 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. +{ + $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. diff --git a/Imaging/ImagingComponents.pas b/Imaging/ImagingComponents.pas index 7e370e3..393ebf5 100644 --- a/Imaging/ImagingComponents.pas +++ b/Imaging/ImagingComponents.pas @@ -1,5 +1,5 @@ { - $Id: ImagingComponents.pas 132 2008-08-27 20:37:38Z galfar $ + $Id: ImagingComponents.pas 171 2009-09-02 01:34:19Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -26,7 +26,7 @@ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } -{ This unit contains VCL/CLX/LCL TGraphic descendant which uses Imaging library +{ This unit contains VCL/LCL TGraphic descendant which uses Imaging library for saving and loading.} unit ImagingComponents; @@ -34,6 +34,17 @@ unit ImagingComponents; 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} @@ -42,10 +53,6 @@ uses {$IFDEF COMPONENT_SET_VCL} Graphics, {$ENDIF} -{$IFDEF COMPONENT_SET_CLX} - Qt, - QGraphics, -{$ENDIF} {$IFDEF COMPONENT_SET_LCL} InterfaceBase, GraphType, @@ -71,6 +78,8 @@ type 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 @@ -114,8 +123,7 @@ type { Returns file extensions of this graphic class.} class function GetFileExtensions: string; override; { Returns default MIME type of this graphic class.} - function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here - //function GetDefaultMimeType: string; override; + function GetMimeType: string; override; {$ENDIF} { Default (the most common) file extension of this graphic class.} property DefaultFileExt: string read FDefaultFileExt; @@ -123,7 +131,7 @@ type TImagingGraphicForSaveClass = class of TImagingGraphicForSave; -{$IFDEF LINK_BITMAP} +{$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 @@ -140,7 +148,7 @@ type end; {$ENDIF} -{$IFDEF LINK_JPEG} +{$IFNDEF DONT_LINK_JPEG} { TImagingGraphic descendant for loading/saving JPEG images.} TImagingJpeg = class(TImagingGraphicForSave) protected @@ -151,8 +159,7 @@ type procedure SaveToStream(Stream: TStream); override; class function GetFileFormat: TImageFileFormat; override; {$IFDEF COMPONENT_SET_LCL} - //function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here - function GetDefaultMimeType: string; override; + function GetMimeType: string; override; {$ENDIF} { See ImagingJpegQuality option for details.} property Quality: LongInt read FQuality write FQuality; @@ -161,7 +168,7 @@ type end; {$ENDIF} -{$IFDEF LINK_PNG} +{$IFNDEF DONT_LINK_PNG} { TImagingGraphic descendant for loading/saving PNG images.} TImagingPNG = class(TImagingGraphicForSave) protected @@ -178,7 +185,7 @@ type end; {$ENDIF} -{$IFDEF LINK_GIF} +{$IFNDEF DONT_LINK_GIF} { TImagingGraphic descendant for loading/saving GIF images.} TImagingGIF = class(TImagingGraphicForSave) public @@ -186,7 +193,7 @@ type end; {$ENDIF} -{$IFDEF LINK_TARGA} +{$IFNDEF DONT_LINK_TARGA} { TImagingGraphic descendant for loading/saving Targa images.} TImagingTarga = class(TImagingGraphicForSave) protected @@ -200,7 +207,7 @@ type end; {$ENDIF} -{$IFDEF LINK_DDS} +{$IFNDEF DONT_LINK_DDS} { Compresssion type used when saving DDS files by TImagingDds.} TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5); @@ -218,7 +225,7 @@ type end; {$ENDIF} -{$IFDEF LINK_MNG} +{$IFNDEF DONT_LINK_MNG} { TImagingGraphic descendant for loading/saving MNG images.} TImagingMNG = class(TImagingGraphicForSave) protected @@ -233,8 +240,7 @@ type procedure SaveToStream(Stream: TStream); override; class function GetFileFormat: TImageFileFormat; override; {$IFDEF COMPONENT_SET_LCL} - //function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here - function GetDefaultMimeType: string; override; + function GetMimeType: string; override; {$ENDIF} { See ImagingMNGLossyCompression option for details.} property LossyCompression: Boolean read FLossyCompression write FLossyCompression; @@ -251,7 +257,7 @@ type end; {$ENDIF} -{$IFDEF LINK_JNG} +{$IFNDEF DONT_LINK_JNG} { TImagingGraphic descendant for loading/saving JNG images.} TImagingJNG = class(TImagingGraphicForSave) protected @@ -328,29 +334,29 @@ procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: T implementation uses -{$IF Defined(UNIX) and Defined(COMPONENT_SET_LCL)} - {$IFDEF LCLGTK2} +{$IF Defined(LCL)} + {$IF Defined(LCLGTK2)} GLib2, GDK2, GTK2, GTKDef, GTKProc, - {$ELSE} + {$ELSEIF Defined(LCLGTK)} GDK, GTK, GTKDef, GTKProc, - {$ENDIF} + {$IFEND} {$IFEND} -{$IFDEF LINK_BITMAP} +{$IFNDEF DONT_LINK_BITMAP} ImagingBitmap, {$ENDIF} -{$IFDEF LINK_JPEG} +{$IFNDEF DONT_LINK_JPEG} ImagingJpeg, {$ENDIF} -{$IFDEF LINK_GIF} +{$IFNDEF DONT_LINK_GIF} ImagingGif, {$ENDIF} -{$IFDEF LINK_TARGA} +{$IFNDEF DONT_LINK_TARGA} ImagingTarga, {$ENDIF} -{$IFDEF LINK_DDS} +{$IFNDEF DONT_LINK_DDS} ImagingDds, {$ENDIF} -{$IF Defined(LINK_PNG) or Defined(LINK_MNG) or Defined(LINK_JNG)} +{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)} ImagingNetworkGraphics, {$IFEND} ImagingUtility; @@ -359,9 +365,10 @@ 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/CLX/LCL.} +{ Registers types to VCL/LCL.} procedure RegisterTypes; var I: LongInt; @@ -387,87 +394,85 @@ var begin for I := Imaging.GetFileFormatCount - 1 downto 0 do RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I)); - {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingGraphic);{$ENDIF} + Classes.RegisterClass(TImagingGraphic); -{$IFDEF LINK_TARGA} +{$IFNDEF DONT_LINK_TARGA} RegisterFileFormat(TImagingTarga); - {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingTarga);{$ENDIF} + Classes.RegisterClass(TImagingTarga); {$ENDIF} -{$IFDEF LINK_DDS} +{$IFNDEF DONT_LINK_DDS} RegisterFileFormat(TImagingDDS); - {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingDDS);{$ENDIF} + Classes.RegisterClass(TImagingDDS); {$ENDIF} -{$IFDEF LINK_JNG} +{$IFNDEF DONT_LINK_JNG} RegisterFileFormat(TImagingJNG); - {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingJNG);{$ENDIF} + Classes.RegisterClass(TImagingJNG); {$ENDIF} -{$IFDEF LINK_MNG} +{$IFNDEF DONT_LINK_MNG} RegisterFileFormat(TImagingMNG); - {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingMNG);{$ENDIF} + Classes.RegisterClass(TImagingMNG); {$ENDIF} -{$IFDEF LINK_GIF} +{$IFNDEF DONT_LINK_GIF} RegisterFileFormat(TImagingGIF); - {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingGIF);{$ENDIF} + Classes.RegisterClass(TImagingGIF); {$ENDIF} -{$IFDEF LINK_PNG} +{$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); - {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingPNG);{$ENDIF} + Classes.RegisterClass(TImagingPNG); {$ENDIF} -{$IFDEF LINK_JPEG} +{$IFNDEF DONT_LINK_JPEG} RegisterFileFormat(TImagingJpeg); - {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingJpeg);{$ENDIF} + Classes.RegisterClass(TImagingJpeg); {$ENDIF} -{$IFDEF LINK_BITMAP} +{$IFNDEF DONT_LINK_BITMAP} RegisterFileFormat(TImagingBitmap); - {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingBitmap);{$ENDIF} + Classes.RegisterClass(TImagingBitmap); {$ENDIF} end; -{ Unregisters types from VCL/CLX/LCL.} +{ Unregisters types from VCL/LCL.} procedure UnRegisterTypes; begin -{$IFDEF LINK_BITMAP} +{$IFNDEF DONT_LINK_BITMAP} TPicture.UnregisterGraphicClass(TImagingBitmap); - {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingBitmap);{$ENDIF} + Classes.UnRegisterClass(TImagingBitmap); {$ENDIF} -{$IFDEF LINK_JPEG} +{$IFNDEF DONT_LINK_JPEG} TPicture.UnregisterGraphicClass(TImagingJpeg); - {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingJpeg);{$ENDIF} + Classes.UnRegisterClass(TImagingJpeg); {$ENDIF} -{$IFDEF LINK_PNG} +{$IFNDEF DONT_LINK_PNG} TPicture.UnregisterGraphicClass(TImagingPNG); - {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingPNG);{$ENDIF} + Classes.UnRegisterClass(TImagingPNG); {$ENDIF} -{$IFDEF LINK_GIF} +{$IFNDEF DONT_LINK_GIF} TPicture.UnregisterGraphicClass(TImagingGIF); - {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingGIF);{$ENDIF} + Classes.UnRegisterClass(TImagingGIF); {$ENDIF} -{$IFDEF LINK_TARGA} +{$IFNDEF DONT_LINK_TARGA} TPicture.UnregisterGraphicClass(TImagingTarga); - {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingTarga);{$ENDIF} + Classes.UnRegisterClass(TImagingTarga); {$ENDIF} -{$IFDEF LINK_DDS} +{$IFNDEF DONT_LINK_DDS} TPicture.UnregisterGraphicClass(TImagingDDS); - {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingDDS);{$ENDIF} + Classes.UnRegisterClass(TImagingDDS); {$ENDIF} TPicture.UnregisterGraphicClass(TImagingGraphic); - {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingGraphic);{$ENDIF} + Classes.UnRegisterClass(TImagingGraphic); end; function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat; begin case Format of -{$IFNDEF COMPONENT_SET_LCL} +{$IFDEF COMPONENT_SET_VCL} ifIndex8: Result := pf8bit; -{$ENDIF} -{$IF (not Defined(COMPONENT_SET_CLX)) and (not Defined(COMPONENT_SET_LCL))} ifR5G6B5: Result := pf16bit; ifR8G8B8: Result := pf24bit; -{$IFEND} +{$ENDIF} ifA8R8G8B8, ifX8R8G8B8: Result := pf32bit; else @@ -479,11 +484,9 @@ function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat; begin case Format of pf8bit: Result := ifIndex8; -{$IFNDEF COMPONENT_SET_CLX} pf15bit: Result := ifA1R5G5B5; pf16bit: Result := ifR5G6B5; pf24bit: Result := ifR8G8B8; -{$ENDIF} pf32bit: Result := ifA8R8G8B8; else Result := ifUnknown; @@ -499,9 +502,6 @@ var {$IFDEF COMPONENT_SET_VCL} LogPalette: TMaxLogPalette; {$ENDIF} -{$IFDEF COMPONENT_SET_CLX} - ColorTable: PPalette32; -{$ENDIF} {$IFDEF COMPONENT_SET_LCL} RawImage: TRawImage; ImgHandle, ImgMaskHandle: HBitmap; @@ -517,19 +517,16 @@ begin if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then Imaging.ConvertImage(WorkData, ifA8R8G8B8) else -{$IFNDEF COMPONENT_SET_LCL} +{$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 -{$ENDIF} -{$IF (not Defined(COMPONENT_SET_CLX)) and (not Defined(COMPONENT_SET_LCL))} - if Info.UsePixelFormat then - Imaging.ConvertImage(WorkData, ifR5G6B5) - else - Imaging.ConvertImage(WorkData, ifR8G8B8); + Imaging.ConvertImage(WorkData, ifR8G8B8); {$ELSE} Imaging.ConvertImage(WorkData, ifA8R8G8B8); -{$IFEND} +{$ENDIF} PF := DataFormatToPixelFormat(WorkData.Format); GetImageFormatInfo(WorkData.Format, Info); @@ -565,27 +562,13 @@ begin // Copy scanlines for I := 0 to WorkData.Height - 1 do Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes); -{$ENDIF} -{$IFDEF COMPONENT_SET_CLX} - Bitmap.Width := WorkData.Width; - Bitmap.Height := WorkData.Height; - Bitmap.PixelFormat := PF; - if (PF = pf8bit) and (WorkData.Palette <> nil) then - begin - // Copy palette - ColorTable := Bitmap.ColorTable; - for I := 0 to Info.PaletteEntries - 1 do - with ColorTable[I] do - begin - R := WorkData.Palette[I].R; - G := WorkData.Palette[I].G; - B := WorkData.Palette[I].B; - end; - 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 @@ -594,9 +577,9 @@ begin begin Width := WorkData.Width; Height := WorkData.Height; - BitsPerPixel := Info.BytesPerPixel * 8; + BitsPerPixel := 32; Format := ricfRGBA; - LineEnd := rileByteBoundary; + LineEnd := rileDWordBoundary; BitOrder := riboBitsInOrder; ByteOrder := riboLSBFirst; LineOrder := riloTopToBottom; @@ -608,14 +591,13 @@ begin RedShift := 16; GreenShift := 8; BlueShift := 0; - Depth := 24; + 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 you get complitation error here upgrade to Lazarus 0.9.24+ } - if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle, False) then + if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle) then begin Bitmap.Handle := ImgHandle; Bitmap.MaskHandle := ImgMaskHandle; @@ -634,9 +616,6 @@ var Colors: Word; LogPalette: TMaxLogPalette; {$ENDIF} -{$IFDEF COMPONENT_SET_CLX} - ColorTable: PPalette32; -{$ENDIF} {$IFDEF COMPONENT_SET_LCL} RawImage: TRawImage; LineLazBytes: LongInt; @@ -650,7 +629,6 @@ begin // trough RawImage api and cannot be changed to mirror some Imaging format // (so formats with no coresponding Imaging format cannot be saved now). - { If you get complitation error here upgrade to Lazarus 0.9.24+ } if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then case RawImage.Description.BitsPerPixel of 8: Format := ifIndex8; @@ -707,28 +685,9 @@ begin for I := 0 to Data.Height - 1 do Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes); {$ENDIF} -{$IFDEF COMPONENT_SET_CLX} - if Format = ifIndex8 then - begin - // Copy palette - ColorTable := Bitmap.ColorTable; - for I := 0 to Info.PaletteEntries - 1 do - with ColorTable[I] do - begin - Data.Palette[I].A := $FF; - Data.Palette[I].R := R; - Data.Palette[I].G := G; - Data.Palette[I].B := B; - 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 // uncommnet for Laz 0.9.25 if you get error here - //if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, Classes.Rect(0, 0, Data.Width, Data.Height)) then + if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then begin LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel, RawImage.Description.LineEnd); @@ -757,6 +716,7 @@ procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: T var OldMode: Integer; BitmapInfo: Windows.TBitmapInfo; + Bmp: TBitmap; begin if TestImage(ImageData) then begin @@ -780,62 +740,45 @@ begin end; try - with SrcRect, ImageData do - Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top, + 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); + 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; end; {$ENDIF} procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); -{$IF Defined(MSWINDOWS) and not Defined(COMPONENT_SET_CLX)} +{$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32 begin DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect); end; -{$ELSEIF Defined(COMPONENT_SET_CLX)} -var - Bitmap: TBitmap; - //Handle: LongWord; -begin - (* - // It would be nice if this worked: - DstCanvas.Start; - Handle := QPainter_handle(DstCanvas.Handle); - {$IFDEF MSWINDOWS} - DisplayImageDataOnDC(Handle, DstRect, ImageData, SrcRect); - {$ELSE} - DisplayImageDataOnX(Handle, DstRect, ImageData, SrcRect); - {$ENDIF} - DstCanvas.Stop; - *) - Bitmap := TBitmap.Create; - try - ConvertDataToBitmap(ImageData, Bitmap); - DstCanvas.CopyRect(DstRect, Bitmap.Canvas, SrcRect); - finally - Bitmap.Free; - end; -end; -{$ELSEIF Defined(UNIX) and Defined(COMPONENT_SET_LCL)} +{$ELSEIF Defined(LCLGTK) or Defined(LCLGTK2)} procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer; ImageData: TImageData); var P: TPoint; begin - // If you get compilation errors here with new Lazarus (rev 14368+) - // uncomment commented code and comment the active code below: - P := TGtkDeviceContext(Dest).Offset; - //P := GetDCOffset(TDeviceContext(Dest)); Inc(DstX, P.X); Inc(DstY, P.Y); gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC, - //gdk_draw_rgb_32_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC, DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE, @PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4); end; @@ -890,6 +833,10 @@ begin end; end; end; +{$ELSE} +begin + raise Exception.Create(SUnsupportedLCLWidgetSet); +end; {$IFEND} procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage); @@ -911,6 +858,12 @@ end; { TImagingGraphic class implementation } +constructor TImagingGraphic.Create; +begin + inherited Create; + PixelFormat := pf24Bit; +end; + procedure TImagingGraphic.LoadFromStream(Stream: TStream); begin ReadDataFromStream(Stream); @@ -1020,14 +973,13 @@ begin Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]); end; -function TImagingGraphicForSave.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here -//function TImagingGraphicForSave.GetDefaultMimeType: string; +function TImagingGraphicForSave.GetMimeType: string; begin Result := 'image/' + FDefaultFileExt; end; {$ENDIF} -{$IFDEF LINK_BITMAP} +{$IFNDEF DONT_LINK_BITMAP} { TImagingBitmap class implementation } @@ -1051,7 +1003,7 @@ begin end; {$ENDIF} -{$IFDEF LINK_JPEG} +{$IFNDEF DONT_LINK_JPEG} { TImagingJpeg class implementation } @@ -1068,8 +1020,7 @@ begin end; {$IFDEF COMPONENT_SET_LCL} -//function TImagingJpeg.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here -function TImagingJpeg.GetDefaultMimeType: string; +function TImagingJpeg.GetMimeType: string; begin Result := 'image/jpeg'; end; @@ -1086,7 +1037,7 @@ end; {$ENDIF} -{$IFDEF LINK_PNG} +{$IFNDEF DONT_LINK_PNG} { TImagingPNG class implementation } @@ -1112,7 +1063,7 @@ begin end; {$ENDIF} -{$IFDEF LINK_GIF} +{$IFNDEF DONT_LINK_GIF} { TImagingGIF class implementation} @@ -1123,7 +1074,7 @@ end; {$ENDIF} -{$IFDEF LINK_TARGA} +{$IFNDEF DONT_LINK_TARGA} { TImagingTarga class implementation } @@ -1147,7 +1098,7 @@ begin end; {$ENDIF} -{$IFDEF LINK_DDS} +{$IFNDEF DONT_LINK_DDS} { TImagingDDS class implementation } @@ -1180,7 +1131,7 @@ begin end; {$ENDIF} -{$IFDEF LINK_MNG} +{$IFNDEF DONT_LINK_MNG} { TImagingMNG class implementation } @@ -1201,8 +1152,7 @@ begin end; {$IFDEF COMPONENT_SET_LCL} -//function TImagingMNG.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here -function TImagingMNG.GetDefaultMimeType: string; +function TImagingMNG.GetMimeType: string; begin Result := 'video/mng'; end; @@ -1222,7 +1172,7 @@ begin end; {$ENDIF} -{$IFDEF LINK_JNG} +{$IFNDEF DONT_LINK_JNG} { TImagingJNG class implementation } @@ -1259,12 +1209,30 @@ initialization 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. diff --git a/Imaging/ImagingDds.pas b/Imaging/ImagingDds.pas index 0b439a9..08090d7 100644 --- a/Imaging/ImagingDds.pas +++ b/Imaging/ImagingDds.pas @@ -1,864 +1,864 @@ -{ - $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. - +{ + $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. + diff --git a/Imaging/ImagingExport.pas b/Imaging/ImagingExport.pas index 9b212a7..daf5bf7 100644 --- a/Imaging/ImagingExport.pas +++ b/Imaging/ImagingExport.pas @@ -1,887 +1,891 @@ -{ - $Id: ImagingExport.pas 71 2007-03-08 00:10: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 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: PChar): Boolean; cdecl; -{ Look at DetermineMemoryFormat for details. Ext should have enough space for - result file extension.} -function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PChar): Boolean; cdecl; -{ Look at IsFileFormatSupported for details.} -function ImIsFileFormatSupported(FileName: PChar): Boolean; cdecl; -{ Look at EnumFileFormats for details.} -function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PChar; - 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: PChar; 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: PChar; 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: PChar; const Image: TImageData): Boolean; cdecl; -{ Look at SaveImageToMemory for details.} -function ImSaveImageToMemory(Ext: PChar; Data: Pointer; var Size: LongInt; - const Image: TImageData): Boolean; cdecl; -{ Look at SaveMultiImageToFile for details.} -function ImSaveMultiImageToFile(FileName: PChar; ImageList: TImageDataList): Boolean; cdecl; -{ Look at SaveMultiImageToMemory for details.} -function ImSaveMultiImageToMemory(Ext: PChar; 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: LongInt): 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: PChar): Boolean; -var - S: string; -begin - try - S := Imaging.DetermineFileFormat(FileName); - Result := S <> ''; - StrCopy(Ext, PChar(S)); - except - Result := False; - end; -end; - -function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PChar): Boolean; -var - S: string; -begin - try - S := Imaging.DetermineMemoryFormat(Data, Size); - Result := S <> ''; - StrCopy(Ext, PChar(S)); - except - Result := False; - end; -end; - -function ImIsFileFormatSupported(FileName: PChar): Boolean; -begin - try - Result := Imaging.IsFileFormatSupported(FileName); - except - Result := False; - end; -end; - -function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PChar; - var CanSave, IsMultiImageFormat: Boolean): Boolean; -var - StrName, StrDefaultExt, StrMasks: string; -begin - try - Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave, - IsMultiImageFormat); - StrCopy(Name, PChar(StrName)); - StrCopy(DefaultExt, PChar(StrDefaultExt)); - StrCopy(Masks, PChar(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: PChar; 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: PChar; 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: PChar; const Image: TImageData): Boolean; -begin - try - Result := Imaging.SaveImageToFile(FileName, Image); - except - Result := False; - end; -end; - -function ImSaveImageToMemory(Ext: PChar; 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: PChar; - ImageList: TImageDataList): Boolean; -begin - try - Result := Imaging.SaveMultiImageToFile(FileName, - PInternalList(ImageList).List); - except - Result := False; - end; -end; - -function ImSaveMultiImageToMemory(Ext: PChar; 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: LongInt): 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.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. - +{ + $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 6c972fe..d3e52f7 100644 --- a/Imaging/ImagingFormats.pas +++ b/Imaging/ImagingFormats.pas @@ -1,4287 +1,4288 @@ -{ - $Id: ImagingFormats.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 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; - 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; -var - MapX, MapY: TMappingTable; - I, J, X, Y: LongInt; - XMinimum, XMaximum: LongInt; - LineBuffer: array of TColorFPRec; - ClusterX, ClusterY: TCluster; - Weight, AccumA, AccumR, AccumG, AccumB: Single; - 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); - SetLength(LineBuffer, XMaximum - XMinimum + 1); - - if not UseOptimizedVersion then - begin - // 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.0; - AccumR := 0.0; - AccumG := 0.0; - AccumB := 0.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 LineBuffer[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.0; - AccumR := 0.0; - AccumG := 0.0; - AccumB := 0.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 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; - - // 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 - // 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 - 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; - CopyPixel( - @PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel], - @SrcColor, Info.BytesPerPixel); - - AccumB := AccumB + SrcColor.B * Weight; - if Info.ChannelCount > 1 then - AccumG := AccumG + SrcColor.G * Weight; - if Info.ChannelCount > 2 then - AccumR := AccumR + SrcColor.R * Weight; - if Info.ChannelCount > 3 then - AccumA := AccumA + SrcColor.A * Weight; - end; - with LineBuffer[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]; - - for I := 0 to DstWidth - 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; - if Info.ChannelCount > 1 then - AccumG := AccumG + G * Weight; - if Info.ChannelCount > 2 then - AccumR := AccumR + R * Weight; - if Info.ChannelCount > 3 then - AccumA := AccumA + A * Weight; - end; - end; - SrcColor.B := ClampToByte(Round(AccumB)); - if Info.ChannelCount > 1 then - SrcColor.G := ClampToByte(Round(AccumG)); - if Info.ChannelCount > 2 then - SrcColor.R := ClampToByte(Round(AccumR)); - if Info.ChannelCount > 3 then - SrcColor.A := ClampToByte(Round(AccumA)); - - 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) shl 4) or (Pixels[I shl 1 + 1].Alpha shr 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 - - rewrite StretchRect for 8bit channels to use integer math? - - -- 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. - +{ + $Id: ImagingFormats.pas 176 2009-10-12 10:53:17Z 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. + diff --git a/Imaging/ImagingGif.pas b/Imaging/ImagingGif.pas index 013fd67..7fe42e9 100644 --- a/Imaging/ImagingGif.pas +++ b/Imaging/ImagingGif.pas @@ -1,1030 +1,1239 @@ -{ - $Id: ImagingGif.pas 132 2008-08-27 20:37:38Z 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.} - TGIFFileFormat = class(TImageFileFormat) - private - 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; - end; - -implementation - -const - SGIFFormatName = 'Graphics Interchange Format'; - SGIFMasks = '*.gif'; - GIFSupportedFormats: TImageFormats = [ifIndex8]; - -type - TGIFVersion = (gv87, gv89); - TDisposalMethod = (dmUndefined, 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 - 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; - - AddMasks(SGIFMasks); -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; -var - Header: TGIFHeader; - HasGlobalPal: Boolean; - GlobalPalLength: Integer; - GlobalPal: TPalette32Size256; - I: Integer; - BlockID: Byte; - HasGraphicExt: Boolean; - GraphicExt: TGraphicControlExtension; - Disposals: array of TDisposalMethod; - - function ReadBlockID: Byte; - begin - Result := GIFTrailer; - GetIO.Read(Handle, @Result, SizeOf(Result)); - end; - - procedure ReadExtensions; - var - BlockSize, ExtType: Byte; - begin - HasGraphicExt := 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)); - - if ExtType = GIFGraphicControlExtension then - begin - HasGraphicExt := True; - Read(Handle, @GraphicExt, SizeOf(GraphicExt)); - 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; - end; - end; - - procedure CopyFrameTransparent(const Image, Frame: TImageData; Left, Top, - TransIndex: Integer; Disposal: TDisposalMethod); - var - X, Y: Integer; - Src, Dst: PByte; - 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 := @PByteArray(Image.Bits)[(Top + Y) * Image.Width + Left]; - for X := 0 to Frame.Width - 1 do - begin - // If disposal methos is undefined copy all pixels regardless of - // transparency (transparency of whole image will be determined by TranspIndex - // in image palette) - same effect as filling the image with trasp color - // instead of backround color beforehand. - // For other methods don't copy transparent pixels from frame to image. - if (Src^ <> TransIndex) or (Disposal = dmUndefined) then - Dst^ := Src^; - Inc(Src); - Inc(Dst); - 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; - HasLocalPal, Interlaced, HasTransparency: Boolean; - I, Idx, LocalPalLength, TransIndex: Integer; - LocalPal: TPalette32Size256; - BlockTerm: Byte; - Frame: TImageData; - LZWStream: TMemoryStream; - begin - Idx := Length(Images); - SetLength(Images, Idx + 1); - FillChar(LocalPal, SizeOf(LocalPal), 0); - with GetIO do - begin - // Read and parse image descriptor - Read(Handle, @ImageDesc, SizeOf(ImageDesc)); - 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) - - // Create new logical screen - NewImage(Header.ScreenWidth, Header.ScreenHeight, ifIndex8, Images[Idx]); - // Create new image for this frame which would be later pasted onto logical screen - InitImage(Frame); - NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Frame); - - // Load local palette if there is any - if 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 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); - - // Add default disposal method for this frame - SetLength(Disposals, Length(Disposals) + 1); - Disposals[High(Disposals)] := dmUndefined; - - // If Grahic Control Extension is present make use of it - if HasGraphicExt then - begin - HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent; - Disposals[High(Disposals)] := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2); - if HasTransparency then - Images[Idx].Palette[GraphicExt.TransparentColorIndex].A := 0; - end - else - HasTransparency := False; - - if Idx >= 1 then - begin - // If previous frame had some special disposal method we take it into - // account now - case Disposals[Idx - 1] of - dmUndefined: ; // Do nothing - dmLeave: - begin - // Leave previous frame on log screen - CopyRect(Images[Idx - 1], 0, 0, Images[Idx].Width, - Images[Idx].Height, Images[Idx], 0, 0); - end; - dmRestoreBackground: - begin - // Clear log screen with background color - FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height, - @Header.BackgroundColorIndex); - end; - dmRestorePrevious: - if Idx >= 2 then - begin - // Set log screen to "previous of previous" frame - CopyRect(Images[Idx - 2], 0, 0, Images[Idx].Width, - Images[Idx].Height, Images[Idx], 0, 0); - end; - end; - end - else - begin - // First frame - just fill with background color - FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height, - @Header.BackgroundColorIndex); - end; - - LZWStream := TMemoryStream.Create; - 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, Frame.Bits); - // Now copy frame to logical screen with skipping of transparent pixels (if enabled) - TransIndex := Iff(HasTransparency, GraphicExt.TransparentColorIndex, MaxInt); - CopyFrameTransparent(Images[Idx], Frame, ImageDesc.Left, ImageDesc.Top, - TransIndex, Disposals[Idx]); - finally - FreeImage(Frame); - LZWStream.Free; - end; - end; - end; - -begin - SetLength(Images, 0); - FillChar(GlobalPal, SizeOf(GlobalPal), 0); - with GetIO do - begin - // Read GIF header - Read(Handle, @Header, SizeOf(Header)); - 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 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; - - 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.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. +{ + $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. diff --git a/Imaging/ImagingIO.pas b/Imaging/ImagingIO.pas index e598091..04c0256 100644 --- a/Imaging/ImagingIO.pas +++ b/Imaging/ImagingIO.pas @@ -1,574 +1,574 @@ -{ - $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. - +{ + $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. + diff --git a/Imaging/ImagingJpeg.pas b/Imaging/ImagingJpeg.pas index cd83743..cbd708d 100644 --- a/Imaging/ImagingJpeg.pas +++ b/Imaging/ImagingJpeg.pas @@ -1,590 +1,606 @@ -{ - $Id: ImagingJpeg.pas 128 2008-07-23 11:57:36Z 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.} - -{$IFDEF LCL} - {$UNDEF IMJPEGLIB} - {$DEFINE PASJPEG} -{$ENDIF} - -interface - -uses - SysUtils, ImagingTypes, Imaging, ImagingColors, -{$IF Defined(IMJPEGLIB)} - imjpeglib, imjmorecfg, imjcomapi, imjdapimin, - imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam, -{$ELSEIF Defined(PASJPEG)} - jpeglib, jmorecfg, jcomapi, jdapimin, - 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.} - 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; - JFIFSignature: TChar4 = 'JFIF'; - EXIFSignature: TChar4 = 'Exif'; - BufferSize = 16384; - -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; - - -{ Intenal unit jpeglib support functions } - -procedure JpegError(CurInfo: j_common_ptr); -begin -end; - -procedure EmitMessage(CurInfo: j_common_ptr; msg_level: Integer); -begin -end; - -procedure OutputMessage(CurInfo: j_common_ptr); -begin -end; - -procedure FormatMessage(CurInfo: j_common_ptr; var buffer: string); -begin -end; - -procedure ResetErrorMgr(CurInfo: j_common_ptr); -begin - CurInfo^.err^.num_warnings := 0; - CurInfo^.err^.msg_code := 0; -end; - -var - JpegErrorRec: jpeg_error_mgr = ( - error_exit: JpegError; - emit_message: EmitMessage; - output_message: OutputMessage; - format_message: FormatMessage; - reset_error_mgr: ResetErrorMgr); - -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); - jc.common.err := @JpegErrorRec; - 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); - jc.common.err := @JpegErrorRec; - jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c)); - JpegStdioDest(jc.c, Handle); - jpeg_set_defaults(@jc.c); - jpeg_set_quality(@jc.c, Saver.FQuality, True); - if Saver.FGrayScale then - jpeg_set_colorspace(@jc.c, JCS_GRAYSCALE) - else - jpeg_set_colorspace(@jc.c, JCS_YCbCr); - 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 - 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; - 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 Char; -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.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. - +{ + $Id: ImagingJpeg.pas 180 2009-10-16 01:07:26Z 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_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 } + +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; + NeedsRedBlueSwap: Boolean; + Pix: PColor24Rec; +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; + + // 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} + + 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; + + 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.5 Changes/Bug Fixes --------------------------------- + - Fixed swapped Red-Blue order when loading Jpegs with + jc.d.jpeg_color_space = JCS_RGB. + + -- 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. + diff --git a/Imaging/ImagingNetworkGraphics.pas b/Imaging/ImagingNetworkGraphics.pas index a83dcd9..5b7dc02 100644 --- a/Imaging/ImagingNetworkGraphics.pas +++ b/Imaging/ImagingNetworkGraphics.pas @@ -1,2166 +1,2573 @@ -{ - $Id: ImagingNetworkGraphics.pas 122 2008-03-14 14:05: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 loaders/savers for Network Graphics image - file formats PNG, MNG, and JNG.} -unit ImagingNetworkGraphics; - -interface - -{$I ImagingOptions.inc} - -uses - 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) - 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; - -{$IFDEF 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} - -{$IFDEF 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 - -{$IFDEF LINK_JNG} -uses - ImagingJpeg, ImagingIO; -{$ENDIF} - -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]; - - 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.} - 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.} - 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 mMNG features are used in this file - end; - PMHDR = ^TMHDR; - - { JHDR chunk format.} - 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; - -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'; - - { 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 - IsJNG: Boolean; - IHDR: TIHDR; - JHDR: TJHDR; - Palette: PPalette24; - PaletteEntries: LongInt; - Transparency: Pointer; - TransparencySize: LongInt; - Background: Pointer; - BackgroundSize: LongInt; - IDATMemory: TMemoryStream; - JDATMemory: TMemoryStream; - JDAAMemory: TMemoryStream; - constructor Create; - destructor Destroy; override; - end; - - { Defines type of Network Graphics file.} - TNGFileType = (ngPNG, ngMNG, ngJNG); - - TNGFileHandler = class(TObject) - public - FileType: TNGFileType; - Frames: array of TFrameInfo; - MHDR: TMHDR; - 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(const IHDR: TIHDR; IDATStream: TMemoryStream; var Image: TImageData); -{$IFDEF LINK_JNG} - procedure LoadImageFromJNGFrame(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; IsJNG: Boolean); - procedure StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer; FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream); -{$IFDEF LINK_JNG} - procedure StoreImageToJNGFrame(const JHDR: TJHDR; const Image: TImageData; IDATStream, JDATStream, JDAAStream: TMemoryStream); -{$ENDIF} - procedure SetFileOptions(FileFormat: TNetworkGraphicsFileFormat); - end; - -{$IFDEF LINK_JNG} - TCustomIOJpegFileFormat = class(TJpegFileFormat) - protected - FCustomIO: TIOFunctions; - procedure SetJpegIO(const JpegIO: TIOFunctions); override; - procedure SetCustomIO(const CustomIO: TIOFunctions); - end; -{$ENDIF} - -{ 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; - -{$IFDEF 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; - -{ 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; - Frame := AddFrameInfo; - Frame.IsJNG := False; - Frame.IHDR := PIHDR(ChunkData)^; - end; - - procedure StartNewJNGImage; - var - Frame: TFrameInfo; - begin - ReadChunkData; - Frame := AddFrameInfo; - Frame.IsJNG := True; - Frame.JHDR := PJHDR(ChunkData)^; - end; - - procedure AppendIDAT; - begin - ReadChunkData; - // Append current IDAT chunk to storage stream - GetLastFrame.IDATMemory.Write(ChunkData^, Chunk.DataSize); - 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; - -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 - else - FillChar(MHDR, SizeOf(MHDR), 0); - - // Read chunks until ending chunk or EOF is reached - repeat - ReadChunk; - if Chunk.ChunkID = IHDRChunk then StartNewPNGImage - else if Chunk.ChunkID = JHDRChunk then StartNewJNGImage - else if Chunk.ChunkID = IDATChunk 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 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(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 := SwapEndianLongWord(IHDR.Width); - Image.Height := SwapEndianLongWord(IHDR.Height); - 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; - -{$IFDEF LINK_JNG} - -procedure TNGFileLoader.LoadImageFromJNGFrame(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(JHDR.Width, JHDR.Height, 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(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.IsJNG) 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.IsJNG) 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.IsJNG and (Frame.JHDR.ColorType in [10, 14])) or - (not Frame.IsJNG 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; - -{$IFDEF 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; IsJNG: 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.IsJNG := IsJNG; - - with Frame do - begin - GetImageFormatInfo(Image.Format, FmtInfo); - - if IsJNG then - begin -{$IFDEF 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 - 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; - - // 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; - - 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; - -begin - Result := False; - begin - case FileType of - ngPNG: 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 IsJNG 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 - 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; - // 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; - end; - - if FileType = ngMNG then - begin - Chunk.DataSize := 0; - Chunk.ChunkID := MENDChunk; - WriteChunk(Chunk, nil); - end; - end; -end; - -procedure TNGFileSaver.SetFileOptions(FileFormat: TNetworkGraphicsFileFormat); -begin - PreFilter := FileFormat.FPreFilter; - CompressLevel := FileFormat.FCompressLevel; - LossyAlpha := FileFormat.FLossyAlpha; - Quality := FileFormat.FQuality; - Progressive := FileFormat.FProgressive; -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; - AddMasks(SPNGMasks); - - FSignature := PNGSignature; - - RegisterOption(ImagingPNGPreFilter, @FPreFilter); - RegisterOption(ImagingPNGCompressLevel, @FCompressLevel); -end; - -function TPNGFileFormat.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 not IsJNG then - NGFileLoader.LoadImageFromPNGFrame(IHDR, IDATMemory, 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 TPNGFileFormat.SaveData(Handle: TImagingHandle; - const Images: TDynImageDataArray; Index: LongInt): Boolean; -var - ImageToSave: TImageData; - MustBeFreed: Boolean; - NGFileSaver: TNGFileSaver; -begin - // Make image PNG 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 := ngPNG; - SetFileOptions(Self); - AddFrame(ImageToSave, False); - SaveFile(Handle); - finally - // Free NG saver and compatible image - NGFileSaver.Free; - if MustBeFreed then - FreeImage(ImageToSave); - end; - end; -end; - -{$IFDEF 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 IsJNG then - NGFileLoader.LoadImageFromJNGFrame(JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[I]) - else - NGFileLoader.LoadImageFromPNGFrame(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); - with NGFileLoader.MHDR do - NewImage(FrameWidth, 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} - -{$IFDEF 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 IsJNG then - NGFileLoader.LoadImageFromJNGFrame(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); -{$IFDEF LINK_MNG} - RegisterImageFileFormat(TMNGFileFormat); -{$ENDIF} -{$IFDEF LINK_JNG} - RegisterImageFileFormat(TJNGFileFormat); -{$ENDIF} -finalization - -{ - File Notes: - - -- TODOS ---------------------------------------------------- - - nothing now - - -- 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. +{ + $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. diff --git a/Imaging/ImagingOpenGL.pas b/Imaging/ImagingOpenGL.pas index ac2af20..2df1fb9 100644 --- a/Imaging/ImagingOpenGL.pas +++ b/Imaging/ImagingOpenGL.pas @@ -1,917 +1,927 @@ -{ - $Id: ImagingOpenGL.pas 128 2008-07-23 11:57:36Z 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} - -interface - -uses - SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats, -{$IFDEF USE_DGL_HEADERS} - dglOpenGL, -{$ELSE} - gl, glext, -{$ENDIF} - 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; - -{$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.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. +{ + $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. diff --git a/Imaging/ImagingOptions.inc b/Imaging/ImagingOptions.inc index 2c18fc8..13342b1 100644 --- a/Imaging/ImagingOptions.inc +++ b/Imaging/ImagingOptions.inc @@ -1,235 +1,201 @@ -{ $Id: ImagingOptions.inc 132 2008-08-27 20:37:38Z 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} // if defined, assembler versions of some - // functions will be used (only for x86) -{ $DEFINE DEBUG} // if defined, debug info, range/IO/overflow - // checking, stack frames, assertions, and - // other debugging options will be turned on - -{ File format support linking options. Undefine formats which you don't want - to be registred automatically. } - -{.$DEFINE LINK_JPEG} // link support for Jpeg images -{.$DEFINE LINK_PNG} // link support for PNG images -{$DEFINE LINK_TARGA} // link support for Targa images -{$DEFINE LINK_BITMAP} // link support for Windows Bitmap images -{.$DEFINE LINK_DDS} // link support for DDS images -{.$DEFINE LINK_GIF} // link support for GIF images -{.$DEFINE LINK_MNG} // link support for MNG images -{.$DEFINE LINK_JNG} // link support for JNG images -{.$DEFINE LINK_PNM} // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM) - -{.$DEFINE 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 (only exception is using CLX in Delphi 6/7). } - -{$DEFINE COMPONENT_SET_VCL} // use Borland's VCL -{ $DEFINE COMPONENT_SET_CLX} // use Borland's CLX (set automatically when using Kylix, - // must be se manually when compiling with Delphi 6/7) -{ $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(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} - -{$IFDEF 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} -{$ELSE} - {$ASSERTIONS OFF} - {$DEBUGINFO OFF} - {$RANGECHECKS OFF} - {$IOCHECKS OFF} - {$OVERFLOWCHECKS OFF} - {$IFDEF DCC} - {$OPTIMIZATION ON} - {$STACKFRAMES OFF} - {$LOCALSYMBOLS OFF} - {$ENDIF} - {$IFDEF FPC} - {$S-} - {$ENDIF} -{$ENDIF} - -{ 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(DCC) and (CompilerVersion >= 17)) or (Defined(FPC) and Defined(CPU86))} - {$DEFINE HAS_INLINE} -{$IFEND} - -// Define if compiler supports advanced records with methods -{$IF (Defined(DCC) and (CompilerVersion >= 18)) } - {$DEFINE HAS_ADVANCED_RECORDS} -{$IFEND} - -// Define if compiler supports operator overloading -// (unfortunately Delphi and FPC operator overloaing is not compatible) -{$IF (Defined(DCC) and (CompilerVersion >= 18)) or 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} - {$UNDEF COMPONENT_SET_CLX} -{$ENDIF} - -{$IFDEF KYLIX} - {$DEFINE COMPONENT_SET_CLX} - {$UNDEF COMPONENT_SET_VCL} - {$UNDEF COMPONENT_SET_LCL} -{$ENDIF} - -{$IFDEF DELPHI} - {$UNDEF COMPONENT_SET_LCL} - {$IF CompilerVersion >= 17} - {$UNDEF COMPONENT_SET_CLX} // Delphi 9+ has no CLX - {$IFEND} - {$IFNDEF COMPONENT_SET_VCL} - {$IFNDEF COMPONENT_SET_CLX} - {$DEFINE COMPONENT_SET_VCL} // use VCL as default if not set - {$ENDIF} - {$ENDIF} -{$ENDIF} - -{$IFDEF COMPONENT_SET_VCL} - {$UNDEF COMPONENT_SET_CLX} - {$UNDEF COMPONENT_SET_LCL} -{$ENDIF} - -{$IFDEF COMPONENT_SET_CLX} - {$UNDEF COMPONENT_SET_VCL} - {$UNDEF COMPONENT_SET_LCL} -{$ENDIF} - -{$IFDEF COMPONENT_SET_LCL} - {$UNDEF COMPONENT_SET_VCL} - {$UNDEF COMPONENT_SET_CLX} -{$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} - -{ Extension dependencies check } - -{$IFDEF LINK_MNG} // MNG uses internaly both PNG and JNG - {$DEFINE LINK_JNG} - {$DEFINE LINK_PNG} -{$ENDIF} - -{$IFDEF LINK_JNG} // JNG uses internaly both PNG and JPEG - {$DEFINE LINK_PNG} - {$DEFINE LINK_JPEG} -{$ENDIF} - - +{ $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(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} + + +{ 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(DCC) and (CompilerVersion >= 17)) or (Defined(FPC) and Defined(CPU86))} + {$DEFINE HAS_INLINE} +{$IFEND} + +// Define if compiler supports advanced records with methods +{$IF (Defined(DCC) and (CompilerVersion >= 18)) } + {$DEFINE HAS_ADVANCED_RECORDS} +{$IFEND} + +// Define if compiler supports operator overloading +// (unfortunately Delphi and FPC operator overloaing is not compatible) +{$IF (Defined(DCC) and (CompilerVersion >= 18)) or 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} + + diff --git a/Imaging/ImagingPortableMaps.pas b/Imaging/ImagingPortableMaps.pas index 871e2c4..570261c 100644 --- a/Imaging/ImagingPortableMaps.pas +++ b/Imaging/ImagingPortableMaps.pas @@ -1,1003 +1,1020 @@ -{ - $Id: ImagingPortableMaps.pas 127 2008-05-31 01:57:13Z 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: Char; - 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 Char; - 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: Char; - 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 := S; - end; - - function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} - begin - Result := StrToInt(ReadString); - end; - - procedure FindLineBreak; - var - C: Char; - 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; - GetIO.Write(Handle, @S[1], Length(S)); - 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); - MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], 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); - MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], 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; - MapInfo.FormatId := Iff(MapInfo.TupleType = ttGrayScaleFP, FIdNumbers[1], 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.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. +{ + $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. diff --git a/Imaging/ImagingTarga.pas b/Imaging/ImagingTarga.pas index b9c8bf3..fedc8b8 100644 --- a/Imaging/ImagingTarga.pas +++ b/Imaging/ImagingTarga.pas @@ -1,623 +1,623 @@ -{ - $Id: ImagingTarga.pas 84 2007-05-27 13:54:27Z 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: array[0..15] of Char; // 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. - +{ + $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. + diff --git a/Imaging/ImagingTypes.pas b/Imaging/ImagingTypes.pas index 31f6c07..abdcdc8 100644 --- a/Imaging/ImagingTypes.pas +++ b/Imaging/ImagingTypes.pas @@ -1,493 +1,499 @@ -{ - $Id: ImagingTypes.pas 132 2008-08-27 20:37:38Z 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 = 0; - - { 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; - - { 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.} - 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. +{ + $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. diff --git a/Imaging/ImagingUtility.pas b/Imaging/ImagingUtility.pas index ace59c6..a023a2a 100644 --- a/Imaging/ImagingUtility.pas +++ b/Imaging/ImagingUtility.pas @@ -1,5 +1,5 @@ { - $Id: ImagingUtility.pas 128 2008-07-23 11:57:36Z galfar $ + $Id: ImagingUtility.pas 175 2009-10-06 11:55:15Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -56,9 +56,10 @@ type 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); @@ -98,23 +99,24 @@ type end; PFloatHelper = ^TFloatHelper; - TChar2 = array[0..1] of Char; - TChar3 = array[0..2] of Char; - TChar4 = array[0..3] of Char; - TChar8 = array[0..7] of Char; + 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: - flFullNames - file names in result will have full path names - (ExtractFileDir(Path) + FileName) - flRelNames - file names in result will have names relative to - ExtractFileDir(Path) dir - flRecursive - adds files in subdirectories found in Path.} - TFileListOption = (flFullNames, flRelNames, flRecursive); - TFileListOptions = set of TFileListOption; + flFullNames - file names in result will have full path names + (ExtractFileDir(Path) + FileName) + flRelNames - file names in result will have names relative to + ExtractFileDir(Path) dir + 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); +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 @@ -135,32 +137,35 @@ function GetAppExe: string; path delimiter at the end.} function GetAppDir: string; { Returns True if FileName matches given Mask with optional case sensitivity. - Mask can contain ? and * special characters: ? matches - one character, * matches zero or more characters.} + 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 - 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 - - BuildFileList('d:\*.*', faDirectory, List, [flFullNames]) returns - list of all directories (d:\dirxxx) in root of D drive.} -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 } -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} -{ Returns a sub-string from S which is followed by - Sep separator and deletes the sub-string from S including the separator.} -function StrToken(var S: string; Sep: Char): string; -{ Same as StrToken but searches from the end of S string.} -function StrTokenEnd(var S: string; Sep: Char): string; -{ Returns string representation of integer number (with digit grouping).} -function IntToStrFmt(const I: Int64): string; -{ Returns string representation of float number (with digit grouping).} -function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; - + 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 + - BuildFileList('d:\*.*', faDirectory, List, [flFullNames]) returns + list of all directories (d:\dirxxx) in root of D drive.} +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 } +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} +{ Returns a sub-string from S which is followed by + Sep separator and deletes the sub-string from S including the separator.} +function StrToken(var S: string; Sep: Char): string; +{ Same as StrToken but searches from the end of S string.} +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).} +function IntToStrFmt(const I: Int64): string; {$IFDEF USE_INLINE}inline;{$ENDIF} +{ Returns string representation of float number (with digit grouping).} +function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; {$IFDEF USE_INLINE}inline;{$ENDIF} + { Clamps integer value to range } function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} { Clamps float value to range } @@ -397,7 +402,7 @@ end; function GetTimeMilliseconds: Int64; begin - Result := GetTimeMicroseconds div 1000; + Result := GetTimeMicroseconds div 1000; end; function GetFileExt(const FileName: string): string; @@ -439,359 +444,275 @@ begin end; function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean): Boolean; -var - MaskLen, KeyLen : LongInt; - - function CharMatch(A, B: Char): Boolean; - begin - if CaseSensitive then - Result := A = B - else - Result := UpCase(A) = UpCase(B); - end; - - function MatchAt(MaskPos, KeyPos: LongInt): Boolean; - begin - while (MaskPos <= MaskLen) and (KeyPos <= KeyLen) do - begin - case Mask[MaskPos] of - '?' : - begin - Inc(MaskPos); - Inc(KeyPos); - end; - '*' : - begin - while (MaskPos <= MaskLen) and (Mask[MaskPos] = '*') do - Inc(MaskPos); - if MaskPos > MaskLen then - begin - Result := True; - Exit; - end; - repeat - if MatchAt(MaskPos, KeyPos) then - begin - Result := True; - Exit; - end; - Inc(KeyPos); - until KeyPos > KeyLen; - Result := False; - Exit; - end; - else - if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then - begin - Result := False; - Exit; - end - else - begin - Inc(MaskPos); - Inc(KeyPos); - end; - end; - end; - - while (MaskPos <= MaskLen) and (Mask[MaskPos] in ['?', '*']) do - Inc(MaskPos); - if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then - begin - Result := False; - Exit; - end; - - Result := True; - end; - -begin - MaskLen := Length(Mask); - KeyLen := Length(FileName); - if MaskLen = 0 then - begin - Result := True; - Exit; - end; - Result := MatchAt(1, 1); +var + MaskLen, KeyLen : LongInt; + + function CharMatch(A, B: Char): Boolean; + begin + if CaseSensitive then + Result := A = B + else + Result := AnsiUpperCase (A) = AnsiUpperCase (B); + end; + + function MatchAt(MaskPos, KeyPos: LongInt): Boolean; + begin + while (MaskPos <= MaskLen) and (KeyPos <= KeyLen) do + begin + case Mask[MaskPos] of + '?' : + begin + Inc(MaskPos); + Inc(KeyPos); + end; + '*' : + begin + while (MaskPos <= MaskLen) and (Mask[MaskPos] = '*') do + Inc(MaskPos); + if MaskPos > MaskLen then + begin + Result := True; + Exit; + end; + repeat + if MatchAt(MaskPos, KeyPos) then + begin + Result := True; + Exit; + end; + Inc(KeyPos); + until KeyPos > KeyLen; + Result := False; + Exit; + end; + else + if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then + begin + Result := False; + Exit; + end + else + begin + Inc(MaskPos); + Inc(KeyPos); + end; + end; + end; + + while (MaskPos <= MaskLen) and (Mask[MaskPos] in ['?', '*']) do + Inc(MaskPos); + if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then + begin + Result := False; + Exit; + end; + + Result := True; + end; + +begin + MaskLen := Length(Mask); + KeyLen := Length(FileName); + if MaskLen = 0 then + begin + Result := True; + Exit; + end; + Result := MatchAt(1, 1); end; function BuildFileList(Path: string; Attr: LongInt; - Files: TStrings; Options: TFileListOptions): Boolean; -var - FileMask: string; - RootDir: string; - Folders: TStringList; - CurrentItem: LongInt; - Counter: LongInt; - LocAttr: LongInt; - - procedure BuildFolderList; - var - FindInfo: TSearchRec; - Rslt: LongInt; - begin - Counter := Folders.Count - 1; - CurrentItem := 0; - while CurrentItem <= Counter do - begin - // Searching for subfolders - Rslt := SysUtils.FindFirst(Folders[CurrentItem] + '*', faDirectory, FindInfo); - try - while Rslt = 0 do - begin - if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') and - (FindInfo.Attr and faDirectory = faDirectory) then - Folders.Add(Folders[CurrentItem] + FindInfo.Name + PathDelim); - Rslt := SysUtils.FindNext(FindInfo); - end; - finally - SysUtils.FindClose(FindInfo); - end; - Counter := Folders.Count - 1; - Inc(CurrentItem); - end; - end; - - procedure FillFileList(CurrentCounter: LongInt); - var - FindInfo: TSearchRec; - Res: LongInt; - CurrentFolder: string; - begin - CurrentFolder := Folders[CurrentCounter]; - Res := SysUtils.FindFirst(CurrentFolder + FileMask, LocAttr, FindInfo); - if flRelNames in Options then - CurrentFolder := ExtractRelativePath(RootDir, CurrentFolder); - try - while Res = 0 do - begin - if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') then - begin - if (flFullNames in Options) or (flRelNames in Options) then - Files.Add(CurrentFolder + FindInfo.Name) - else - Files.Add(FindInfo.Name); - end; - Res := SysUtils.FindNext(FindInfo); - end; - finally - SysUtils.FindClose(FindInfo); - end; - end; - -begin - FileMask := ExtractFileName(Path); - RootDir := ExtractFilePath(Path); - Folders := TStringList.Create; - Folders.Add(RootDir); - Files.Clear; -{$IFDEF DCC} - {$WARN SYMBOL_PLATFORM OFF} -{$ENDIF} - if Attr = faAnyFile then - LocAttr := faSysFile or faHidden or faArchive or faReadOnly - else - LocAttr := Attr; -{$IFDEF DCC} - {$WARN SYMBOL_PLATFORM ON} -{$ENDIF} - // Here's the recursive search for nested folders - if flRecursive in Options then - BuildFolderList; - if Attr <> faDirectory then - for Counter := 0 to Folders.Count - 1 do - FillFileList(Counter) - else - Files.AddStrings(Folders); - Folders.Free; - Result := True; -end; - -function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt; -{$IFDEF USE_ASM} -asm - // The Original ASM Code is (C) Fastcode project. - test eax, eax - jz @Nil - test edx, edx - jz @Nil - dec ecx - jl @Nil - - push esi - push ebx - - mov esi, [edx-4] //Length(Str) - mov ebx, [eax-4] //Length(Substr) - sub esi, ecx //effective length of Str - add edx, ecx //addr of the first char at starting position - cmp esi, ebx - jl @Past //jump if EffectiveLength(Str) 0 then - begin - Result := Copy(S, 1, I - 1); - Delete(S, 1, I); - end - else - begin - Result := S; - S := ''; - end; -end; - -function StrTokenEnd(var S: string; Sep: Char): string; -var - I, J: LongInt; -begin - J := 0; - I := Pos(Sep, S); - while I <> 0 do - begin - J := I; - I := PosEx(Sep, S, J + 1); - end; - if J <> 0 then - begin - Result := Copy(S, J + 1, MaxInt); - Delete(S, J, MaxInt); - end - else - begin - Result := S; - S := ''; - end; -end; - -function IntToStrFmt(const I: Int64): string; -begin - Result := Format('%.0n', [I * 1.0]); -end; - -function FloatToStrFmt(const F: Double; Precision: Integer): string; -begin - Result := Format('%.' + IntToStr(Precision) + 'n', [F]); -end; - + Files: TStrings; Options: TFileListOptions): Boolean; +var + FileMask: string; + RootDir: string; + Folders: TStringList; + CurrentItem: LongInt; + Counter: LongInt; + LocAttr: LongInt; + + procedure BuildFolderList; + var + FindInfo: TSearchRec; + Rslt: LongInt; + begin + Counter := Folders.Count - 1; + CurrentItem := 0; + while CurrentItem <= Counter do + begin + // Searching for subfolders + Rslt := SysUtils.FindFirst(Folders[CurrentItem] + '*', faDirectory, FindInfo); + try + while Rslt = 0 do + begin + if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') and + (FindInfo.Attr and faDirectory = faDirectory) then + Folders.Add(Folders[CurrentItem] + FindInfo.Name + PathDelim); + Rslt := SysUtils.FindNext(FindInfo); + end; + finally + SysUtils.FindClose(FindInfo); + end; + Counter := Folders.Count - 1; + Inc(CurrentItem); + end; + end; + + procedure FillFileList(CurrentCounter: LongInt); + var + FindInfo: TSearchRec; + Res: LongInt; + CurrentFolder: string; + begin + CurrentFolder := Folders[CurrentCounter]; + Res := SysUtils.FindFirst(CurrentFolder + FileMask, LocAttr, FindInfo); + if flRelNames in Options then + CurrentFolder := ExtractRelativePath(RootDir, CurrentFolder); + try + while Res = 0 do + begin + if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') then + begin + if (flFullNames in Options) or (flRelNames in Options) then + Files.Add(CurrentFolder + FindInfo.Name) + else + Files.Add(FindInfo.Name); + end; + Res := SysUtils.FindNext(FindInfo); + end; + finally + SysUtils.FindClose(FindInfo); + end; + end; + +begin + FileMask := ExtractFileName(Path); + RootDir := ExtractFilePath(Path); + Folders := TStringList.Create; + Folders.Add(RootDir); + Files.Clear; +{$IFDEF DCC} + {$WARN SYMBOL_PLATFORM OFF} +{$ENDIF} + if Attr = faAnyFile then + LocAttr := faSysFile or faHidden or faArchive or faReadOnly + else + LocAttr := Attr; +{$IFDEF DCC} + {$WARN SYMBOL_PLATFORM ON} +{$ENDIF} + // Here's the recursive search for nested folders + if flRecursive in Options then + BuildFolderList; + if Attr <> faDirectory then + for Counter := 0 to Folders.Count - 1 do + FillFileList(Counter) + else + Files.AddStrings(Folders); + Folders.Free; + Result := True; +end; + +function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt; +var + I, X: LongInt; + Len, LenSubStr: LongInt; +begin + I := Offset; + LenSubStr := Length(SubStr); + Len := Length(S) - LenSubStr + 1; + while I <= Len do + begin + if S[I] = SubStr[1] then + begin + X := 1; + while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do + Inc(X); + if (X = LenSubStr) then + begin + Result := I; + Exit; + end; + end; + Inc(I); + end; + Result := 0; +end; + +function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt; +begin + Result := PosEx(AnsiLowerCase(SubStr), AnsiLowerCase(S), Offset); +end; + +function StrToken(var S: string; Sep: Char): string; +var + I: LongInt; +begin + I := Pos(Sep, S); + if I <> 0 then + begin + Result := Copy(S, 1, I - 1); + Delete(S, 1, I); + end + else + begin + Result := S; + S := ''; + end; +end; + +function StrTokenEnd(var S: string; Sep: Char): string; +var + I, J: LongInt; +begin + J := 0; + I := Pos(Sep, S); + while I <> 0 do + begin + J := I; + I := PosEx(Sep, S, J + 1); + end; + if J <> 0 then + begin + Result := Copy(S, J + 1, MaxInt); + Delete(S, J, MaxInt); + end + else + begin + Result := S; + S := ''; + end; +end; + +procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings); +var + Token, Str: string; +begin + Tokens.Clear; + Str := S; + while Str <> '' do + begin + Token := StrToken(Str, Sep); + Tokens.Add(Token); + end; +end; + +function IntToStrFmt(const I: Int64): string; +begin + Result := Format('%.0n', [I * 1.0]); +end; + +function FloatToStrFmt(const F: Double; Precision: Integer): string; +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 + else if Result > Max then Result := Max; end; @@ -800,8 +721,7 @@ begin Result := Number; if Result < Min then Result := Min - else - if Result > Max then + else if Result > Max then Result := Max; end; @@ -831,7 +751,7 @@ end; function NextPow2(Num: LongInt): LongInt; begin Result := Num and -Num; - while (Result < Num) do + while Result < Num do Result := Result shl 1; end; @@ -957,18 +877,18 @@ end; function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; begin - if Condition then + if Condition then Result := TruePart else - Result := FalsePart; + Result := FalsePart; end; function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; begin - if Condition then + if Condition then Result := TruePart else - Result := FalsePart; + Result := FalsePart; end; function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; @@ -1062,8 +982,8 @@ end; function MulDiv(Number, Numerator, Denominator: Word): Word; {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))} asm - MUL DX - DIV CX + MUL DX + DIV CX end; {$ELSE} begin @@ -1075,8 +995,8 @@ function IsLittleEndian: Boolean; var W: Word; begin - W := $00FF; - Result := PByte(@W)^ = $FF; + W := $00FF; + Result := PByte(@W)^ = $FF; end; function SwapEndianWord(Value: Word): Word; @@ -1334,12 +1254,12 @@ begin 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)); +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; @@ -1488,27 +1408,27 @@ begin 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); +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 - 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; + 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); -end; +end; procedure DebugMsg(const Msg: string; const Args: array of const); var @@ -1552,6 +1472,12 @@ initialization -- 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! @@ -1561,7 +1487,7 @@ initialization -- 0.23 Changes/Bug Fixes ----------------------------------- - Added RectInRect and RectIntersects functions - - Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase. + - Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase. - Moved BuildFileList here from DemoUtils. -- 0.21 Changes/Bug Fixes ----------------------------------- diff --git a/Imaging/JpegLib/imjdmarker.pas b/Imaging/JpegLib/imjdmarker.pas index 741e90a..23cb9fa 100644 --- a/Imaging/JpegLib/imjdmarker.pas +++ b/Imaging/JpegLib/imjdmarker.pas @@ -1,2644 +1,2644 @@ -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; + 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. diff --git a/Imaging/JpegLib/imjmemmgr.pas b/Imaging/JpegLib/imjmemmgr.pas index 296449f..b3122f6 100644 --- a/Imaging/JpegLib/imjmemmgr.pas +++ b/Imaging/JpegLib/imjmemmgr.pas @@ -1,1282 +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 e64c40a..750fd80 100644 --- a/Imaging/JpegLib/imjmemnobs.pas +++ b/Imaging/JpegLib/imjmemnobs.pas @@ -1,264 +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). } - -{$IFDEF WINDOWS} -const - MAX_ALLOC_CHUNK = long(32752); -{$ELSE} -const - MAX_ALLOC_CHUNK = long(1000000000); -{$ENDIF} - -{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/ZLib/dzlib.pas b/Imaging/ZLib/dzlib.pas index c863ac9..a335628 100644 --- a/Imaging/ZLib/dzlib.pas +++ b/Imaging/ZLib/dzlib.pas @@ -1,520 +1,520 @@ -{*******************************************************} -{ } -{ 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 Char; - 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 PChar = ( - 'need dictionary', // Z_NEED_DICT (2) - 'stream end', // Z_STREAM_END (1) - '', // Z_OK (0) - 'file error', // Z_ERRNO (-1) - 'stream error', // Z_STREAM_ERROR (-2) - 'data error', // Z_DATA_ERROR (-3) - 'insufficient memory', // Z_MEM_ERROR (-4) - 'buffer error', // Z_BUF_ERROR (-5) - 'incompatible version', // Z_VERSION_ERROR (-6) - ''); - -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 Char; -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 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. diff --git a/Imaging/ZLib/iminfcodes.pas b/Imaging/ZLib/iminfcodes.pas index 48de413..5a1a781 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 '+char(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 c744903..400b0fc 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 '+char(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 '+char(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/impaszlib.pas b/Imaging/ZLib/impaszlib.pas index 08f2056..555634c 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 : string); - {$ENDIF} - - procedure Trace(x : string); - procedure Tracev(x : string); - procedure Tracevv(x : string); - procedure Tracevvv(x : string); - procedure Tracec(c : boolean; x : string); - procedure Tracecv(c : boolean; x : string); - -function zlibVersion : string; -{ 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) : string; -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: string; - Stream_size: LongInt): LongInt; -function inflateInit_(var Stream: z_stream; const Version: string; - 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: string; - Stream_size: LongInt): LongInt; -begin - Result := imzdeflate.deflateInit_(@Stream, Level, Version, Stream_size); -end; - -function inflateInit_(var Stream: z_stream; const Version: string; - Stream_size: Longint): LongInt; -begin - Result := imzinflate.inflateInit_(@Stream, Version, Stream_size); -end; - -function zError(err : int) : string; -begin - zError := z_errmsg[Z_NEED_DICT-err]; -end; - -function zlibVersion : string; -begin - zlibVersion := ZLIB_VERSION; -end; - -procedure z_error (m : string); -begin - WriteLn(output, m); - Write('Zlib - Halt...'); - ReadLn; - Halt(1); -end; - -procedure Assert(cond : boolean; msg : string); -begin - if not cond then - z_error(msg); -end; - -procedure Trace(x : string); -begin - WriteLn(x); -end; - -procedure Tracev(x : string); -begin - if (z_verbose>0) then - WriteLn(x); -end; - -procedure Tracevv(x : string); -begin - if (z_verbose>1) then - WriteLn(x); -end; - -procedure Tracevvv(x : string); -begin - if (z_verbose>2) then - WriteLn(x); -end; - -procedure Tracec(c : boolean; x : string); -begin - if (z_verbose>0) and (c) then - WriteLn(x); -end; - -procedure Tracecv(c : boolean; x : string); -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 40c64e9..04c0ebf 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(char)); -{ 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)+' '+char(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), ' '+char(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 <> pchar(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/imzdeflate.pas b/Imaging/ZLib/imzdeflate.pas index 696354c..dc5e96f 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 : string; - 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 : string; - 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 : string; - 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(char(s.window^[match]), char(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(char(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(char(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(char(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(char(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 a67fc1f..6984950 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 : string; - stream_size : int) : int; - - -function inflateInit2_(var z: z_stream; - w : int; - const version : string; - 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 : string; - 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 : string; - 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/Tools/convertfontmap/ConvertFontMap.lpi b/Tools/convertfontmap/ConvertFontMap.lpi new file mode 100644 index 0000000..07889e4 --- /dev/null +++ b/Tools/convertfontmap/ConvertFontMap.lpi @@ -0,0 +1,88 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Tools/convertfontmap/ConvertFontMap.lpr b/Tools/convertfontmap/ConvertFontMap.lpr new file mode 100644 index 0000000..4f67258 --- /dev/null +++ b/Tools/convertfontmap/ConvertFontMap.lpr @@ -0,0 +1,91 @@ +(* + * CDDL HEADER START + * + * The contents of this file are subject to the terms of the + * Common Development and Distribution License, Version 1.0 only + * (the "License"). You may not use this file except in compliance + * with the License. + * + * You can obtain a copy of the license at + * http://www.opensource.org/licenses/cddl1.php. + * See the License for the specific language governing permissions + * and limitations under the License. + * + * When distributing Covered Code, include this CDDL HEADER in each + * file and include the License file at + * http://www.opensource.org/licenses/cddl1.php. If applicable, + * add the following below this CDDL HEADER, with the fields enclosed + * by brackets "[]" replaced with your own identifying * information: + * Portions Copyright [yyyy] [name of copyright owner] + * + * CDDL HEADER END + * + * + * Portions Copyright 2009 Andreas Schneider + *) +program ConvertFontMap; + +{$mode objfpc}{$H+} + +uses + Classes, sysutils, DOM, XMLRead; + +{$IFDEF WINDOWS}{$R ConvertFontMap.rc}{$ENDIF} + +type + TFontInfo = packed record + Character: char; + LeftOffset: SmallInt; + CharWidth: Word; + Width: Word; + Height: Word; + X1: Single; + Y1: Single; + X2: Single; + Y2: Single; + end; + +var + xmlDoc: TXMLDocument; + chars: TDOMNodeList; + root, parent, charNode: TDOMElement; + outFile: TFileStream; + spaceWidth: Word; + fontInfo: TFontInfo; + i: Integer; + +begin + if ParamCount = 2 then + begin + ReadXMLFile(xmlDoc, ParamStr(1)); + outFile := TFileStream.Create(ParamStr(2), fmCreate); + + root := xmlDoc.DocumentElement; + parent := TDOMElement(root.FindNode('characters')); + chars := parent.ChildNodes; + + spaceWidth := StrToInt(root.AttribStrings['spacewidth']); + outFile.Write(spaceWidth, SizeOf(spaceWidth)); + + for i := 0 to chars.Count - 1 do + begin + charNode := TDOMElement(chars[i]); + fontInfo.Character := Char(StrToInt(charNode.AttribStrings['char'])); + fontInfo.LeftOffset := StrToInt(charNode.AttribStrings['A']); + fontInfo.CharWidth := StrToInt(charNode.AttribStrings['C']); + fontInfo.Width := StrToInt(charNode.AttribStrings['wid']); + fontInfo.Height := StrToInt(charNode.AttribStrings['hgt']); + fontInfo.X1 := StrToFloat(charNode.AttribStrings['X1']); + fontInfo.Y1 := StrToFloat(charNode.AttribStrings['Y1']); + fontInfo.X2 := StrToFloat(charNode.AttribStrings['X2']); + fontInfo.Y2 := StrToFloat(charNode.AttribStrings['Y2']); + outFile.Write(fontInfo, SizeOf(fontInfo)); + end; + + outFile.Free; + xmlDoc.Free; + + end else + Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' '); +end. +