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.
+