aksdb
/
CentrED
1
0
Fork 0
Code Issues 2 Pull Requests Releases Wiki Activity

- Updated Vampyre Imaging Lib 

- Added font rendering
- Added height display in flat mode
This commit is contained in:
Andreas Schneider 2009-12-05 17:26:22 +01:00
parent a5128b0d05
commit be3f8c05df
40 changed files with 34488 additions and 32762 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Client/CentrED.lpi
View File

@ -56,7 +56,7 @@
<MinVersion Major="4" Minor="5" Release="1" Valid="True"/>
</Item5>
</RequiredPackages>
<Units Count="35">
<Units Count="36">
<Unit0>
<Filename Value="CentrED.lpr"/>
<IsPartOfProject Value="True"/>
@ -273,6 +273,11 @@
<IsPartOfProject Value="True"/>
<UnitName Value="UTiledata"/>
</Unit34>
<Unit35>
<Filename Value="UGLFont.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="UGLFont"/>
</Unit35>
</Units>
</ProjectOptions>
<CompilerOptions>

2
Client/CentrED.lpr
View File

@ -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}

BIN
Client/GLFont/DejaVu.fnt Normal file
View File

Binary file not shown.

BIN
Client/GLFont/DejaVu.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 5.0 KiB

8
Client/ResourceList.txt
View File

@ -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

205
Client/UGLFont.pas Normal file
View File

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

44
Client/ULandscape.pas
View File

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

211
Client/UResourceManager.pas
View File

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

28
Client/UfrmMain.pas
View File

@ -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);

7038
Imaging/Imaging.pas
View File

File diff suppressed because it is too large Load Diff

1714
Imaging/ImagingBitmap.pas
View File

File diff suppressed because it is too large Load Diff

3821
Imaging/ImagingCanvases.pas
View File

File diff suppressed because it is too large Load Diff

1994
Imaging/ImagingClasses.pas
View File

File diff suppressed because it is too large Load Diff

449
Imaging/ImagingColors.pas
View File

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

322
Imaging/ImagingComponents.pas
View File

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

1728
Imaging/ImagingDds.pas
View File

File diff suppressed because it is too large Load Diff

1778
Imaging/ImagingExport.pas
View File

File diff suppressed because it is too large Load Diff

8575
Imaging/ImagingFormats.pas
View File

File diff suppressed because it is too large Load Diff

2269
Imaging/ImagingGif.pas
View File

File diff suppressed because it is too large Load Diff

1148
Imaging/ImagingIO.pas
View File

File diff suppressed because it is too large Load Diff

1196
Imaging/ImagingJpeg.pas
View File

File diff suppressed because it is too large Load Diff

4739
Imaging/ImagingNetworkGraphics.pas
View File

File diff suppressed because it is too large Load Diff

1844
Imaging/ImagingOpenGL.pas
View File

File diff suppressed because it is too large Load Diff

436
Imaging/ImagingOptions.inc
View File

@ -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}

2023
Imaging/ImagingPortableMaps.pas
View File

File diff suppressed because it is too large Load Diff

1246
Imaging/ImagingTarga.pas
View File

File diff suppressed because it is too large Load Diff

992
Imaging/ImagingTypes.pas
View File

@ -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 <Ord(Low(TImageFormat)), Ord(High(TImageFormat))> 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 <Ord(Low(TImageFormat)), Ord(High(TImageFormat))>
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
<Ord(Low(ImagingFormats.TSamplingFilter)), Ord(High(ImagingFormats.TSamplingFilter))>
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 <Ord(Low(TImageFormat)), Ord(High(TImageFormat))> 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 <Ord(Low(TImageFormat)), Ord(High(TImageFormat))>
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
<Ord(Low(ImagingFormats.TSamplingFilter)), Ord(High(ImagingFormats.TSamplingFilter))>
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.

756
Imaging/ImagingUtility.pas
View File

@ -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 <Min, Max>}
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Clamps float value to range <Min, Max>}
@ -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)<Length(Substr)
test ebx, ebx
jle @Past //jump if Length(Substr)<=0
add esp, -12
add ebx, -1 //Length(Substr)-1
add esi, edx //addr of the terminator
add edx, ebx //addr of the last char at starting position
mov [esp+8], esi //save addr of the terminator
add eax, ebx //addr of the last char of Substr
sub ecx, edx //-@Str[Length(Substr)]
neg ebx //-(Length(Substr)-1)
mov [esp+4], ecx //save -@Str[Length(Substr)]
mov [esp], ebx //save -(Length(Substr)-1)
movzx ecx, byte ptr [eax] //the last char of Substr
@Loop:
cmp cl, [edx]
jz @Test0
@AfterTest0:
cmp cl, [edx+1]
jz @TestT
@AfterTestT:
add edx, 4
cmp edx, [esp+8]
jb @Continue
@EndLoop:
add edx, -2
cmp edx, [esp+8]
jb @Loop
@Exit:
add esp, 12
@Past:
pop ebx
pop esi
@Nil:
xor eax, eax
ret
@Continue:
cmp cl, [edx-2]
jz @Test2
cmp cl, [edx-1]
jnz @Loop
@Test1:
add edx, 1
@Test2:
add edx, -2
@Test0:
add edx, -1
@TestT:
mov esi, [esp]
test esi, esi
jz @Found
@String:
movzx ebx, word ptr [esi+eax]
cmp bx, word ptr [esi+edx+1]
jnz @AfterTestT
cmp esi, -2
jge @Found
movzx ebx, word ptr [esi+eax+2]
cmp bx, word ptr [esi+edx+3]
jnz @AfterTestT
add esi, 4
jl @String
@Found:
mov eax, [esp+4]
add edx, 2
cmp edx, [esp+8]
ja @Exit
add esp, 12
add eax, edx
pop ebx
pop esi
end;
{$ELSE}
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;
{$ENDIF}
function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt;
begin
Result := PosEx(LowerCase(SubStr), LowerCase(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;
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 -----------------------------------

5288
Imaging/JpegLib/imjdmarker.pas
View File

File diff suppressed because it is too large Load Diff

2565
Imaging/JpegLib/imjmemmgr.pas
View File

File diff suppressed because it is too large Load Diff

523
Imaging/JpegLib/imjmemnobs.pas
View File

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

1040
Imaging/ZLib/dzlib.pas
View File

File diff suppressed because it is too large Load Diff

1152
Imaging/ZLib/iminfcodes.pas
View File

File diff suppressed because it is too large Load Diff

636
Imaging/ZLib/iminffast.pas
View File

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

1040
Imaging/ZLib/impaszlib.pas
View File

File diff suppressed because it is too large Load Diff

4496
Imaging/ZLib/imtrees.pas
View File

File diff suppressed because it is too large Load Diff

4258
Imaging/ZLib/imzdeflate.pas
View File

File diff suppressed because it is too large Load Diff

1500
Imaging/ZLib/imzinflate.pas
View File

File diff suppressed because it is too large Load Diff

88
Tools/convertfontmap/ConvertFontMap.lpi Normal file
View File

@ -0,0 +1,88 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="7"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<MainUnit Value="0"/>
<TargetFileExt Value=".exe"/>
<Icon Value="0"/>
<UseXPManifest Value="True"/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="ConvertFontMap.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ConvertFontMap"/>
<CursorPos X="25" Y="38"/>
<TopLine Value="33"/>
<EditorIndex Value="0"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
</Unit0>
</Units>
<JumpHistory Count="1" HistoryIndex="0">
<Position1>
<Filename Value="ConvertFontMap.lpr"/>
<Caret Line="82" Column="17" TopLine="54"/>
</Position1>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="8"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="..\..\bin\ConvertFontMap"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)\"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
</CodeGeneration>
<Linking>
<Debugging>
<UseLineInfoUnit Value="False"/>
<StripSymbols Value="True"/>
</Debugging>
<LinkSmart Value="True"/>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

91
Tools/convertfontmap/ConvertFontMap.lpr Normal file
View File

@ -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)), ' <In Font XML> <Out Font Bin>');
end.