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

⬆️ Update Vampyre Imaging lib

This commit is contained in:
Andreas Schneider 2022-05-08 10:47:53 +02:00
parent 5e47564252
commit d30f01ac64
87 changed files with 65044 additions and 63406 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
Client/UfrmRadar.lfm
View File

@ -1,28 +1,30 @@
object frmRadarMap: TfrmRadarMap
Left = 290
Height = 450
Height = 562
Top = 171
Width = 599
Width = 749
HorzScrollBar.Page = 478
VertScrollBar.Page = 359
ActiveControl = sbMain
Caption = 'Radar Map (1:8)'
ClientHeight = 450
ClientWidth = 599
ClientHeight = 562
ClientWidth = 749
DesignTimePPI = 120
OnClose = FormClose
OnCreate = FormCreate
OnDestroy = FormDestroy
OnResize = FormResize
Position = poOwnerFormCenter
ShowInTaskBar = stAlways
LCLVersion = '2.3.0.0'
object pnlBottom: TPanel
Left = 0
Height = 26
Top = 424
Height = 32
Top = 418
Width = 599
Align = alBottom
BevelOuter = bvNone
ClientHeight = 26
ClientHeight = 32
ClientWidth = 599
TabOrder = 0
object lblPosition: TLabel
@ -31,7 +33,7 @@ object frmRadarMap: TfrmRadarMap
Top = 0
Width = 1
Align = alLeft
BorderSpacing.Left = 10
BorderSpacing.Left = 12
Color = clDefault
Layout = tlCenter
ParentColor = False
@ -50,9 +52,9 @@ object frmRadarMap: TfrmRadarMap
TabOrder = 1
object pbRadar: TPaintBox
Left = 0
Height = 252
Height = 315
Top = 0
Width = 365
Width = 456
OnMouseDown = pbRadarMouseDown
OnMouseLeave = pbRadarMouseLeave
OnMouseMove = pbRadarMouseMove

6
Client/UfrmRadar.pas
View File

@ -113,7 +113,7 @@ begin
SetLength(radarMap, FRadar.Width * FRadar.Height);
for x := 0 to FRadar.Width - 1 do
for y := 0 to FRadar.Height - 1 do
radarMap[x * FRadar.Height + y] := EncodeUOColor(PInteger(FRadar.PixelPointers[x, y])^);
radarMap[x * FRadar.Height + y] := EncodeUOColor(PInteger(FRadar.PixelPointer[x, y])^);
radarMapFile := TFileStream.Create(GetAppConfigDir(False) + 'RadarMap.cache',
fmCreate);
@ -213,7 +213,7 @@ begin
begin
x := ABuffer.ReadWord;
y := ABuffer.ReadWord;
PInteger(FRadar.PixelPointers[x, y])^ := DecodeUOColor(ABuffer.ReadWord);
PInteger(FRadar.PixelPointer[x, y])^ := DecodeUOColor(ABuffer.ReadWord);
RepaintRadar;
end;
end;
@ -225,7 +225,7 @@ var
begin
for x := 0 to FRadar.Width - 1 do
for y := 0 to FRadar.Height - 1 do
PInteger(FRadar.PixelPointers[x, y])^ := DecodeUOColor(ARadarMap[x * FRadar.Height + y]);
PInteger(FRadar.PixelPointer[x, y])^ := DecodeUOColor(ARadarMap[x * FRadar.Height + y]);
RepaintRadar;
end;

1272
Imaging/Imaging.pas
View File

File diff suppressed because it is too large Load Diff

109
Imaging/ImagingBitmap.pas
View File

@ -1,32 +1,17 @@
{
$Id: ImagingBitmap.pas 129 2008-08-06 20:01:30Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains image format loader/saver for Windows Bitmap images.}
{
This unit contains image format loader/saver for Windows Bitmap images.
}
unit ImagingBitmap;
{$I ImagingOptions.inc}
@ -44,6 +29,7 @@ type
TBitmapFileFormat = class(TImageFileFormat)
protected
FUseRLE: LongBool;
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
@ -51,7 +37,6 @@ type
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
{ Controls that RLE compression is used during saving. Accessible trough
@ -85,39 +70,39 @@ type
{ File Header for Windows/OS2 bitmap file.}
TBitmapFileHeader = packed record
ID: Word; // Is always 19778 : 'BM'
Size: LongWord; // Filesize
Size: UInt32; // File size
Reserved1: Word;
Reserved2: Word;
Offset: LongWord; // Offset from start pos to beginning of image bits
Offset: UInt32; // Offset from start pos to beginning of image bits
end;
{ Info Header for Windows bitmap file version 4.}
TBitmapInfoHeader = packed record
Size: LongWord;
Width: LongInt;
Height: LongInt;
Size: UInt32;
Width: Int32;
Height: Int32;
Planes: Word;
BitCount: Word;
Compression: LongWord;
SizeImage: LongWord;
XPelsPerMeter: LongInt;
YPelsPerMeter: LongInt;
ClrUsed: LongInt;
ClrImportant: LongInt;
RedMask: LongWord;
GreenMask: LongWord;
BlueMask: LongWord;
AlphaMask: LongWord;
CSType: LongWord;
EndPoints: array[0..8] of LongWord;
GammaRed: LongWord;
GammaGreen: LongWord;
GammaBlue: LongWord;
Compression: UInt32;
SizeImage: UInt32;
XPelsPerMeter: Int32;
YPelsPerMeter: Int32;
ClrUsed: UInt32;
ClrImportant: UInt32;
RedMask: UInt32;
GreenMask: UInt32;
BlueMask: UInt32;
AlphaMask: UInt32;
CSType: UInt32;
EndPoints: array[0..8] of UInt32;
GammaRed: UInt32;
GammaGreen: UInt32;
GammaBlue: UInt32;
end;
{ Info Header for OS2 bitmaps.}
TBitmapCoreHeader = packed record
Size: LongWord;
Size: UInt32;
Width: Word;
Height: Word;
Planes: Word;
@ -133,13 +118,11 @@ type
{ TBitmapFileFormat class implementation }
constructor TBitmapFileFormat.Create;
procedure TBitmapFileFormat.Define;
begin
inherited Create;
inherited;
FName := SBitmapFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := False;
FFeatures := [ffLoad, ffSave];
FSupportedFormats := BitmapSupportedFormats;
FUseRLE := BitmapDefaultRLE;
@ -211,8 +194,8 @@ var
procedure LoadRLE4;
var
RLESrc: PByteArray;
Row, Col, WriteRow, I: LongInt;
SrcPos: LongWord;
Row, Col, WriteRow, I: Integer;
SrcPos: UInt32;
DeltaX, DeltaY, Low, High: Byte;
Pixels: PByteArray;
OpCode: TRLEOpcode;
@ -228,7 +211,7 @@ var
NegHeightBitmap := BI.Height < 0;
Row := 0; // Current row in dest image
Col := 0; // Current column in dest image
// Row in dest image where actuall writting will be done
// Row in dest image where actual writing will be done
WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
while (Row < Height) and (SrcPos < BI.SizeImage) do
begin
@ -308,8 +291,8 @@ var
procedure LoadRLE8;
var
RLESrc: PByteArray;
SrcCount, Row, Col, WriteRow: LongInt;
SrcPos: LongWord;
SrcCount, Row, Col, WriteRow: Integer;
SrcPos: UInt32;
DeltaX, DeltaY: Byte;
Pixels: PByteArray;
OpCode: TRLEOpcode;
@ -324,7 +307,7 @@ var
NegHeightBitmap := BI.Height < 0;
Row := 0; // Current row in dest image
Col := 0; // Current column in dest image
// Row in dest image where actuall writting will be done
// Row in dest image where actual writing will be done
WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
while (Row < Height) and (SrcPos < BI.SizeImage) do
begin
@ -425,7 +408,7 @@ begin
BI.SizeImage := BF.Size - BF.Offset;
end;
// Bit mask reading. Only read it if there is V3 header, V4 header has
// masks laoded already (only masks for RGB in V3).
// masks loaded already (only masks for RGB in V3).
if (BI.Compression = BI_BITFIELDS) and (BI.Size = V3InfoHeaderSize) then
Read(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3);
@ -455,7 +438,7 @@ begin
// Palette settings and reading
if BI.BitCount <= 8 then
begin
// Seek to the begining of palette
// Seek to the beginning of palette
Seek(Handle, StartPos + SizeOf(TBitmapFileHeader) + LongInt(BI.Size),
smFromBeginning);
if IsOS2 then
@ -523,12 +506,12 @@ begin
// 1 and 4 bpp images are supported only for loading which is now
// so we now convert them to 8bpp (and unalign scanlines).
case BI.BitCount of
1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes);
1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes, False);
4:
begin
// RLE4 bitmaps are translated to 8bit during RLE decoding
if BI.Compression <> BI_RLE4 then
Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes);
Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes, False);
end;
end;
// Enlarge palette
@ -829,7 +812,7 @@ initialization
Should be less buggy an more readable (load inspired by Colosseum Builders' code).
- Made public properties for options registered to SetOption/GetOption
functions.
- Addded alpha check to 32b bitmap loading too (teh same as in 16b
- Added alpha check to 32b bitmap loading too (teh same as in 16b
bitmap loading).
- Moved Convert1To8 and Convert4To8 to ImagingFormats
- Changed extensions to filename masks.
@ -849,7 +832,7 @@ initialization
-- 0.13 Changes/Bug Fixes -----------------------------------
- when loading 1/4 bit images with dword aligned dimensions
there was ugly memory rewritting bug causing image corruption
there was ugly memory rewriting bug causing image corruption
}

269
Imaging/ImagingCanvases.pas
View File

@ -1,34 +1,15 @@
{
$Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{
This unit contains canvas classes for drawing and applying effects.
}
{ This unit contains canvas classes for drawing and applying effects.}
unit ImagingCanvases;
{$I ImagingOptions.inc}
@ -132,7 +113,7 @@ type
TImagingCanvas works for all image data formats except special ones
(compressed). Because of this its methods are quite slow (they usually work
with colors in ifA32R32G32B32F format). If you want fast drawing you
can use one of fast canvas clases. These descendants of TImagingCanvas
can use one of fast canvas classes. These descendants of TImagingCanvas
work only for few select formats (or only one) but they are optimized thus
much faster.
}
@ -179,7 +160,7 @@ type
procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual;
procedure CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
DestX, DestY: LongInt; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
procedure StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor;
Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc);
@ -230,13 +211,13 @@ type
Resulting destination pixel color is:
SrcColor * SrcFactor + DstColor * DstFactor}
procedure DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas;
DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor);
DestX, DestY: LongInt; SrcFactor, DestFactor: TBlendingFactor);
{ Draws contents of this canvas onto another one with typical alpha
blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); virtual;
procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: LongInt); virtual;
{ Draws contents of this canvas onto another one using additive blending
(source and dest factors are bfOne).}
procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer);
procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: LongInt);
{ Draws stretched and filtered contents of this canvas onto another canvas
with pixel blending. Blending factors are chosen using TBlendingFactor parameters.
Resulting destination pixel color is:
@ -293,7 +274,7 @@ type
procedure ModifyContrastBrightness(Contrast, Brightness: Single);
{ Gamma correction of individual color channels. Range is (0, +inf),
1.0 means no change.}
procedure GammaCorection(Red, Green, Blue: Single);
procedure GammaCorrection(Red, Green, Blue: Single);
{ Inverts colors of all image pixels, makes negative image. Ignores alpha channel.}
procedure InvertColors; virtual;
{ Simple single level thresholding with threshold level (in range [0, 1])
@ -350,11 +331,11 @@ type
property PixelsFP[X, Y: LongInt]: TColorFPRec read GetPixelFP write SetPixelFP;
{ Clipping rectangle of this canvas. No pixels outside this rectangle are
altered by canvas methods if Clipping property is True. Clip rect gets
reseted when UpdateCanvasState is called.}
reset when UpdateCanvasState is called.}
property ClipRect: TRect read FClipRect write SetClipRect;
{ Extended format information.}
property FormatInfo: TImageFormatInfo read FFormatInfo;
{ Indicates that this canvas is in valid state. If False canvas oprations
{ Indicates that this canvas is in valid state. If False canvas operations
may crash.}
property Valid: Boolean read GetValid;
@ -379,7 +360,7 @@ type
procedure UpdateCanvasState; override;
procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); override;
procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: LongInt); override;
procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override;
procedure InvertColors; override;
@ -395,7 +376,8 @@ const
Kernel: ((1, 1, 1),
(1, 1, 1),
(1, 1, 1));
Divisor: 9);
Divisor: 9;
Bias: 0);
{ Kernel for 5x5 average smoothing filter.}
FilterAverage5x5: TConvolutionFilter5x5 = (
@ -404,14 +386,16 @@ const
(1, 1, 1, 1, 1),
(1, 1, 1, 1, 1),
(1, 1, 1, 1, 1));
Divisor: 25);
Divisor: 25;
Bias: 0);
{ Kernel for 3x3 Gaussian smoothing filter.}
FilterGaussian3x3: TConvolutionFilter3x3 = (
Kernel: ((1, 2, 1),
(2, 4, 2),
(1, 2, 1));
Divisor: 16);
Divisor: 16;
Bias: 0);
{ Kernel for 5x5 Gaussian smoothing filter.}
FilterGaussian5x5: TConvolutionFilter5x5 = (
@ -420,49 +404,56 @@ const
(6, 24, 36, 24, 6),
(4, 16, 24, 16, 4),
(1, 4, 6, 4, 1));
Divisor: 256);
Divisor: 256;
Bias: 0);
{ Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).}
FilterSobelHorz3x3: TConvolutionFilter3x3 = (
Kernel: (( 1, 2, 1),
( 0, 0, 0),
(-1, -2, -1));
Divisor: 1);
Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).}
FilterSobelVert3x3: TConvolutionFilter3x3 = (
Kernel: ((-1, 0, 1),
(-2, 0, 2),
(-1, 0, 1));
Divisor: 1);
Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Prewitt horizontal edge detection filter.}
FilterPrewittHorz3x3: TConvolutionFilter3x3 = (
Kernel: (( 1, 1, 1),
( 0, 0, 0),
(-1, -1, -1));
Divisor: 1);
Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Prewitt vertical edge detection filter.}
FilterPrewittVert3x3: TConvolutionFilter3x3 = (
Kernel: ((-1, 0, 1),
(-1, 0, 1),
(-1, 0, 1));
Divisor: 1);
Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Kirsh horizontal edge detection filter.}
FilterKirshHorz3x3: TConvolutionFilter3x3 = (
Kernel: (( 5, 5, 5),
(-3, 0, -3),
(-3, -3, -3));
Divisor: 1);
Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Kirsh vertical edge detection filter.}
FilterKirshVert3x3: TConvolutionFilter3x3 = (
Kernel: ((5, -3, -3),
(5, 0, -3),
(5, -3, -3));
Divisor: 1);
Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Laplace omni-directional edge detection filter
(2nd derivative approximation).}
@ -470,7 +461,8 @@ const
Kernel: ((-1, -1, -1),
(-1, 8, -1),
(-1, -1, -1));
Divisor: 1);
Divisor: 1;
Bias: 0);
{ Kernel for 5x5 Laplace omni-directional edge detection filter
(2nd derivative approximation).}
@ -480,23 +472,26 @@ const
(-1, -1, 24, -1, -1),
(-1, -1, -1, -1, -1),
(-1, -1, -1, -1, -1));
Divisor: 1);
Divisor: 1;
Bias: 0);
{ Kernel for 3x3 spharpening filter (Laplacian + original color).}
{ Kernel for 3x3 sharpening filter (Laplacian + original color).}
FilterSharpen3x3: TConvolutionFilter3x3 = (
Kernel: ((-1, -1, -1),
(-1, 9, -1),
(-1, -1, -1));
Divisor: 1);
Divisor: 1;
Bias: 0);
{ Kernel for 5x5 spharpening filter (Laplacian + original color).}
{ Kernel for 5x5 sharpening filter (Laplacian + original color).}
FilterSharpen5x5: TConvolutionFilter5x5 = (
Kernel: ((-1, -1, -1, -1, -1),
(-1, -1, -1, -1, -1),
(-1, -1, 25, -1, -1),
(-1, -1, -1, -1, -1),
(-1, -1, -1, -1, -1));
Divisor: 1);
Divisor: 1;
Bias: 0);
{ Kernel for 5x5 glow filter.}
FilterGlow5x5: TConvolutionFilter5x5 = (
@ -505,17 +500,19 @@ const
( 2, 0, -20, 0, 2),
( 2, 0, 0, 0, 2),
( 1, 2, 2, 2, 1));
Divisor: 8);
Divisor: 8;
Bias: 0);
{ Kernel for 3x3 edge enhancement filter.}
FilterEdgeEnhance3x3: TConvolutionFilter3x3 = (
Kernel: ((-1, -2, -1),
(-2, 16, -2),
(-1, -2, -1));
Divisor: 4);
Divisor: 4;
Bias: 0);
{ Kernel for 3x3 contour enhancement filter.}
FilterTraceControur3x3: TConvolutionFilter3x3 = (
FilterTraceContour3x3: TConvolutionFilter3x3 = (
Kernel: ((-6, -6, -2),
(-1, 32, -1),
(-6, -2, -6));
@ -616,6 +613,8 @@ begin
bfOneMinusDstAlpha: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A);
bfDstColor: FSrc := ColorFP(DestPix.A, DestPix.R, DestPix.G, DestPix.B);
bfOneMinusDstColor: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.R, 1 - DestPix.G, 1 - DestPix.B);
else
Assert(False);
end;
case DestFactor of
bfZero: FDst := ColorFP(0, 0, 0, 0);
@ -626,6 +625,8 @@ begin
bfOneMinusDstAlpha: FDst := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A);
bfSrcColor: FDst := ColorFP(SrcPix.A, SrcPix.R, SrcPix.G, SrcPix.B);
bfOneMinusSrcColor: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.R, 1 - SrcPix.G, 1 - SrcPix.B);
else
Assert(False);
end;
// Compute blending formula
DestPix.R := SrcPix.R * FSrc.R + DestPix.R * FDst.R;
@ -645,7 +646,10 @@ begin
DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
// Blend the two pixels (Src 'over' Dest alpha composition operation)
DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A;
SrcAlpha := IffFloat(DestPix.A = 0, 0, SrcPix.A / DestPix.A);
if DestPix.A = 0 then
SrcAlpha := 0
else
SrcAlpha := SrcPix.A / DestPix.A;
DestAlpha := 1.0 - SrcAlpha;
DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha;
DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha;
@ -786,9 +790,9 @@ end;
function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
begin
Result.A := Pixel.A;
Result.R := Result.R * Pixel.A;
Result.G := Result.G * Pixel.A;
Result.B := Result.B * Pixel.A;
Result.R := Pixel.R * Pixel.A;
Result.G := Pixel.G * Pixel.A;
Result.B := Pixel.B * Pixel.A;
end;
function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
@ -796,9 +800,9 @@ begin
Result.A := Pixel.A;
if Pixel.A <> 0.0 then
begin
Result.R := Result.R / Pixel.A;
Result.G := Result.G / Pixel.A;
Result.B := Result.B / Pixel.A;
Result.R := Pixel.R / Pixel.A;
Result.G := Pixel.G / Pixel.A;
Result.B := Pixel.B / Pixel.A;
end
else
begin
@ -906,8 +910,7 @@ end;
procedure TImagingCanvas.SetClipRect(const Value: TRect);
begin
FClipRect := Value;
SwapMin(FClipRect.Left, FClipRect.Right);
SwapMin(FClipRect.Top, FClipRect.Bottom);
NormalizeRect(FClipRect);
IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height));
end;
@ -987,7 +990,7 @@ begin
case Bpp of
1: FillMemoryByte(PixelPtr, WidthBytes, PByte(Color)^);
2: FillMemoryWord(PixelPtr, WidthBytes, PWord(Color)^);
4: FillMemoryLongWord(PixelPtr, WidthBytes, PLongWord(Color)^);
4: FillMemoryUInt32(PixelPtr, WidthBytes, PUInt32(Color)^);
else
for I := X1 to X2 do
begin
@ -1046,16 +1049,16 @@ begin
if FPenMode = pmClear then Exit;
// If line is vertical or horizontal just call appropriate method
if X2 - X1 = 0 then
begin
HorzLine(X1, X2, Y1);
Exit;
end;
if Y2 - Y1 = 0 then
if X2 = X1 then
begin
VertLine(X1, Y1, Y2);
Exit;
end;
if Y2 = Y1 then
begin
HorzLine(X1, X2, Y1);
Exit;
end;
// Determine if line is steep (angle with X-axis > 45 degrees)
Steep := Abs(Y2 - Y1) > Abs(X2 - X1);
@ -1354,10 +1357,10 @@ begin
end;
procedure TImagingCanvas.DrawInternal(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor,
DestCanvas: TImagingCanvas; DestX, DestY: LongInt; SrcFactor,
DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
var
X, Y, SrcX, SrcY, Width, Height, SrcBpp, DestBpp: Integer;
X, Y, SrcX, SrcY, Width, Height, SrcBpp, DestBpp: LongInt;
PSrc: TColorFPRec;
SrcPointer, DestPointer: PByte;
begin
@ -1391,19 +1394,19 @@ begin
end;
procedure TImagingCanvas.DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas;
DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor);
DestX, DestY: LongInt; SrcFactor, DestFactor: TBlendingFactor);
begin
DrawInternal(SrcRect, DestCanvas, DestX, DestY, SrcFactor, DestFactor, PixelBlendProc);
end;
procedure TImagingCanvas.DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
DestX, DestY: Integer);
DestX, DestY: LongInt);
begin
DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAlphaProc);
end;
procedure TImagingCanvas.DrawAdd(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer);
DestCanvas: TImagingCanvas; DestX, DestY: LongInt);
begin
DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAddProc);
end;
@ -1414,13 +1417,13 @@ procedure TImagingCanvas.StretchDrawInternal(const SrcRect: TRect;
PixelWriteProc: TPixelWriteProc);
const
FilterMapping: array[TResizeFilter] of TSamplingFilter =
(sfNearest, sfLinear, DefaultCubicFilter);
(sfNearest, sfLinear, DefaultCubicFilter, sfLanczos);
var
X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: Integer;
DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: Integer;
SrcPix, PDest: TColorFPRec;
X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: LongInt;
SrcPix: TColorFPRec;
MapX, MapY: TMappingTable;
XMinimum, XMaximum: Integer;
XMinimum, XMaximum: LongInt;
LineBuffer: array of TColorFPRec;
ClusterX, ClusterY: TCluster;
Weight, AccumA, AccumR, AccumG, AccumB: Single;
@ -1572,10 +1575,10 @@ begin
PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1);
SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp];
// Get pixels from neighbourhood of current pixel and add their
// Get pixels from neighborhood of current pixel and add their
// colors to accumulators weighted by filter kernel values
Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette);
KernelValue := PLongIntArray(Kernel)[J * KernelSize + I];
KernelValue := PUInt32Array(Kernel)[J * KernelSize + I];
R := R + Pixel.R * KernelValue;
G := G + Pixel.G * KernelValue;
@ -1714,7 +1717,7 @@ begin
Brightness / 100, 0);
end;
procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single);
procedure TImagingCanvas.GammaCorrection(Red, Green, Blue: Single);
begin
PointTransform(TransformGamma, Red, Green, Blue);
end;
@ -1852,9 +1855,9 @@ begin
end;
procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer);
DestCanvas: TImagingCanvas; DestX, DestY: LongInt);
var
X, Y, SrcX, SrcY, Width, Height: Integer;
X, Y, SrcX, SrcY, Width, Height: LongInt;
SrcPix, DestPix: PColor32Rec;
begin
if DestCanvas.ClassType <> Self.ClassType then
@ -1900,10 +1903,10 @@ end;
procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect;
DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
var
X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4,
FracX, FracY, InvFracY, T1, T2: Integer;
SrcX, SrcY, SrcWidth, SrcHeight: Integer;
DestX, DestY, DestWidth, DestHeight: Integer;
X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4, InvFracY, T1, T2: Integer;
FracX, FracY: Cardinal;
SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
DestX, DestY, DestWidth, DestHeight: LongInt;
SrcLine, SrcLine2: PColor32RecArray;
DestPix: PColor32Rec;
Accum: TColor32Rec;
@ -1985,9 +1988,9 @@ begin
end;
T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1);
Weight2:= (Cardinal(InvFracY) * FracX) shr 16; // cast to Card, Int can overflow gere
Weight2:= Integer((Cardinal(InvFracY) * FracX) shr 16); // cast to Card, Int can overflow here
Weight1:= InvFracY - Weight2;
Weight4:= (Cardinal(FracY) * FracX) shr 16;
Weight4:= Integer((Cardinal(FracY) * FracX) shr 16);
Weight3:= FracY - Weight4;
Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 +
@ -2007,83 +2010,12 @@ begin
Inc(Yp, ScaleY);
end;
end;
{
// Generate mapping tables
MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth,
FPData.Width, FilterFunction, Radius, False);
MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight,
FPData.Height, FilterFunction, Radius, False);
FindExtremes(MapX, XMinimum, XMaximum);
SetLength(LineBuffer, XMaximum - XMinimum + 1);
for J := 0 to DestHeight - 1 do
begin
ClusterY := MapY[J];
for X := XMinimum to XMaximum do
begin
AccumA := 0;
AccumR := 0;
AccumG := 0;
AccumB := 0;
for Y := 0 to Length(ClusterY) - 1 do
begin
Weight := Round(ClusterY[Y].Weight * 256);
SrcColor := FScanlines[ClusterY[Y].Pos, X];
AccumB := AccumB + SrcColor.B * Weight;
AccumG := AccumG + SrcColor.G * Weight;
AccumR := AccumR + SrcColor.R * Weight;
AccumA := AccumA + SrcColor.A * Weight;
end;
with LineBuffer[X - XMinimum] do
begin
A := AccumA;
R := AccumR;
G := AccumG;
B := AccumB;
end;
end;
DestPtr := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + J, DestX];
for I := 0 to DestWidth - 1 do
begin
ClusterX := MapX[I];
AccumA := 0;
AccumR := 0;
AccumG := 0;
AccumB := 0;
for X := 0 to Length(ClusterX) - 1 do
begin
Weight := Round(ClusterX[X].Weight * 256);
with LineBuffer[ClusterX[X].Pos - XMinimum] do
begin
AccumB := AccumB + B * Weight;
AccumG := AccumG + G * Weight;
AccumR := AccumR + R * Weight;
AccumA := AccumA + A * Weight;
end;
end;
AccumA := ClampInt(AccumA, 0, $00FF0000);
AccumR := ClampInt(AccumR, 0, $00FF0000);
AccumG := ClampInt(AccumG, 0, $00FF0000);
AccumB := ClampInt(AccumB, 0, $00FF0000);
SrcColor.Color := (Cardinal(AccumA and $00FF0000) shl 8) or
(AccumR and $00FF0000) or ((AccumG and $00FF0000) shr 8) or ((AccumB and $00FF0000) shr 16);
AlphaBlendPixels(@SrcColor, DestPtr);
Inc(DestPtr);
end;
end; }
end;
procedure TFastARGB32Canvas.UpdateCanvasState;
var
I: LongInt;
ScanPos: PLongWord;
ScanPos: PUInt32;
begin
inherited UpdateCanvasState;
@ -2133,9 +2065,14 @@ finalization
-- TODOS ----------------------------------------------------
- more more more ...
- implement pen width everywhere
- add blending (*image and object drawing)
- more objects (arc, polygon)
-- 0.26.5 Changes/Bug Fixes ---------------------------------
- Fixed bug that could raise floating point error in DrawAlpha
and StretchDrawAlpha.
- Fixed bug in TImagingCanvas.Line that caused not drawing
of horz or vert lines.
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha)
- Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation.
@ -2146,7 +2083,7 @@ finalization
- Added FloodFill method.
- Added GetHistogram method.
- Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes
(thanks to Carlos González).
(thanks to Carlos Gonzalez).
- Added TImagingCanvas.AdjustColorLevels method.
-- 0.25.0 Changes/Bug Fixes ---------------------------------
@ -2169,7 +2106,7 @@ finalization
-- 0.19 Changes/Bug Fixes -----------------------------------
- added TFastARGB32Canvas
- added convolutions, hline, vline
- unit created, intial stuff added
- unit created, initial stuff added
}

490
Imaging/ImagingClasses.pas
View File

@ -1,29 +1,12 @@
{
$Id: ImagingClasses.pas 173 2009-09-04 17:05:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains class based wrapper to Imaging library.}
@ -40,41 +23,52 @@ type
{ Base abstract high level class wrapper to low level Imaging structures and
functions.}
TBaseImage = class(TPersistent)
private
function GetEmpty: Boolean;
protected
FPData: PImageData;
FOnDataSizeChanged: TNotifyEvent;
FOnPixelsChanged: TNotifyEvent;
function GetFormat: TImageFormat; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetHeight: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetSize: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetWidth: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetHeight: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetSize: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetWidth: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetBits: Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPalette: PPalette32; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPaletteEntries: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetScanLine(Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPaletteEntries: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetScanline(Index: Integer): Pointer;
function GetPixelPointer(X, Y: Integer): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetScanlineSize: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetFormatInfo: TImageFormatInfo; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetBoundsRect: TRect;
procedure SetFormat(const Value: TImageFormat); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetHeight(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetHeight(const Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetWidth(const Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetPointer; virtual; abstract;
procedure DoDataSizeChanged; virtual;
procedure DoPixelsChanged; virtual;
published
public
constructor Create; virtual;
constructor CreateFromImage(AImage: TBaseImage);
destructor Destroy; override;
{ Returns info about current image.}
function ToString: string;
function ToString: string; {$IF (Defined(DCC) and (CompilerVersion >= 20.0)) or Defined(FPC)}override;{$IFEND}
{ Creates a new image data with the given size and format. Old image
data is lost. Works only for the current image of TMultiImage.}
procedure RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat);
procedure RecreateImageData(AWidth, AHeight: Integer; AFormat: TImageFormat);
{ Maps underlying image data to given TImageData record. Both TBaseImage and
TImageData now share some image memory (bits). So don't call FreeImage
on TImageData afterwards since this TBaseImage would get really broken.}
procedure MapImageData(const ImageData: TImageData);
{ Deletes current image.}
procedure Clear;
{ Resizes current image with optional resampling.}
procedure Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
procedure Resize(NewWidth, NewHeight: Integer; Filter: TResizeFilter);
{ Resizes current image proportionally to fit the given width and height. }
procedure ResizeToFit(FitWidth, FitHeight: Integer; Filter: TResizeFilter; DstImage: TBaseImage);
{ Flips current image. Reverses the image along its horizontal axis the top
becomes the bottom and vice versa.}
procedure Flip;
@ -88,21 +82,27 @@ type
negative X and Y coordinates.
Note that copying is fastest for images in the same data format
(and slowest for images in special formats).}
procedure CopyTo(SrcX, SrcY, Width, Height: LongInt; DstImage: TBaseImage; DstX, DstY: LongInt);
procedure CopyTo(SrcX, SrcY, Width, Height: Integer; DstImage: TBaseImage; DstX, DstY: Integer); overload;
{ Copies whole image to DstImage. No blending is performed -
alpha is simply copied to destination image. Operates also with
negative X and Y coordinates.
Note that copying is fastest for images in the same data format
(and slowest for images in special formats).}
procedure CopyTo(DstImage: TBaseImage; DstX, DstY: Integer); overload;
{ Stretches the contents of the source rectangle to the destination rectangle
with optional resampling. No blending is performed - alpha is
simply copied/resampled to destination image. Note that stretching is
fastest for images in the same data format (and slowest for
images in special formats).}
procedure StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt; DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter);
procedure StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: Integer; DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: Integer; Filter: TResizeFilter);
{ Replaces pixels with OldPixel in the given rectangle by NewPixel.
OldPixel and NewPixel should point to the pixels in the same format
as the given image is in.}
procedure ReplaceColor(X, Y, Width, Height: LongInt; OldColor, NewColor: Pointer);
procedure ReplaceColor(X, Y, Width, Height: Integer; OldColor, NewColor: Pointer);
{ Swaps SrcChannel and DstChannel color or alpha channels of image.
Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
identify channels.}
procedure SwapChannels(SrcChannel, DstChannel: LongInt);
procedure SwapChannels(SrcChannel, DstChannel: Integer);
{ Loads current image data from file.}
procedure LoadFromFile(const FileName: string); virtual;
@ -110,31 +110,33 @@ type
procedure LoadFromStream(Stream: TStream); virtual;
{ Saves current image data to file.}
procedure SaveToFile(const FileName: string);
function SaveToFile(const FileName: string): Boolean;
{ Saves current image data to stream. Ext identifies desired image file
format (jpg, png, dds, ...)}
procedure SaveToStream(const Ext: string; Stream: TStream);
format (jpg, png, dds, ...).}
function SaveToStream(const Ext: string; Stream: TStream): Boolean;
{ Width of current image in pixels.}
property Width: LongInt read GetWidth write SetWidth;
property Width: Integer read GetWidth write SetWidth;
{ Height of current image in pixels.}
property Height: LongInt read GetHeight write SetHeight;
property Height: Integer read GetHeight write SetHeight;
{ Image data format of current image.}
property Format: TImageFormat read GetFormat write SetFormat;
{ Size in bytes of current image's data.}
property Size: LongInt read GetSize;
property Size: Integer read GetSize;
{ Pointer to memory containing image bits.}
property Bits: Pointer read GetBits;
{ Pointer to palette for indexed format images. It is nil for others.
Max palette entry is at index [PaletteEntries - 1].}
property Palette: PPalette32 read GetPalette;
{ Number of entries in image's palette}
property PaletteEntries: LongInt read GetPaletteEntries;
property PaletteEntries: Integer read GetPaletteEntries;
{ Provides indexed access to each line of pixels. Does not work with special
format images (like DXT).}
property ScanLine[Index: LongInt]: Pointer read GetScanLine;
property Scanline[Index: Integer]: Pointer read GetScanline;
{ Returns pointer to image pixel at [X, Y] coordinates.}
property PixelPointers[X, Y: LongInt]: Pointer read GetPixelPointer;
property PixelPointer[X, Y: Integer]: Pointer read GetPixelPointer;
{ Size/length of one image scanline in bytes.}
property ScanlineSize: Integer read GetScanlineSize;
{ Extended image format information.}
property FormatInfo: TImageFormatInfo read GetFormatInfo;
{ This gives complete access to underlying TImageData record.
@ -144,7 +146,9 @@ type
{ Indicates whether the current image is valid (proper format,
allowed dimensions, right size, ...).}
property Valid: Boolean read GetValid;
{{ Specifies the bounding rectangle of the image.}
{ Indicates whether image contains any data (size in bytes > 0).}
property Empty: Boolean read GetEmpty;
{ Specifies the bounding rectangle of the image.}
property BoundsRect: TRect read GetBoundsRect;
{ This event occurs when the image data size has just changed. That means
image width, height, or format has been changed.}
@ -161,13 +165,15 @@ type
procedure SetPointer; override;
public
constructor Create; override;
constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault);
constructor CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat = ifDefault);
constructor CreateFromData(const AData: TImageData);
constructor CreateFromFile(const FileName: string);
constructor CreateFromStream(Stream: TStream);
destructor Destroy; override;
{ Assigns single image from another single image or multi image.}
procedure Assign(Source: TPersistent); override;
{ Assigns single image from image data record.}
procedure AssignFromImageData(const AImageData: TImageData);
end;
{ Extension of TBaseImage which uses array of TImageData records to
@ -180,70 +186,74 @@ type
TMultiImage = class(TBaseImage)
protected
FDataArray: TDynImageDataArray;
FActiveImage: LongInt;
procedure SetActiveImage(Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetImageCount: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetImageCount(Value: LongInt);
FActiveImage: Integer;
procedure SetActiveImage(Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetImageCount: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetImageCount(Value: Integer);
function GetAllImagesValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetImage(Index: LongInt): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetImage(Index: LongInt; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetImage(Index: Integer): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetImage(Index: Integer; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetPointer; override;
function PrepareInsert(Index, Count: LongInt): Boolean;
procedure DoInsertImages(Index: LongInt; const Images: TDynImageDataArray);
procedure DoInsertNew(Index: LongInt; AWidth, AHeight: LongInt; AFormat: TImageFormat);
function PrepareInsert(Index, InsertCount: Integer): Boolean;
procedure DoInsertImages(Index: Integer; const Images: TDynImageDataArray);
procedure DoInsertNew(Index: Integer; AWidth, AHeight: Integer; AFormat: TImageFormat);
public
constructor Create; override;
constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat; Images: LongInt);
constructor CreateFromArray(ADataArray: TDynImageDataArray);
constructor CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat; ImageCount: Integer);
constructor CreateFromArray(const ADataArray: TDynImageDataArray);
constructor CreateFromFile(const FileName: string);
constructor CreateFromStream(Stream: TStream);
destructor Destroy; override;
{ Assigns multi image from another multi image or single image.}
procedure Assign(Source: TPersistent); override;
{ Assigns multi image from array of image data records.}
procedure AssignFromArray(const ADataArray: TDynImageDataArray);
{ Adds new image at the end of the image array. }
procedure AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload;
{ Adds existing image at the end of the image array. }
procedure AddImage(const Image: TImageData); overload;
{ Adds existing image (Active image of a TmultiImage)
at the end of the image array. }
procedure AddImage(Image: TBaseImage); overload;
{ Adds existing image array ((all images of a multi image))
at the end of the image array. }
{ Adds new image at the end of the image array. Returns index of the added image.}
function AddImage(AWidth, AHeight: Integer; AFormat: TImageFormat = ifDefault): Integer; overload;
{ Adds existing image at the end of the image array. Returns index of the added image.}
function AddImage(const Image: TImageData): Integer; overload;
{ Adds existing image (or active image of a TMultiImage)
at the end of the image array. Returns index of the added image.}
function AddImage(Image: TBaseImage): Integer; overload;
{ Adds existing image array (all images of a multi image)
at the end of the image array.}
procedure AddImages(const Images: TDynImageDataArray); overload;
{ Adds existing MultiImage images at the end of the image array. }
{ Adds existing MultiImage images at the end of the image array.}
procedure AddImages(Images: TMultiImage); overload;
{ Inserts new image image at the given position in the image array. }
procedure InsertImage(Index, AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload;
procedure InsertImage(Index, AWidth, AHeight: Integer; AFormat: TImageFormat = ifDefault); overload;
{ Inserts existing image at the given position in the image array. }
procedure InsertImage(Index: LongInt; const Image: TImageData); overload;
{ Inserts existing image (Active image of a TmultiImage)
procedure InsertImage(Index: Integer; const Image: TImageData); overload;
{ Inserts existing image (Active image of a TMultiImage)
at the given position in the image array. }
procedure InsertImage(Index: LongInt; Image: TBaseImage); overload;
procedure InsertImage(Index: Integer; Image: TBaseImage); overload;
{ Inserts existing image at the given position in the image array. }
procedure InsertImages(Index: LongInt; const Images: TDynImageDataArray); overload;
{ Inserts existing images (all images of a TmultiImage) at
procedure InsertImages(Index: Integer; const Images: TDynImageDataArray); overload;
{ Inserts existing images (all images of a TMultiImage) at
the given position in the image array. }
procedure InsertImages(Index: LongInt; Images: TMultiImage); overload;
procedure InsertImages(Index: Integer; Images: TMultiImage); overload;
{ Exchanges two images at the given positions in the image array. }
procedure ExchangeImages(Index1, Index2: LongInt);
procedure ExchangeImages(Index1, Index2: Integer);
{ Deletes image at the given position in the image array.}
procedure DeleteImage(Index: LongInt);
procedure DeleteImage(Index: Integer);
{ Rearranges images so that the first image will become last and vice versa.}
procedure ReverseImages;
{ Deletes all images.}
procedure ClearAll;
{ Converts all images to another image data format.}
procedure ConvertImages(Format: TImageFormat);
{ Resizes all images.}
procedure ResizeImages(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
procedure ResizeImages(NewWidth, NewHeight: Integer; Filter: TResizeFilter);
{ Overloaded loading method that will add new image to multiimage if
image array is empty bero loading. }
{ Overloaded loading method that will add new image to multi-image if
image array is empty before loading. If it's not empty the active image is replaced.}
procedure LoadFromFile(const FileName: string); override;
{ Overloaded loading method that will add new image to multiimage if
image array is empty bero loading. }
{ Overloaded loading method that will add new image to multi-image if
image array is empty before loading. If it's not empty the active image is replaced.}
procedure LoadFromStream(Stream: TStream); override;
{ Loads whole multi image from file.}
@ -251,16 +261,16 @@ type
{ Loads whole multi image from stream.}
procedure LoadMultiFromStream(Stream: TStream);
{ Saves whole multi image to file.}
procedure SaveMultiToFile(const FileName: string);
function SaveMultiToFile(const FileName: string): Boolean;
{ Saves whole multi image to stream. Ext identifies desired
image file format (jpg, png, dds, ...).}
procedure SaveMultiToStream(const Ext: string; Stream: TStream);
function SaveMultiToStream(const Ext: string; Stream: TStream): Boolean;
{ Indicates active image of this multi image. All methods inherited
from TBaseImage operate on this image only.}
property ActiveImage: LongInt read FActiveImage write SetActiveImage;
property ActiveImage: Integer read FActiveImage write SetActiveImage;
{ Number of images of this multi image.}
property ImageCount: LongInt read GetImageCount write SetImageCount;
property ImageCount: Integer read GetImageCount write SetImageCount;
{ This value is True if all images of this TMultiImage are valid.}
property AllImagesValid: Boolean read GetAllImagesValid;
{ This gives complete access to underlying TDynImageDataArray.
@ -269,7 +279,7 @@ type
property DataArray: TDynImageDataArray read FDataArray;
{ Array property for accessing individual images of TMultiImage. When you
set image at given index the old image is freed and the source is cloned.}
property Images[Index: LongInt]: TImageData read GetImage write SetImage; default;
property Images[Index: Integer]: TImageData read GetImage write SetImage; default;
end;
implementation
@ -277,7 +287,6 @@ implementation
const
DefaultWidth = 16;
DefaultHeight = 16;
DefaultImages = 1;
function GetArrayFromImageData(const ImageData: TImageData): TDynImageDataArray;
begin
@ -303,7 +312,7 @@ begin
inherited Destroy;
end;
function TBaseImage.GetWidth: LongInt;
function TBaseImage.GetWidth: Integer;
begin
if Valid then
Result := FPData.Width
@ -311,7 +320,7 @@ begin
Result := 0;
end;
function TBaseImage.GetHeight: LongInt;
function TBaseImage.GetHeight: Integer;
begin
if Valid then
Result := FPData.Height
@ -327,7 +336,7 @@ begin
Result := ifUnknown;
end;
function TBaseImage.GetScanLine(Index: LongInt): Pointer;
function TBaseImage.GetScanline(Index: Integer): Pointer;
var
Info: TImageFormatInfo;
begin
@ -343,7 +352,15 @@ begin
Result := nil;
end;
function TBaseImage.GetPixelPointer(X, Y: LongInt): Pointer;
function TBaseImage.GetScanlineSize: Integer;
begin
if Valid then
Result := FormatInfo.GetPixelsSize(Format, Width, 1)
else
Result := 0;
end;
function TBaseImage.GetPixelPointer(X, Y: Integer): Pointer;
begin
if Valid then
Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * GetFormatInfo.BytesPerPixel]
@ -351,7 +368,7 @@ begin
Result := nil;
end;
function TBaseImage.GetSize: LongInt;
function TBaseImage.GetSize: Integer;
begin
if Valid then
Result := FPData.Size
@ -375,7 +392,7 @@ begin
Result := nil;
end;
function TBaseImage.GetPaletteEntries: LongInt;
function TBaseImage.GetPaletteEntries: Integer;
begin
Result := GetFormatInfo.PaletteEntries;
end;
@ -398,12 +415,17 @@ begin
Result := Rect(0, 0, GetWidth, GetHeight);
end;
procedure TBaseImage.SetWidth(const Value: LongInt);
function TBaseImage.GetEmpty: Boolean;
begin
Result := FPData.Size = 0;
end;
procedure TBaseImage.SetWidth(const Value: Integer);
begin
Resize(Value, GetHeight, rfNearest);
end;
procedure TBaseImage.SetHeight(const Value: LongInt);
procedure TBaseImage.SetHeight(const Value: Integer);
begin
Resize(GetWidth, Value, rfNearest);
end;
@ -427,18 +449,45 @@ begin
FOnPixelsChanged(Self);
end;
procedure TBaseImage.RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat);
procedure TBaseImage.RecreateImageData(AWidth, AHeight: Integer; AFormat: TImageFormat);
begin
if Assigned(FPData) and Imaging.NewImage(AWidth, AHeight, AFormat, FPData^) then
DoDataSizeChanged;
end;
procedure TBaseImage.Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
procedure TBaseImage.MapImageData(const ImageData: TImageData);
begin
Clear;
FPData.Width := ImageData.Width;
FPData.Height := ImageData.Height;
FPData.Format := ImageData.Format;
FPData.Size := ImageData.Size;
FPData.Bits := ImageData.Bits;
FPData.Palette := ImageData.Palette;
end;
procedure TBaseImage.Clear;
begin
FreeImage(FPData^);
end;
procedure TBaseImage.Resize(NewWidth, NewHeight: Integer; Filter: TResizeFilter);
begin
if Valid and Imaging.ResizeImage(FPData^, NewWidth, NewHeight, Filter) then
DoDataSizeChanged;
end;
procedure TBaseImage.ResizeToFit(FitWidth, FitHeight: Integer;
Filter: TResizeFilter; DstImage: TBaseImage);
begin
if Valid and Assigned(DstImage) then
begin
Imaging.ResizeImageToFit(FPData^, FitWidth, FitHeight, Filter,
DstImage.FPData^);
DstImage.DoDataSizeChanged;
end;
end;
procedure TBaseImage.Flip;
begin
if Valid and Imaging.FlipImage(FPData^) then
@ -453,12 +502,15 @@ end;
procedure TBaseImage.Rotate(Angle: Single);
begin
if Valid and Imaging.RotateImage(FPData^, Angle) then
if Valid then
begin
Imaging.RotateImage(FPData^, Angle);
DoPixelsChanged;
end;
end;
procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: LongInt;
DstImage: TBaseImage; DstX, DstY: LongInt);
procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: Integer;
DstImage: TBaseImage; DstX, DstY: Integer);
begin
if Valid and Assigned(DstImage) and DstImage.Valid then
begin
@ -467,8 +519,17 @@ begin
end;
end;
procedure TBaseImage.StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter);
procedure TBaseImage.CopyTo(DstImage: TBaseImage; DstX, DstY: Integer);
begin
if Valid and Assigned(DstImage) and DstImage.Valid then
begin
Imaging.CopyRect(FPData^, 0, 0, Width, Height, DstImage.FPData^, DstX, DstY);
DstImage.DoPixelsChanged;
end;
end;
procedure TBaseImage.StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: Integer;
DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: Integer; Filter: TResizeFilter);
begin
if Valid and Assigned(DstImage) and DstImage.Valid then
begin
@ -514,16 +575,20 @@ begin
DoDataSizeChanged;
end;
procedure TBaseImage.SaveToFile(const FileName: string);
function TBaseImage.SaveToFile(const FileName: string): Boolean;
begin
if Valid then
Imaging.SaveImageToFile(FileName, FPData^);
Result := Imaging.SaveImageToFile(FileName, FPData^)
else
Result := False;
end;
procedure TBaseImage.SaveToStream(const Ext: string; Stream: TStream);
function TBaseImage.SaveToStream(const Ext: string; Stream: TStream): Boolean;
begin
if Valid then
Imaging.SaveImageToStream(Ext, Stream, FPData^);
Result := Imaging.SaveImageToStream(Ext, Stream, FPData^)
else
Result := False;
end;
@ -532,10 +597,10 @@ end;
constructor TSingleImage.Create;
begin
inherited Create;
RecreateImageData(DefaultWidth, DefaultHeight, ifDefault);
Clear;
end;
constructor TSingleImage.CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat);
constructor TSingleImage.CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat);
begin
inherited Create;
RecreateImageData(AWidth, AHeight, AFormat);
@ -544,13 +609,7 @@ end;
constructor TSingleImage.CreateFromData(const AData: TImageData);
begin
inherited Create;
if Imaging.TestImage(AData) then
begin
Imaging.CloneImage(AData, FImageData);
DoDataSizeChanged;
end
else
Create;
AssignFromImageData(AData);
end;
constructor TSingleImage.CreateFromFile(const FileName: string);
@ -580,59 +639,57 @@ procedure TSingleImage.Assign(Source: TPersistent);
begin
if Source = nil then
begin
Create;
Clear;
end
else if Source is TSingleImage then
begin
CreateFromData(TSingleImage(Source).FImageData);
AssignFromImageData(TSingleImage(Source).FImageData);
end
else if Source is TMultiImage then
begin
if TMultiImage(Source).Valid then
CreateFromData(TMultiImage(Source).FPData^)
AssignFromImageData(TMultiImage(Source).FPData^)
else
Assign(nil);
Clear;
end
else
inherited Assign(Source);
end;
procedure TSingleImage.AssignFromImageData(const AImageData: TImageData);
begin
if Imaging.TestImage(AImageData) then
begin
Imaging.CloneImage(AImageData, FImageData);
DoDataSizeChanged;
end
else
Clear;
end;
{ TMultiImage class implementation }
constructor TMultiImage.Create;
begin
SetImageCount(DefaultImages);
SetActiveImage(0);
inherited Create;
end;
constructor TMultiImage.CreateFromParams(AWidth, AHeight: LongInt;
AFormat: TImageFormat; Images: LongInt);
constructor TMultiImage.CreateFromParams(AWidth, AHeight: Integer;
AFormat: TImageFormat; ImageCount: Integer);
var
I: LongInt;
I: Integer;
begin
Imaging.FreeImagesInArray(FDataArray);
SetLength(FDataArray, Images);
SetLength(FDataArray, ImageCount);
for I := 0 to GetImageCount - 1 do
Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[I]);
if GetImageCount > 0 then
SetActiveImage(0);
end;
constructor TMultiImage.CreateFromArray(ADataArray: TDynImageDataArray);
var
I: LongInt;
constructor TMultiImage.CreateFromArray(const ADataArray: TDynImageDataArray);
begin
Imaging.FreeImagesInArray(FDataArray);
SetLength(FDataArray, Length(ADataArray));
for I := 0 to GetImageCount - 1 do
begin
// Clone only valid images
if Imaging.TestImage(ADataArray[I]) then
Imaging.CloneImage(ADataArray[I], FDataArray[I])
else
Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
end;
SetActiveImage(0);
AssignFromArray(ADataArray);
end;
constructor TMultiImage.CreateFromFile(const FileName: string);
@ -651,20 +708,20 @@ begin
inherited Destroy;
end;
procedure TMultiImage.SetActiveImage(Value: LongInt);
procedure TMultiImage.SetActiveImage(Value: Integer);
begin
FActiveImage := Value;
SetPointer;
end;
function TMultiImage.GetImageCount: LongInt;
function TMultiImage.GetImageCount: Integer;
begin
Result := Length(FDataArray);
end;
procedure TMultiImage.SetImageCount(Value: LongInt);
procedure TMultiImage.SetImageCount(Value: Integer);
var
I, OldCount: LongInt;
I, OldCount: Integer;
begin
if Value > GetImageCount then
begin
@ -689,13 +746,13 @@ begin
Result := (GetImageCount > 0) and TestImagesInArray(FDataArray);
end;
function TMultiImage.GetImage(Index: LongInt): TImageData;
function TMultiImage.GetImage(Index: Integer): TImageData;
begin
if (Index >= 0) and (Index < GetImageCount) then
Result := FDataArray[Index];
end;
procedure TMultiImage.SetImage(Index: LongInt; Value: TImageData);
procedure TMultiImage.SetImage(Index: Integer; Value: TImageData);
begin
if (Index >= 0) and (Index < GetImageCount) then
Imaging.CloneImage(Value, FDataArray[Index]);
@ -715,24 +772,27 @@ begin
end;
end;
function TMultiImage.PrepareInsert(Index, Count: LongInt): Boolean;
function TMultiImage.PrepareInsert(Index, InsertCount: Integer): Boolean;
var
I: LongInt;
I: Integer;
OldImageCount, MoveCount: Integer;
begin
OldImageCount := GetImageCount;
// Inserting to empty image will add image at index 0
if GetImageCount = 0 then
if OldImageCount = 0 then
Index := 0;
if (Index >= 0) and (Index <= GetImageCount) and (Count > 0) then
if (Index >= 0) and (Index <= OldImageCount) and (InsertCount > 0) then
begin
SetLength(FDataArray, GetImageCount + Count);
if Index < GetImageCount - 1 then
SetLength(FDataArray, OldImageCount + InsertCount);
if Index < OldImageCount then
begin
// Move imges to new position
System.Move(FDataArray[Index], FDataArray[Index + Count],
(GetImageCount - Count - Index) * SizeOf(TImageData));
// Move images to new position
MoveCount := OldImageCount - Index;
System.Move(FDataArray[Index], FDataArray[Index + InsertCount], MoveCount * SizeOf(TImageData));
// Null old images, not free them!
for I := Index to Index + Count - 1 do
for I := Index to Index + InsertCount - 1 do
InitImage(FDataArray[I]);
end;
Result := True;
@ -741,9 +801,9 @@ begin
Result := False;
end;
procedure TMultiImage.DoInsertImages(Index: LongInt; const Images: TDynImageDataArray);
procedure TMultiImage.DoInsertImages(Index: Integer; const Images: TDynImageDataArray);
var
I, Len: LongInt;
I, Len: Integer;
begin
Len := Length(Images);
if PrepareInsert(Index, Len) then
@ -753,7 +813,7 @@ begin
end;
end;
procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: LongInt;
procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: Integer;
AFormat: TImageFormat);
begin
if PrepareInsert(Index, 1) then
@ -766,38 +826,62 @@ var
begin
if Source = nil then
begin
Create;
ClearAll;
end
else if Source is TMultiImage then
begin
CreateFromArray(TMultiImage(Source).FDataArray);
AssignFromArray(TMultiImage(Source).FDataArray);
SetActiveImage(TMultiImage(Source).ActiveImage);
end
else if Source is TSingleImage then
begin
SetLength(Arr, 1);
Arr[0] := TSingleImage(Source).FImageData;
CreateFromArray(Arr);
Arr := nil;
AssignFromArray(Arr);
end
else
inherited Assign(Source);
end;
procedure TMultiImage.AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat);
procedure TMultiImage.AssignFromArray(const ADataArray: TDynImageDataArray);
var
I: Integer;
begin
DoInsertNew(GetImageCount, AWidth, AHeight, AFormat);
Imaging.FreeImagesInArray(FDataArray);
SetLength(FDataArray, Length(ADataArray));
for I := 0 to GetImageCount - 1 do
begin
// Clone only valid images
if Imaging.TestImage(ADataArray[I]) then
Imaging.CloneImage(ADataArray[I], FDataArray[I])
else
Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
end;
if GetImageCount > 0 then
SetActiveImage(0);
end;
procedure TMultiImage.AddImage(const Image: TImageData);
function TMultiImage.AddImage(AWidth, AHeight: Integer; AFormat: TImageFormat): Integer;
begin
DoInsertImages(GetImageCount, GetArrayFromImageData(Image));
Result := GetImageCount;
DoInsertNew(Result, AWidth, AHeight, AFormat);
end;
procedure TMultiImage.AddImage(Image: TBaseImage);
function TMultiImage.AddImage(const Image: TImageData): Integer;
begin
Result := GetImageCount;
DoInsertImages(Result, GetArrayFromImageData(Image));
end;
function TMultiImage.AddImage(Image: TBaseImage): Integer;
begin
if Assigned(Image) and Image.Valid then
DoInsertImages(GetImageCount, GetArrayFromImageData(Image.FPData^));
begin
Result := GetImageCount;
DoInsertImages(Result, GetArrayFromImageData(Image.FPData^));
end
else
Result := -1;
end;
procedure TMultiImage.AddImages(const Images: TDynImageDataArray);
@ -810,35 +894,35 @@ begin
DoInsertImages(GetImageCount, Images.FDataArray);
end;
procedure TMultiImage.InsertImage(Index, AWidth, AHeight: LongInt;
procedure TMultiImage.InsertImage(Index, AWidth, AHeight: Integer;
AFormat: TImageFormat);
begin
DoInsertNew(Index, AWidth, AHeight, AFormat);
end;
procedure TMultiImage.InsertImage(Index: LongInt; const Image: TImageData);
procedure TMultiImage.InsertImage(Index: Integer; const Image: TImageData);
begin
DoInsertImages(Index, GetArrayFromImageData(Image));
end;
procedure TMultiImage.InsertImage(Index: LongInt; Image: TBaseImage);
procedure TMultiImage.InsertImage(Index: Integer; Image: TBaseImage);
begin
if Assigned(Image) and Image.Valid then
DoInsertImages(Index, GetArrayFromImageData(Image.FPData^));
end;
procedure TMultiImage.InsertImages(Index: LongInt;
procedure TMultiImage.InsertImages(Index: Integer;
const Images: TDynImageDataArray);
begin
DoInsertImages(Index, FDataArray);
DoInsertImages(Index, Images);
end;
procedure TMultiImage.InsertImages(Index: LongInt; Images: TMultiImage);
procedure TMultiImage.InsertImages(Index: Integer; Images: TMultiImage);
begin
DoInsertImages(Index, Images.FDataArray);
end;
procedure TMultiImage.ExchangeImages(Index1, Index2: LongInt);
procedure TMultiImage.ExchangeImages(Index1, Index2: Integer);
var
TempData: TImageData;
begin
@ -851,9 +935,9 @@ begin
end;
end;
procedure TMultiImage.DeleteImage(Index: LongInt);
procedure TMultiImage.DeleteImage(Index: Integer);
var
I: LongInt;
I: Integer;
begin
if (Index >= 0) and (Index < GetImageCount) then
begin
@ -871,20 +955,25 @@ begin
end;
end;
procedure TMultiImage.ClearAll;
begin
ImageCount := 0;
end;
procedure TMultiImage.ConvertImages(Format: TImageFormat);
var
I: LongInt;
I: Integer;
begin
for I := 0 to GetImageCount - 1 do
Imaging.ConvertImage(FDataArray[I], Format);
end;
procedure TMultiImage.ResizeImages(NewWidth, NewHeight: LongInt;
procedure TMultiImage.ResizeImages(NewWidth, NewHeight: Integer;
Filter: TResizeFilter);
var
I: LongInt;
I: Integer;
begin
for I := 0 to GetImageCount do
for I := 0 to GetImageCount - 1 do
Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter);
end;
@ -922,24 +1011,33 @@ begin
SetActiveImage(0);
end;
procedure TMultiImage.SaveMultiToFile(const FileName: string);
function TMultiImage.SaveMultiToFile(const FileName: string): Boolean;
begin
Imaging.SaveMultiImageToFile(FileName, FDataArray);
Result := Imaging.SaveMultiImageToFile(FileName, FDataArray);
end;
procedure TMultiImage.SaveMultiToStream(const Ext: string; Stream: TStream);
function TMultiImage.SaveMultiToStream(const Ext: string; Stream: TStream): Boolean;
begin
Imaging.SaveMultiImageToStream(Ext, Stream, FDataArray);
Result := Imaging.SaveMultiImageToStream(Ext, Stream, FDataArray);
end;
{
File Notes:
File Notes (obsolete):
-- TODOS ----------------------------------------------------
- nothing now
- add SetPalette, create some pal wrapper first
- put all low level stuff here like ReplaceColor etc, change
CopyTo to Copy, and add overload Copy(SrcRect, DstX, DstY) ...
-- 0.77.1 ---------------------------------------------------
- Added TSingleImage.AssignFromData and TMultiImage.AssignFromArray
as a replacement for constructors used as methods (that is
compiler error in Delphi XE3).
- Added TBaseImage.ResizeToFit method.
- Changed TMultiImage to have default state with no images.
- TMultiImage.AddImage now returns index of newly added image.
- Fixed img index bug in TMultiImage.ResizeImages
-- 0.26.5 Changes/Bug Fixes ---------------------------------
- Added MapImageData method to TBaseImage
- Added Empty property to TBaseImage.
- Added Clear method to TBaseImage.
- Added ScanlineSize property to TBaseImage.
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- Added TMultiImage.ReverseImages method.
@ -978,7 +1076,7 @@ end;
-- 0.17 Changes/Bug Fixes -----------------------------------
- added props PaletteEntries and ScanLine to TBaseImage
- aded new constructor to TBaseImage that take TBaseImage source
- added new constructor to TBaseImage that take TBaseImage source
- TMultiImage levels adding and inserting rewritten internally
- added some new functions to TMultiImage: AddLevels, InsertLevels
- added some new functions to TBaseImage: Flip, Mirror, Rotate,

33
Imaging/ImagingColors.pas
View File

@ -1,29 +1,12 @@
{
$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
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains functions for manipulating and converting color values.}
@ -73,6 +56,8 @@ procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
{ Converts YCoCg to RGB color.}
procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
//procedure RGBToHSL(R, G, B: Byte; var H, S, L: Byte);
//procedure HSLToRGB(H, S, L: Byte; var R, G, B: Byte);
implementation
@ -231,7 +216,7 @@ end;
- Fixed RGB>>CMYK conversions.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added RGB<>CMY(K) converion functions for 16 bit channels
- Added RGB<>CMY(K) conversion functions for 16 bit channels
(needed by PSD loading code).
-- 0.21 Changes/Bug Fixes -----------------------------------

342
Imaging/ImagingComponents.pas
View File

@ -1,29 +1,12 @@
{
$Id: ImagingComponents.pas 171 2009-09-02 01:34:19Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains VCL/LCL TGraphic descendant which uses Imaging library
@ -34,27 +17,26 @@ unit ImagingComponents;
interface
{$IFDEF LCL}
{$IF Defined(FPC) and Defined(LCL)}
{$DEFINE COMPONENT_SET_LCL}
{$ENDIF}
{$ELSEIF Defined(DELPHI)}
{$DEFINE COMPONENT_SET_VCL}
{$IFEND}
{$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
// If no component sets should be used just include empty unit.
//DOC-IGNORE-BEGIN
implementation
//DOC-IGNORE-END
{$ELSE}
uses
SysUtils, Types, Classes,
{$IFDEF MSWINDOWS}
Windows,
{$ENDIF}
SysUtils, Types, Classes,
{$IFDEF COMPONENT_SET_VCL}
Graphics,
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
InterfaceBase,
GraphType,
Graphics,
LCLType,
@ -65,18 +47,27 @@ uses
type
{ Graphic class which uses Imaging to load images.
It has standard TBitmap class as ancestor and it can
Assign also to/from TImageData structres and TBaseImage
classes. For saving is uses inherited TBitmap methods.
Assign also to/from TImageData structures and TBaseImage
classes. If you want to perfectly preserve the original pixel format
of the source image then these classes may not for you.
This class is automatically registered to TPicture for all
file extensions supported by Imaging (useful only for loading).
If you just want to load images in various formats you can use this
class or simply use TPicture.LoadFromXXX which will create this class
automatically. For TGraphic class that saves with Imaging look
automatically.
For saving it always uses PNG fallback.
For TGraphic classes that save in different formats look
at TImagingGraphicForSave class.}
TImagingGraphic = class(TBitmap)
protected
procedure ReadDataFromStream(Stream: TStream); virtual;
procedure AssignTo(Dest: TPersistent); override;
{ Called by TFiler when reading and writing TPicture.Data property.
We need to override ReadData+WriteData otherwise inherited ones from
TBitmap would be called resulting in errors.}
procedure ReadData(Stream: TStream); override;
procedure WriteData(Stream: TStream); override;
public
constructor Create; override;
@ -85,6 +76,8 @@ type
even though it is called by descendant class capable of
saving only one file format.}
procedure LoadFromStream(Stream: TStream); override;
{ Always saves as PNG.}
procedure SaveToStream(Stream: TStream); override;
{ Copies the image contained in Source to this graphic object.
Supports also TBaseImage descendants from ImagingClasses unit. }
procedure Assign(Source: TPersistent); override;
@ -96,21 +89,32 @@ type
procedure AssignFromImageData(const ImageData: TImageData);
{ Copies the current image to TImageData structure.}
procedure AssignToImageData(var ImageData: TImageData);
{$IFDEF COMPONENT_SET_LCL}
{ Needed for TGraphic.LoadFromResourceName() to work.
We return RT_RCDATA here. Also for TImagingBitmap since
RT_BITMAP is stored differently than bitmap on disk (no BITMAPFILEHEADER).}
function GetResourceType: TResourceType; override;
{ Used by TPicture.LoadFromStream to find the right TGraphic class for streams. }
class function IsStreamFormatSupported(Stream: TStream): boolean; override;
{$ENDIF}
end;
TImagingGraphicClass = class of TImagingGraphic;
{ Base class for file format specific TGraphic classes that use
{ Base (abstract) class for file format specific TGraphic classes that use
Imaging for saving. Each descendant class can load all file formats
supported by Imaging but save only one format (TImagingBitmap
for *.bmp, TImagingJpeg for *.jpg). Format specific classes also
allow easy access to Imaging options that affect saving of files
(they are properties here).}
for *.bmp, TImagingJpeg for *.jpg). The image is saved in this one file
format regardless of the extension you request).
Format specific classes also allow easy access to Imaging options that
affect saving of files (they are properties here).}
TImagingGraphicForSave = class(TImagingGraphic)
protected
FDefaultFileExt: string;
FSavingFormat: TImageFormat;
procedure WriteDataToStream(Stream: TStream); virtual;
procedure WriteData(Stream: TStream); override;
public
constructor Create; override;
{ Saves the current image to the stream. It is saved in the
@ -133,7 +137,7 @@ type
{$IFNDEF DONT_LINK_BITMAP}
{ TImagingGraphic descendant for loading/saving Windows bitmaps.
VCL/CLX/LCL all have native support for bitmaps so you might
VCL/LCL both have native support for bitmaps so you might
want to disable this class (although you can save bitmaps with
RLE compression with this class).}
TImagingBitmap = class(TImagingGraphicForSave)
@ -208,20 +212,20 @@ type
{$ENDIF}
{$IFNDEF DONT_LINK_DDS}
{ Compresssion type used when saving DDS files by TImagingDds.}
TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5);
{ Compression type used when saving DDS files by TImagingDds.}
TDDSCompression = (dcNone, dcDXT1, dcDXT3, dcDXT5);
{ TImagingGraphic descendant for loading/saving DDS images.}
TImagingDDS = class(TImagingGraphicForSave)
protected
FCompression: TDDSCompresion;
FCompression: TDDSCompression;
public
constructor Create; override;
procedure SaveToStream(Stream: TStream); override;
class function GetFileFormat: TImageFileFormat; override;
{ You can choose compression type used when saving DDS file.
dcNone means that file will be saved in the current bitmaps pixel format.}
property Compression: TDDSCompresion read FCompression write FCompression;
property Compression: TDDSCompression read FCompression write FCompression;
end;
{$ENDIF}
@ -299,13 +303,19 @@ procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap);
When Image is TMultiImage only the current image level is overwritten.}
procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage);
{ Displays image onto TCanvas to rectangle DstRect. This procedure
draws image without converting from Imaging format to TBitmap.
Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
when you want displaying images that change frequently (because converting to
TBitmap by ConvertImageDataToBitmap is generally slow).}
procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData); overload;
{ Displays image stored in TImageData structure onto TCanvas. This procedure
draws image without converting from Imaging format to TBitmap.
Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
when you want displaying images that change frequently (because converting to
TBitmap by ConvertImageDataToBitmap is generally slow). Dest and Src
rectangles represent coordinates in the form (X1, Y1, X2, Y2).}
procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); overload;
{ Displays image onto TCanvas at position [DstX, DstY]. This procedure
draws image without converting from Imaging format to TBitmap.
Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
@ -331,14 +341,19 @@ procedure DisplayImage(DstCanvas: TCanvas; const DstRect: TRect; Image: TBaseIma
procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
{$ENDIF}
procedure RegisterTypes;
implementation
uses
{$IF Defined(LCL)}
InterfaceBase,
{$IF Defined(LCLGTK2)}
GLib2, GDK2, GTK2, Gtk2Def, Gtk2Proc,
{$ELSEIF Defined(LCLGTK)}
GDK, GTK, GTKDef, GTKProc,
GLib2, GDK2, GTK2, GTK2Def, GTK2Proc,
{$ELSEIF Defined(LCLqt5)}
Qt5, qtobjects,
{$ELSEIF Defined(LCLcocoa)}
CocoaGDIObjects, CocoaUtils,
{$IFEND}
{$IFEND}
{$IFNDEF DONT_LINK_BITMAP}
@ -359,7 +374,7 @@ uses
{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
ImagingNetworkGraphics,
{$IFEND}
ImagingUtility;
ImagingFormats, ImagingUtility;
resourcestring
SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s';
@ -368,7 +383,13 @@ resourcestring
SUnsupportedLCLWidgetSet = 'This function is not implemented for current LCL widget set';
SImagingGraphicName = 'Imaging Graphic AllInOne';
{ Registers types to VCL/LCL.}
var
RegisteredFormats: TList;
RegisteredGraphicsClasses: Boolean = False;
{ Registers types to VCL/LCL.
In some cases (base+ext package installed in Lazarus) RegisterTypes can be
called twice so must keep track of which formats were already registered. }
procedure RegisterTypes;
var
I: LongInt;
@ -377,10 +398,16 @@ var
var
I: LongInt;
begin
if RegisteredFormats.IndexOf(Format) >= 0 then
Exit;
for I := 0 to Format.Extensions.Count - 1 do
begin
TPicture.RegisterFileFormat(Format.Extensions[I], SImagingGraphicName,
TImagingGraphic);
end;
RegisteredFormats.Add(Format);
end;
procedure RegisterFileFormat(AClass: TImagingGraphicForSaveClass);
var
@ -396,6 +423,9 @@ begin
RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I));
Classes.RegisterClass(TImagingGraphic);
if RegisteredGraphicsClasses then
Exit;
{$IFNDEF DONT_LINK_TARGA}
RegisterFileFormat(TImagingTarga);
Classes.RegisterClass(TImagingTarga);
@ -418,7 +448,7 @@ begin
{$ENDIF}
{$IFNDEF DONT_LINK_PNG}
{$IFDEF COMPONENT_SET_LCL}
// Unregister Lazarus´ default PNG loader which crashes on some PNG files
// Unregister Lazarus default PNG loader which crashes on some PNG files
TPicture.UnregisterGraphicClass(TPortableNetworkGraphic);
{$ENDIF}
RegisterFileFormat(TImagingPNG);
@ -432,6 +462,8 @@ begin
RegisterFileFormat(TImagingBitmap);
Classes.RegisterClass(TImagingBitmap);
{$ENDIF}
RegisteredGraphicsClasses := True;
end;
{ Unregisters types from VCL/LCL.}
@ -495,11 +527,11 @@ end;
procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap);
var
I, LineBytes: LongInt;
PF: TPixelFormat;
Info: TImageFormatInfo;
WorkData: TImageData;
{$IFDEF COMPONENT_SET_VCL}
I, LineBytes: LongInt;
LogPalette: TMaxLogPalette;
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
@ -509,6 +541,14 @@ var
begin
PF := DataFormatToPixelFormat(Data.Format);
GetImageFormatInfo(Data.Format, Info);
if (PF = pf8bit) and PaletteHasAlpha(Data.Palette, Info.PaletteEntries) then
begin
// Some indexed images may have valid alpha data, don't lose it!
// (e.g. transparent 8bit PNG or GIF images)
PF := pfCustom;
end;
if PF = pfCustom then
begin
// Convert from formats not supported by Graphics unit
@ -517,6 +557,7 @@ begin
if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then
Imaging.ConvertImage(WorkData, ifA8R8G8B8)
else
begin
{$IFDEF COMPONENT_SET_VCL}
if Info.IsIndexed or Info.HasGrayChannel then
Imaging.ConvertImage(WorkData, ifIndex8)
@ -527,6 +568,7 @@ begin
{$ELSE}
Imaging.ConvertImage(WorkData, ifA8R8G8B8);
{$ENDIF}
end;
PF := DataFormatToPixelFormat(WorkData.Format);
GetImageFormatInfo(WorkData.Format, Info);
@ -537,8 +579,6 @@ begin
if PF = pfCustom then
RaiseImaging(SBadFormatDataToBitmap, [ImageToStr(WorkData)]);
LineBytes := WorkData.Width * Info.BytesPerPixel;
{$IFDEF COMPONENT_SET_VCL}
Bitmap.Width := WorkData.Width;
Bitmap.Height := WorkData.Height;
@ -559,17 +599,19 @@ begin
end;
Bitmap.Palette := CreatePalette(PLogPalette(@LogPalette)^);
end;
// Copy scanlines
LineBytes := WorkData.Width * Info.BytesPerPixel;
for I := 0 to WorkData.Height - 1 do
Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes);
// Delphi 2009 and newer support alpha transparency fro TBitmap
// Delphi 2009 and newer support alpha transparency for TBitmap
{$IF Defined(DELPHI) and (CompilerVersion >= 20.0)}
if Bitmap.PixelFormat = pf32bit then
Bitmap.AlphaFormat := afDefined;
{$IFEND}
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
// Create 32bit raw image from image data
FillChar(RawImage, SizeOf(RawImage), 0);
@ -621,13 +663,14 @@ var
LineLazBytes: LongInt;
{$ENDIF}
begin
Format := ifUnknown;
{$IFDEF COMPONENT_SET_LCL}
// In the current Lazarus 0.9.10 Bitmap.PixelFormat property is useless.
// We cannot change bitmap's format by changing it (it will just release
// old image but not convert it to new format) nor we can determine bitmaps's
// current format (it is usually set to pfDevice). So bitmap's format is obtained
// trough RawImage api and cannot be changed to mirror some Imaging format
// (so formats with no coresponding Imaging format cannot be saved now).
// (so formats with no corresponding Imaging format cannot be saved now).
if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then
case RawImage.Description.BitsPerPixel of
@ -641,8 +684,6 @@ begin
32: Format := ifA8R8G8B8;
48: Format := ifR16G16B16;
64: Format := ifA16R16G16B16;
else
Format := ifUnknown;
end;
{$ELSE}
Format := PixelFormatToDataFormat(Bitmap.PixelFormat);
@ -693,9 +734,14 @@ begin
RawImage.Description.LineEnd);
// Copy scanlines
for I := 0 to Data.Height - 1 do
begin
Move(PByteArray(RawImage.Data)[I * LineLazBytes],
PByteArray(Data.Bits)[I * LineBytes], LineBytes);
{ If you get complitation error here upgrade to Lazarus 0.9.24+ }
end;
// May need to swap RB order, depends on widget set
if RawImage.Description.BlueShift > RawImage.Description.RedShift then
SwapChannels(Data, ChannelRed, ChannelBlue);
RawImage.FreeData;
end;
{$ENDIF}
@ -745,7 +791,7 @@ begin
DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left,
Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY) <> Height then
begin
// StretchDIBits may fail on some ocassions (error 487, http://support.microsoft.com/kb/269585).
// StretchDIBits may fail on some occasions (error 487, http://support.microsoft.com/kb/269585).
// This fallback is slow but works every time. Thanks to Sergey Galezdinov for the fix.
Bmp := TBitmap.Create;
try
@ -763,13 +809,17 @@ begin
end;
{$ENDIF}
procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData);
begin
DisplayImageData(DstCanvas, DstRect, ImageData, Rect(0, 0, ImageData.Width, ImageData.Height));
end;
procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
{$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32
begin
DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect);
end;
{$ELSEIF Defined(LCLGTK) or Defined(LCLGTK2)}
{$ELSEIF Defined(LCLGTK2)}
procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
SrcWidth, SrcHeight: Integer; ImageData: TImageData);
var
@ -778,9 +828,19 @@ end;
P := TGtkDeviceContext(Dest).Offset;
Inc(DstX, P.X);
Inc(DstY, P.Y);
if ImageData.Format = ifR8G8B8 then
begin
gdk_draw_rgb_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC,
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
@PUInt32Array(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 3);
end
else
begin
gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC,
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
@PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
@PUInt32Array(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
end;
end;
var
@ -790,9 +850,10 @@ var
begin
if TestImage(ImageData) then
begin
Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay);
InitImage(DisplayImage);
if not (ImageData.Format in [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8]) then
raise EImagingError.Create(SBadFormatDisplay);
InitImage(DisplayImage);
SrcBounds := RectToBounds(SrcRect);
DstBounds := RectToBounds(DstRect);
WidgetSet.GetClipBox(DstCanvas.Handle, @DstClip);
@ -809,7 +870,7 @@ begin
if (SrcBounds.Right = NewWidth) and (SrcBounds.Bottom = NewHeight) then
try
CloneImage(ImageData, DisplayImage);
// Swap R-B channels for GTK display compatability!
// Swap R-B channels for GTK display compatibility!
SwapChannels(DisplayImage, ChannelRed, ChannelBlue);
GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top,
SrcBounds.Left, SrcBounds.Top, NewWidth, NewHeight, DisplayImage);
@ -823,7 +884,7 @@ begin
// Stretch pixels from old image to new one TResizeFilter = (rfNearest, rfBilinear, rfBicubic);
StretchRect(ImageData, SrcBounds.Left, SrcBounds.Top, SrcBounds.Right,
SrcBounds.Bottom, DisplayImage, 0, 0, NewWidth, NewHeight, rfNearest);
// Swap R-B channels for GTK display compatability!
// Swap R-B channels for GTK display compatibility!
SwapChannels(DisplayImage, ChannelRed, ChannelBlue);
GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, 0, 0,
NewWidth, NewHeight, DisplayImage);
@ -833,9 +894,53 @@ begin
end;
end;
end;
{$ELSEIF Defined(LCLqt5)}
var
QImage: TQtImage;
Context: TQtDeviceContext;
begin
if TestImage(ImageData) then
begin
if not (ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8]) then
raise EImagingError.Create(SBadFormatDisplay);
Context := TQtDeviceContext(DstCanvas.Handle);
// QImage directly uses the image memory, there is no copy done
QImage := TQtImage.Create(ImageData.Bits, ImageData.Width, ImageData.Height,
ImageData.Width * 4, QImageFormat_ARGB32, False);
try
QPainter_drawImage(Context.Widget, PRect(@DstRect), QImage.Handle, @SrcRect, QtAutoColor);
finally
QImage.Free;
end;
end;
end;
{$ELSEIF Defined(LCLcocoa)}
var
CocoaBmp: TCocoaBitmap;
Context: TCocoaContext;
begin
if TestImage(ImageData) then
begin
if not (ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8]) then
raise EImagingError.Create(SBadFormatDisplay);
Context := CheckDC(DstCanvas.Handle);
// We copy the data since it needs R/B swap and potentially alpha pre-multiply
CocoaBmp := TCocoaBitmap.Create(ImageData.Width, ImageData.Height, 32, 32,
cbaDWord, cbtBGRA, ImageData.Bits, True);
try
Context.DrawImageRep(RectToNSRect(DstRect), RectToNSRect(SrcRect), CocoaBmp.ImageRep);
finally
CocoaBmp.Free;
end;
end;
end;
{$ELSE}
begin
raise Exception.Create(SUnsupportedLCLWidgetSet);
raise EImagingError.Create(SUnsupportedLCLWidgetSet);
end;
{$IFEND}
@ -864,12 +969,27 @@ begin
PixelFormat := pf24Bit;
end;
procedure TImagingGraphic.LoadFromStream(Stream: TStream);
procedure TImagingGraphic.ReadData(Stream: TStream);
begin
ReadDataFromStream(Stream);
// Here we need to skip ReadData+WriteData of TBitmap (and LCL TRasterBitmap)
// and go to the basics in TGraphic's ReadData+WriteData with just LoadFromStream
// and SaveToStream.
// Some VCL/LCL TGraphic classes also store size of the written data
// before the stream contents. However, the stream passed here
// from TReader.DefineBinaryProperty is already
// a memory stream capped to the size of binary property data.
// Picture.Data = <vaBinary><Size(TWriter)><TGraphicClassName(TPicture)><ImageBits(TImagingGraphicForSave)>
LoadFromStream(Stream);
end;
procedure TImagingGraphic.ReadDataFromStream(Stream: TStream);
procedure TImagingGraphic.WriteData(Stream: TStream);
begin
// This can happen when streaming some of the formats that don't have
// TImagingGraphicForSave descendant.
SaveToStream(Stream);
end;
procedure TImagingGraphic.LoadFromStream(Stream: TStream);
var
Image: TSingleImage;
begin
@ -882,6 +1002,19 @@ begin
end;
end;
procedure TImagingGraphic.SaveToStream(Stream: TStream);
var
Image: TSingleImage;
begin
Image := TSingleImage.Create;
try
Image.Assign(Self);
Image.SaveToStream('png', Stream);
finally
Image.Free;
end;
end;
procedure TImagingGraphic.AssignTo(Dest: TPersistent);
var
Arr: TDynImageDataArray;
@ -901,6 +1034,18 @@ begin
inherited AssignTo(Dest);
end;
{$IFDEF COMPONENT_SET_LCL}
function TImagingGraphic.GetResourceType: TResourceType;
begin
Result := RT_RCDATA;
end;
class function TImagingGraphic.IsStreamFormatSupported(Stream: TStream): Boolean;
begin
Result := DetermineStreamFormat(Stream) <> '';
end;
{$ENDIF}
procedure TImagingGraphic.Assign(Source: TPersistent);
begin
if Source is TBaseImage then
@ -933,7 +1078,6 @@ begin
ConvertBitmapToData(Self, ImageData);
end;
{ TImagingGraphicForSave class implementation }
constructor TImagingGraphicForSave.Create;
@ -944,7 +1088,12 @@ begin
GetFileFormat.CheckOptionsValidity;
end;
procedure TImagingGraphicForSave.WriteDataToStream(Stream: TStream);
procedure TImagingGraphicForSave.WriteData(Stream: TStream);
begin
SaveToStream(Stream);
end;
procedure TImagingGraphicForSave.SaveToStream(Stream: TStream);
var
Image: TSingleImage;
begin
@ -962,11 +1111,6 @@ begin
end;
end;
procedure TImagingGraphicForSave.SaveToStream(Stream: TStream);
begin
WriteDataToStream(Stream);
end;
{$IFDEF COMPONENT_SET_LCL}
class function TImagingGraphicForSave.GetFileExtensions: string;
begin
@ -980,9 +1124,6 @@ end;
{$ENDIF}
{$IFNDEF DONT_LINK_BITMAP}
{ TImagingBitmap class implementation }
constructor TImagingBitmap.Create;
begin
inherited Create;
@ -1004,9 +1145,6 @@ end;
{$ENDIF}
{$IFNDEF DONT_LINK_JPEG}
{ TImagingJpeg class implementation }
constructor TImagingJpeg.Create;
begin
inherited Create;
@ -1038,9 +1176,6 @@ end;
{$ENDIF}
{$IFNDEF DONT_LINK_PNG}
{ TImagingPNG class implementation }
constructor TImagingPNG.Create;
begin
inherited Create;
@ -1064,20 +1199,13 @@ end;
{$ENDIF}
{$IFNDEF DONT_LINK_GIF}
{ TImagingGIF class implementation}
class function TImagingGIF.GetFileFormat: TImageFileFormat;
begin
Result := FindImageFileFormatByClass(TGIFFileFormat);
end;
{$ENDIF}
{$IFNDEF DONT_LINK_TARGA}
{ TImagingTarga class implementation }
constructor TImagingTarga.Create;
begin
inherited Create;
@ -1099,9 +1227,6 @@ end;
{$ENDIF}
{$IFNDEF DONT_LINK_DDS}
{ TImagingDDS class implementation }
constructor TImagingDDS.Create;
begin
inherited Create;
@ -1132,9 +1257,6 @@ end;
{$ENDIF}
{$IFNDEF DONT_LINK_MNG}
{ TImagingMNG class implementation }
constructor TImagingMNG.Create;
begin
inherited Create;
@ -1173,9 +1295,6 @@ end;
{$ENDIF}
{$IFNDEF DONT_LINK_JNG}
{ TImagingJNG class implementation }
constructor TImagingJNG.Create;
begin
inherited Create;
@ -1205,17 +1324,26 @@ end;
{$ENDIF}
initialization
RegisteredFormats := TList.Create;
RegisterTypes;
finalization
UnRegisterTypes;
RegisteredFormats.Free;
{$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.77.1 ---------------------------------------------------
- Fixed bug in ConvertBitmapToData causing images from GTK2 bitmaps
to have swapped RB channels.
- LCL: Removed GTK1 support (deprecated).
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Transparency of 8bit images (like loaded from 8bit PNG or GIF) is
kept intact during conversion to TBitmap in ConvertDataToBitmap
(32bit bitmap is created).
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Setting AlphaFormat property of TBitmap in ConvertDataToBitmap
@ -1236,7 +1364,7 @@ finalization
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus
with GTK2 target.
- Added commnets with code for Lazarus rev. 11861+ regarding
- Added comments with code for Lazarus rev. 11861+ regarding
RawImage interface. Replace current code with that in comments
if you use Lazarus from SVN. New RawImage interface will be used by
default after next Lazarus release.
@ -1258,7 +1386,7 @@ finalization
- added procedures: ConvertImageToBitmap and ConvertBitmapToImage
-- 0.17 Changes/Bug Fixes -----------------------------------
- LCL data to bitmap conversion didn´t work in Linux, fixed
- LCL data to bitmap conversion didn't work in Linux, fixed
- added MNG file format
- added JNG file format

449
Imaging/ImagingDds.pas
View File

@ -1,29 +1,12 @@
{
$Id: ImagingDds.pas 129 2008-08-06 20:01:30Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains image format loader/saver for DirectDraw Surface images.}
@ -38,11 +21,11 @@ uses
type
{ Class for loading and saving Microsoft DirectDraw surfaces.
It can load/save all D3D formats which have coresponding
It can load/save all D3D formats which have corresponding
TImageFormat. It supports plain textures, cube textures and
volume textures, all of these can have mipmaps. It can also
load some formats which have no exact TImageFormat, but can be easily
converted to one (bump map formats).
converted to one (bump map formats, etc.).
You can get some information about last loaded DDS file by calling
GetOption with ImagingDDSLoadedXXX options and you can set some
saving options by calling SetOption with ImagingDDSSaveXXX or you can
@ -51,7 +34,7 @@ type
at least number of images to build cube/volume based on current
Depth and MipMapCount settings.}
TDDSFileFormat = class(TImageFileFormat)
protected
private
FLoadedCubeMap: LongBool;
FLoadedVolume: LongBool;
FLoadedMipMapCount: LongInt;
@ -62,6 +45,8 @@ type
FSaveDepth: LongInt;
procedure ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt;
IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt);
protected
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
@ -69,7 +54,6 @@ type
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
procedure CheckOptionsValidity; override;
published
@ -94,6 +78,17 @@ type
property SaveDepth: LongInt read FSaveDepth write FSaveDepth;
end;
const
{ DDS related metadata Ids }
{ DXGI format of textures stored in DDS files with DX10 extension. Type is
Enum (value corresponding to DXGI_FORMAT enum from DX SDK).}
SMetaDdsDxgiFormat = 'DdsDxgiFormat';
{ Number of mipmaps for each main image in DDS file.}
SMetaDdsMipMapCount = 'DdsMipMapCount';
{ Texture array size stored in DDS file (DX10 extension).}
SMetaDdsArraySize = 'DdsArraySize';
implementation
const
@ -106,18 +101,20 @@ const
const
{ Four character codes.}
DDSMagic = LongWord(Byte('D') or (Byte('D') shl 8) or (Byte('S') shl 16) or
DDSMagic = UInt32(Byte('D') or (Byte('D') shl 8) or (Byte('S') shl 16) or
(Byte(' ') shl 24));
FOURCC_DXT1 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
FOURCC_DXT1 = UInt32(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
(Byte('1') shl 24));
FOURCC_DXT3 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
FOURCC_DXT3 = UInt32(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
(Byte('3') shl 24));
FOURCC_DXT5 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
FOURCC_DXT5 = UInt32(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
(Byte('5') shl 24));
FOURCC_ATI1 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
FOURCC_ATI1 = UInt32(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
(Byte('1') shl 24));
FOURCC_ATI2 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
FOURCC_ATI2 = UInt32(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
(Byte('2') shl 24));
FOURCC_DX10 = UInt32(Byte('D') or (Byte('X') shl 8) or (Byte('1') shl 16) or
(Byte('0') shl 24));
{ Some D3DFORMAT values used in DDS files as FourCC value.}
D3DFMT_A16B16G16R16 = 36;
@ -126,7 +123,7 @@ const
D3DFMT_R16F = 111;
D3DFMT_A16B16G16R16F = 113;
{ Constans used by TDDSurfaceDesc2.Flags.}
{ Constants used by TDDSurfaceDesc2.Flags.}
DDSD_CAPS = $00000001;
DDSD_HEIGHT = $00000002;
DDSD_WIDTH = $00000004;
@ -136,7 +133,7 @@ const
DDSD_LINEARSIZE = $00080000;
DDSD_DEPTH = $00800000;
{ Constans used by TDDSPixelFormat.Flags.}
{ Constants used by TDDSPixelFormat.Flags.}
DDPF_ALPHAPIXELS = $00000001; // used by formats which contain alpha
DDPF_FOURCC = $00000004; // used by DXT and large ARGB formats
DDPF_RGB = $00000040; // used by RGB formats
@ -144,12 +141,12 @@ const
DDPF_BUMPLUMINANCE = $00040000; // used by mixed signed-unsigned formats
DDPF_BUMPDUDV = $00080000; // used by signed formats
{ Constans used by TDDSCaps.Caps1.}
{ Constants used by TDDSCaps.Caps1.}
DDSCAPS_COMPLEX = $00000008;
DDSCAPS_TEXTURE = $00001000;
DDSCAPS_MIPMAP = $00400000;
{ Constans used by TDDSCaps.Caps2.}
{ Constants used by TDDSCaps.Caps2.}
DDSCAPS2_CUBEMAP = $00000200;
DDSCAPS2_POSITIVEX = $00000400;
DDSCAPS2_NEGATIVEX = $00000800;
@ -166,56 +163,191 @@ const
type
{ Stores the pixel format information.}
TDDPixelFormat = packed record
Size: LongWord; // Size of the structure = 32 bytes
Flags: LongWord; // Flags to indicate valid fields
FourCC: LongWord; // Four-char code for compressed textures (DXT)
BitCount: LongWord; // Bits per pixel if uncomp. usually 16,24 or 32
RedMask: LongWord; // Bit mask for the Red component
GreenMask: LongWord; // Bit mask for the Green component
BlueMask: LongWord; // Bit mask for the Blue component
AlphaMask: LongWord; // Bit mask for the Alpha component
Size: UInt32; // Size of the structure = 32 bytes
Flags: UInt32; // Flags to indicate valid fields
FourCC: UInt32; // Four-char code for compressed textures (DXT)
BitCount: UInt32; // Bits per pixel if uncomp. usually 16,24 or 32
RedMask: UInt32; // Bit mask for the Red component
GreenMask: UInt32; // Bit mask for the Green component
BlueMask: UInt32; // Bit mask for the Blue component
AlphaMask: UInt32; // Bit mask for the Alpha component
end;
{ Specifies capabilities of surface.}
TDDSCaps = packed record
Caps1: LongWord; // Should always include DDSCAPS_TEXTURE
Caps2: LongWord; // For cubic environment maps
Reserved: array[0..1] of LongWord; // Reserved
Caps1: UInt32; // Should always include DDSCAPS_TEXTURE
Caps2: UInt32; // For cubic environment maps
Reserved: array[0..1] of UInt32; // Reserved
end;
{ Record describing DDS file contents.}
TDDSurfaceDesc2 = packed record
Size: LongWord; // Size of the structure = 124 Bytes
Flags: LongWord; // Flags to indicate valid fields
Height: LongWord; // Height of the main image in pixels
Width: LongWord; // Width of the main image in pixels
PitchOrLinearSize: LongWord; // For uncomp formats number of bytes per
Size: UInt32; // Size of the structure = 124 Bytes
Flags: UInt32; // Flags to indicate valid fields
Height: UInt32; // Height of the main image in pixels
Width: UInt32; // Width of the main image in pixels
PitchOrLinearSize: UInt32; // For uncomp formats number of bytes per
// scanline. For comp it is the size in
// bytes of the main image
Depth: LongWord; // Only for volume text depth of the volume
MipMaps: LongInt; // Total number of levels in the mipmap chain
Reserved1: array[0..10] of LongWord; // Reserved
Depth: UInt32; // Only for volume text depth of the volume
MipMaps: Int32; // Total number of levels in the mipmap chain
Reserved1: array[0..10] of UInt32; // Reserved
PixelFormat: TDDPixelFormat; // Format of the pixel data
Caps: TDDSCaps; // Capabilities
Reserved2: LongWord; // Reserved
Reserved2: UInt32; // Reserved
end;
{ DDS file header.}
TDDSFileHeader = packed record
Magic: LongWord; // File format magic
Magic: UInt32; // File format magic
Desc: TDDSurfaceDesc2; // Surface description
end;
{ Resource types for D3D 10+ }
TD3D10ResourceDimension = (
D3D10_RESOURCE_DIMENSION_UNKNOWN = 0,
D3D10_RESOURCE_DIMENSION_BUFFER = 1,
D3D10_RESOURCE_DIMENSION_TEXTURE1D = 2,
D3D10_RESOURCE_DIMENSION_TEXTURE2D = 3,
D3D10_RESOURCE_DIMENSION_TEXTURE3D = 4
);
{ Texture formats for D3D 10+ }
TDXGIFormat = (
DXGI_FORMAT_UNKNOWN = 0,
DXGI_FORMAT_R32G32B32A32_TYPELESS = 1,
DXGI_FORMAT_R32G32B32A32_FLOAT = 2,
DXGI_FORMAT_R32G32B32A32_UINT = 3,
DXGI_FORMAT_R32G32B32A32_SINT = 4,
DXGI_FORMAT_R32G32B32_TYPELESS = 5,
DXGI_FORMAT_R32G32B32_FLOAT = 6,
DXGI_FORMAT_R32G32B32_UINT = 7,
DXGI_FORMAT_R32G32B32_SINT = 8,
DXGI_FORMAT_R16G16B16A16_TYPELESS = 9,
DXGI_FORMAT_R16G16B16A16_FLOAT = 10,
DXGI_FORMAT_R16G16B16A16_UNORM = 11,
DXGI_FORMAT_R16G16B16A16_UINT = 12,
DXGI_FORMAT_R16G16B16A16_SNORM = 13,
DXGI_FORMAT_R16G16B16A16_SINT = 14,
DXGI_FORMAT_R32G32_TYPELESS = 15,
DXGI_FORMAT_R32G32_FLOAT = 16,
DXGI_FORMAT_R32G32_UINT = 17,
DXGI_FORMAT_R32G32_SINT = 18,
DXGI_FORMAT_R32G8X24_TYPELESS = 19,
DXGI_FORMAT_D32_FLOAT_S8X24_UINT = 20,
DXGI_FORMAT_R32_FLOAT_X8X24_TYPELESS = 21,
DXGI_FORMAT_X32_TYPELESS_G8X24_UINT = 22,
DXGI_FORMAT_R10G10B10A2_TYPELESS = 23,
DXGI_FORMAT_R10G10B10A2_UNORM = 24,
DXGI_FORMAT_R10G10B10A2_UINT = 25,
DXGI_FORMAT_R11G11B10_FLOAT = 26,
DXGI_FORMAT_R8G8B8A8_TYPELESS = 27,
DXGI_FORMAT_R8G8B8A8_UNORM = 28,
DXGI_FORMAT_R8G8B8A8_UNORM_SRGB = 29,
DXGI_FORMAT_R8G8B8A8_UINT = 30,
DXGI_FORMAT_R8G8B8A8_SNORM = 31,
DXGI_FORMAT_R8G8B8A8_SINT = 32,
DXGI_FORMAT_R16G16_TYPELESS = 33,
DXGI_FORMAT_R16G16_FLOAT = 34,
DXGI_FORMAT_R16G16_UNORM = 35,
DXGI_FORMAT_R16G16_UINT = 36,
DXGI_FORMAT_R16G16_SNORM = 37,
DXGI_FORMAT_R16G16_SINT = 38,
DXGI_FORMAT_R32_TYPELESS = 39,
DXGI_FORMAT_D32_FLOAT = 40,
DXGI_FORMAT_R32_FLOAT = 41,
DXGI_FORMAT_R32_UINT = 42,
DXGI_FORMAT_R32_SINT = 43,
DXGI_FORMAT_R24G8_TYPELESS = 44,
DXGI_FORMAT_D24_UNORM_S8_UINT = 45,
DXGI_FORMAT_R24_UNORM_X8_TYPELESS = 46,
DXGI_FORMAT_X24_TYPELESS_G8_UINT = 47,
DXGI_FORMAT_R8G8_TYPELESS = 48,
DXGI_FORMAT_R8G8_UNORM = 49,
DXGI_FORMAT_R8G8_UINT = 50,
DXGI_FORMAT_R8G8_SNORM = 51,
DXGI_FORMAT_R8G8_SINT = 52,
DXGI_FORMAT_R16_TYPELESS = 53,
DXGI_FORMAT_R16_FLOAT = 54,
DXGI_FORMAT_D16_UNORM = 55,
DXGI_FORMAT_R16_UNORM = 56,
DXGI_FORMAT_R16_UINT = 57,
DXGI_FORMAT_R16_SNORM = 58,
DXGI_FORMAT_R16_SINT = 59,
DXGI_FORMAT_R8_TYPELESS = 60,
DXGI_FORMAT_R8_UNORM = 61,
DXGI_FORMAT_R8_UINT = 62,
DXGI_FORMAT_R8_SNORM = 63,
DXGI_FORMAT_R8_SINT = 64,
DXGI_FORMAT_A8_UNORM = 65,
DXGI_FORMAT_R1_UNORM = 66,
DXGI_FORMAT_R9G9B9E5_SHAREDEXP = 67,
DXGI_FORMAT_R8G8_B8G8_UNORM = 68,
DXGI_FORMAT_G8R8_G8B8_UNORM = 69,
DXGI_FORMAT_BC1_TYPELESS = 70,
DXGI_FORMAT_BC1_UNORM = 71,
DXGI_FORMAT_BC1_UNORM_SRGB = 72,
DXGI_FORMAT_BC2_TYPELESS = 73,
DXGI_FORMAT_BC2_UNORM = 74,
DXGI_FORMAT_BC2_UNORM_SRGB = 75,
DXGI_FORMAT_BC3_TYPELESS = 76,
DXGI_FORMAT_BC3_UNORM = 77,
DXGI_FORMAT_BC3_UNORM_SRGB = 78,
DXGI_FORMAT_BC4_TYPELESS = 79,
DXGI_FORMAT_BC4_UNORM = 80,
DXGI_FORMAT_BC4_SNORM = 81,
DXGI_FORMAT_BC5_TYPELESS = 82,
DXGI_FORMAT_BC5_UNORM = 83,
DXGI_FORMAT_BC5_SNORM = 84,
DXGI_FORMAT_B5G6R5_UNORM = 85,
DXGI_FORMAT_B5G5R5A1_UNORM = 86,
DXGI_FORMAT_B8G8R8A8_UNORM = 87,
DXGI_FORMAT_B8G8R8X8_UNORM = 88,
DXGI_FORMAT_R10G10B10_XR_BIAS_A2_UNORM = 89,
DXGI_FORMAT_B8G8R8A8_TYPELESS = 90,
DXGI_FORMAT_B8G8R8A8_UNORM_SRGB = 91,
DXGI_FORMAT_B8G8R8X8_TYPELESS = 92,
DXGI_FORMAT_B8G8R8X8_UNORM_SRGB = 93,
DXGI_FORMAT_BC6H_TYPELESS = 94,
DXGI_FORMAT_BC6H_UF16 = 95,
DXGI_FORMAT_BC6H_SF16 = 96,
DXGI_FORMAT_BC7_TYPELESS = 97,
DXGI_FORMAT_BC7_UNORM = 98,
DXGI_FORMAT_BC7_UNORM_SRGB = 99,
DXGI_FORMAT_AYUV = 100,
DXGI_FORMAT_Y410 = 101,
DXGI_FORMAT_Y416 = 102,
DXGI_FORMAT_NV12 = 103,
DXGI_FORMAT_P010 = 104,
DXGI_FORMAT_P016 = 105,
DXGI_FORMAT_420_OPAQUE = 106,
DXGI_FORMAT_YUY2 = 107,
DXGI_FORMAT_Y210 = 108,
DXGI_FORMAT_Y216 = 109,
DXGI_FORMAT_NV11 = 110,
DXGI_FORMAT_AI44 = 111,
DXGI_FORMAT_IA44 = 112,
DXGI_FORMAT_P8 = 113,
DXGI_FORMAT_A8P8 = 114,
DXGI_FORMAT_B4G4R4A4_UNORM = 115
);
{ DX10 extension header for DDS file format }
TDX10Header = packed record
DXGIFormat: TDXGIFormat;
ResourceDimension: TD3D10ResourceDimension;
MiscFlags: UInt32;
ArraySize: UInt32;
Reserved: UInt32;
end;
{ TDDSFileFormat class implementation }
constructor TDDSFileFormat.Create;
procedure TDDSFileFormat.Define;
begin
inherited Create;
inherited;
FName := SDDSFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := True;
FFeatures := [ffLoad, ffSave, ffMultiImage];
FSupportedFormats := DDSSupportedFormats;
FSaveCubeMap := False;
@ -261,7 +393,7 @@ begin
if IsCubeMap then
begin
// Cube maps are stored like this
// Face 0 mimap 0
// Face 0 mipmap 0
// Face 0 mipmap 1
// ...
// Face 1 mipmap 0
@ -307,10 +439,12 @@ function TDDSFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
Hdr: TDDSFileHeader;
HdrDX10: TDX10Header;
SrcFormat: TImageFormat;
FmtInfo: TImageFormatInfo;
NeedsSwapChannels: Boolean;
CurrentWidth, CurrentHeight, ImageCount, LoadSize, I, PitchOrLinear: LongInt;
CurrentWidth, CurrentHeight, ImageCount, LoadSize, I,
PitchOrLinear, MainImageLinearSize: LongInt;
Data: PByte;
UseAsPitch: Boolean;
UseAsLinear: Boolean;
@ -322,6 +456,128 @@ var
(DDPF.BlueMask = PF.BBitMask);
end;
function FindFourCCFormat(FourCC: UInt32): TImageFormat;
begin
// Handle FourCC and large ARGB formats
case FourCC of
D3DFMT_A16B16G16R16: Result := ifA16B16G16R16;
D3DFMT_R32F: Result := ifR32F;
D3DFMT_A32B32G32R32F: Result := ifA32B32G32R32F;
D3DFMT_R16F: Result := ifR16F;
D3DFMT_A16B16G16R16F: Result := ifA16B16G16R16F;
FOURCC_DXT1: Result := ifDXT1;
FOURCC_DXT3: Result := ifDXT3;
FOURCC_DXT5: Result := ifDXT5;
FOURCC_ATI1: Result := ifATI1N;
FOURCC_ATI2: Result := ifATI2N;
else
Result := ifUnknown;
end;
end;
function FindDX10Format(DXGIFormat: TDXGIFormat; var NeedsSwapChannels: Boolean): TImageFormat;
begin
Result := ifUnknown;
NeedsSwapChannels := False;
case DXGIFormat of
DXGI_FORMAT_UNKNOWN: ;
DXGI_FORMAT_R32G32B32A32_TYPELESS, DXGI_FORMAT_R32G32B32A32_FLOAT:
Result := ifA32B32G32R32F;
DXGI_FORMAT_R32G32B32A32_UINT: ;
DXGI_FORMAT_R32G32B32A32_SINT: ;
DXGI_FORMAT_R32G32B32_TYPELESS, DXGI_FORMAT_R32G32B32_FLOAT:
Result := ifB32G32R32F;
DXGI_FORMAT_R32G32B32_UINT: ;
DXGI_FORMAT_R32G32B32_SINT: ;
DXGI_FORMAT_R16G16B16A16_FLOAT:
Result := ifA16B16G16R16F;
DXGI_FORMAT_R16G16B16A16_TYPELESS, DXGI_FORMAT_R16G16B16A16_UNORM,
DXGI_FORMAT_R16G16B16A16_UINT, DXGI_FORMAT_R16G16B16A16_SNORM,
DXGI_FORMAT_R16G16B16A16_SINT:
Result := ifA16B16G16R16;
DXGI_FORMAT_R32G32_TYPELESS: ;
DXGI_FORMAT_R32G32_FLOAT: ;
DXGI_FORMAT_R32G32_UINT: ;
DXGI_FORMAT_R32G32_SINT: ;
DXGI_FORMAT_R32G8X24_TYPELESS: ;
DXGI_FORMAT_D32_FLOAT_S8X24_UINT: ;
DXGI_FORMAT_R32_FLOAT_X8X24_TYPELESS: ;
DXGI_FORMAT_X32_TYPELESS_G8X24_UINT: ;
DXGI_FORMAT_R10G10B10A2_TYPELESS: ;
DXGI_FORMAT_R10G10B10A2_UNORM: ;
DXGI_FORMAT_R10G10B10A2_UINT: ;
DXGI_FORMAT_R11G11B10_FLOAT: ;
DXGI_FORMAT_R8G8B8A8_TYPELESS, DXGI_FORMAT_R8G8B8A8_UNORM,
DXGI_FORMAT_R8G8B8A8_UINT, DXGI_FORMAT_R8G8B8A8_SNORM,DXGI_FORMAT_R8G8B8A8_SINT,
DXGI_FORMAT_R8G8B8A8_UNORM_SRGB:
begin
Result := ifA8R8G8B8;
NeedsSwapChannels := True;
end;
DXGI_FORMAT_R16G16_TYPELESS: ;
DXGI_FORMAT_R16G16_FLOAT: ;
DXGI_FORMAT_R16G16_UNORM: ;
DXGI_FORMAT_R16G16_UINT: ;
DXGI_FORMAT_R16G16_SNORM: ;
DXGI_FORMAT_R16G16_SINT: ;
DXGI_FORMAT_R32_TYPELESS, DXGI_FORMAT_R32_UINT, DXGI_FORMAT_R32_SINT:
Result := ifGray32;
DXGI_FORMAT_D32_FLOAT, DXGI_FORMAT_R32_FLOAT:
Result := ifR32F;
DXGI_FORMAT_R24G8_TYPELESS: ;
DXGI_FORMAT_D24_UNORM_S8_UINT: ;
DXGI_FORMAT_R24_UNORM_X8_TYPELESS: ;
DXGI_FORMAT_X24_TYPELESS_G8_UINT: ;
DXGI_FORMAT_R8G8_TYPELESS, DXGI_FORMAT_R8G8_UNORM, DXGI_FORMAT_R8G8_UINT,
DXGI_FORMAT_R8G8_SNORM, DXGI_FORMAT_R8G8_SINT:
Result := ifA8Gray8;
DXGI_FORMAT_R16_TYPELESS, DXGI_FORMAT_D16_UNORM, DXGI_FORMAT_R16_UNORM,
DXGI_FORMAT_R16_UINT, DXGI_FORMAT_R16_SNORM, DXGI_FORMAT_R16_SINT:
Result := ifGray16;
DXGI_FORMAT_R16_FLOAT:
Result := ifR16F;
DXGI_FORMAT_R8_TYPELESS, DXGI_FORMAT_R8_UNORM, DXGI_FORMAT_R8_UINT,
DXGI_FORMAT_R8_SNORM, DXGI_FORMAT_R8_SINT, DXGI_FORMAT_A8_UNORM:
Result := ifGray8;
DXGI_FORMAT_R1_UNORM: ;
DXGI_FORMAT_R9G9B9E5_SHAREDEXP: ;
DXGI_FORMAT_R8G8_B8G8_UNORM: ;
DXGI_FORMAT_G8R8_G8B8_UNORM: ;
DXGI_FORMAT_BC1_TYPELESS, DXGI_FORMAT_BC1_UNORM, DXGI_FORMAT_BC1_UNORM_SRGB:
Result := ifDXT1;
DXGI_FORMAT_BC2_TYPELESS, DXGI_FORMAT_BC2_UNORM, DXGI_FORMAT_BC2_UNORM_SRGB:
Result := ifDXT3;
DXGI_FORMAT_BC3_TYPELESS, DXGI_FORMAT_BC3_UNORM, DXGI_FORMAT_BC3_UNORM_SRGB:
Result := ifDXT5;
DXGI_FORMAT_BC4_TYPELESS, DXGI_FORMAT_BC4_UNORM, DXGI_FORMAT_BC4_SNORM:
Result := ifATI1N;
DXGI_FORMAT_BC5_TYPELESS, DXGI_FORMAT_BC5_UNORM, DXGI_FORMAT_BC5_SNORM:
Result := ifATI2N;
DXGI_FORMAT_B5G6R5_UNORM:
Result := ifR5G6B5;
DXGI_FORMAT_B5G5R5A1_UNORM:
Result := ifA1R5G5B5;
DXGI_FORMAT_B8G8R8A8_UNORM, DXGI_FORMAT_B8G8R8A8_TYPELESS:
Result := ifA8R8G8B8;
DXGI_FORMAT_B8G8R8X8_UNORM, DXGI_FORMAT_B8G8R8X8_TYPELESS:
Result := ifX8R8G8B8;
DXGI_FORMAT_R10G10B10_XR_BIAS_A2_UNORM: ;
DXGI_FORMAT_B8G8R8A8_UNORM_SRGB: ;
DXGI_FORMAT_B8G8R8X8_UNORM_SRGB: ;
DXGI_FORMAT_BC6H_TYPELESS: ;
DXGI_FORMAT_BC6H_UF16: ;
DXGI_FORMAT_BC6H_SF16: ;
DXGI_FORMAT_BC7_TYPELESS: ;
DXGI_FORMAT_BC7_UNORM: ;
DXGI_FORMAT_BC7_UNORM_SRGB: ;
DXGI_FORMAT_P8: ;
DXGI_FORMAT_A8P8: ;
DXGI_FORMAT_B4G4R4A4_UNORM:
Result := ifA4R4G4B4;
end;
end;
begin
Result := False;
ImageCount := 1;
@ -329,34 +585,27 @@ begin
FLoadedDepth := 1;
FLoadedVolume := False;
FLoadedCubeMap := False;
ZeroMemory(@HdrDX10, SizeOf(HdrDX10));
with GetIO, Hdr, Hdr.Desc.PixelFormat do
begin
Read(Handle, @Hdr, SizeOF(Hdr));
{
// Set position to the end of the header (for possible future versions
// ith larger header)
Seek(Handle, Hdr.Desc.Size + SizeOf(Hdr.Magic) - SizeOf(Hdr),
smFromCurrent);
}
Read(Handle, @Hdr, SizeOf(Hdr));
SrcFormat := ifUnknown;
NeedsSwapChannels := False;
// Get image data format
if (Flags and DDPF_FOURCC) = DDPF_FOURCC then
begin
// Handle FourCC and large ARGB formats
case FourCC of
D3DFMT_A16B16G16R16: SrcFormat := ifA16B16G16R16;
D3DFMT_R32F: SrcFormat := ifR32F;
D3DFMT_A32B32G32R32F: SrcFormat := ifA32B32G32R32F;
D3DFMT_R16F: SrcFormat := ifR16F;
D3DFMT_A16B16G16R16F: SrcFormat := ifA16B16G16R16F;
FOURCC_DXT1: SrcFormat := ifDXT1;
FOURCC_DXT3: SrcFormat := ifDXT3;
FOURCC_DXT5: SrcFormat := ifDXT5;
FOURCC_ATI1: SrcFormat := ifATI1N;
FOURCC_ATI2: SrcFormat := ifATI2N;
end;
if FourCC = FOURCC_DX10 then
begin
Read(Handle, @HdrDX10, SizeOf(HdrDX10));
SrcFormat := FindDX10Format(HdrDX10.DXGIFormat, NeedsSwapChannels);
FMetadata.SetMetaItem(SMetaDdsDxgiFormat, HdrDX10.DXGIFormat);
FMetadata.SetMetaItem(SMetaDdsArraySize, HdrDX10.ArraySize);
end
else
SrcFormat := FindFourCCFormat(FourCC);
end
else if (Flags and DDPF_RGB) = DDPF_RGB then
begin
@ -367,11 +616,9 @@ begin
case BitCount of
16:
begin
if MasksEqual(Desc.PixelFormat,
GetFormatInfo(ifA4R4G4B4).PixelFormat) then
if MasksEqual(Desc.PixelFormat, GetFormatInfo(ifA4R4G4B4).PixelFormat) then
SrcFormat := ifA4R4G4B4;
if MasksEqual(Desc.PixelFormat,
GetFormatInfo(ifA1R5G5B5).PixelFormat) then
if MasksEqual(Desc.PixelFormat, GetFormatInfo(ifA1R5G5B5).PixelFormat) then
SrcFormat := ifA1R5G5B5;
end;
32:
@ -458,7 +705,8 @@ begin
end;
// If DDS format is not supported we will exit
if SrcFormat = ifUnknown then Exit;
if SrcFormat = ifUnknown then
Exit;
// File contains mipmaps for each subimage.
{ Some DDS writers ignore setting proper Caps and Flags so
@ -468,6 +716,7 @@ begin
if Desc.MipMaps > 1 then
begin
FLoadedMipMapCount := Desc.MipMaps;
FMetadata.SetMetaItem(SMetaDdsMipMapCount, Desc.MipMaps);
ImageCount := Desc.MipMaps;
end;
@ -508,12 +757,21 @@ begin
// Main image pitch or linear size
PitchOrLinear := Desc.PitchOrLinearSize;
// Check: some writers just write garbage to pitch/linear size fields and flags
MainImageLinearSize := FmtInfo.GetPixelsSize(SrcFormat, Desc.Width, Desc.Height);
if UseAsLinear and ((PitchOrLinear < MainImageLinearSize) or
(PitchOrLinear * Integer(Desc.Height) = MainImageLinearSize)) then
begin
// Explicitly set linear size
PitchOrLinear := MainImageLinearSize;
end;
for I := 0 to ImageCount - 1 do
begin
// Compute dimensions of surrent subimage based on texture type and
// number of mipmaps
ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth,
FloadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight);
FLoadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight);
NewImage(CurrentWidth, CurrentHeight, SrcFormat, Images[I]);
if (I > 0) or (PitchOrLinear = 0) then
@ -563,7 +821,7 @@ var
Hdr: TDDSFileHeader;
MainImage, ImageToSave: TImageData;
I, MainIdx, Len, ImageCount: LongInt;
J: LongWord;
J: UInt32;
FmtInfo: TImageFormatInfo;
MustBeFreed: Boolean;
Is2DTexture, IsCubeMap, IsVolume: Boolean;
@ -823,6 +1081,13 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.77.1 ----------------------------------------------------
- Texture and D3D specific info stored in DDS is now available as metadata
(loading).
- Added support for loading DDS files with DX10 extension
(http://msdn.microsoft.com/en-us/library/windows/desktop/bb943991(v=vs.85).aspx)
and few compatibility fixes.
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Added support for 3Dc ATI1/2 formats.

891
Imaging/ImagingExport.pas
View File

@ -1,891 +0,0 @@
{
$Id: ImagingExport.pas 173 2009-09-04 17:05:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This function contains functions exported from Imaging dynamic link library.
All string are exported as PChars and all var parameters are exported
as pointers. All posible exceptions getting out of dll are catched.}
unit ImagingExport;
{$I ImagingOptions.inc}
interface
uses
ImagingTypes,
Imaging;
{ Returns version of Imaging library. }
procedure ImGetVersion(var Major, Minor, Patch: LongInt); cdecl;
{ Look at InitImage for details.}
procedure ImInitImage(var Image: TImageData); cdecl;
{ Look at NewImage for details.}
function ImNewImage(Width, Height: LongInt; Format: TImageFormat;
var Image: TImageData): Boolean; cdecl;
{ Look at TestImage for details.}
function ImTestImage(var Image: TImageData): Boolean; cdecl;
{ Look at FreeImage for details.}
function ImFreeImage(var Image: TImageData): Boolean; cdecl;
{ Look at DetermineFileFormat for details. Ext should have enough space for
result file extension.}
function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean; cdecl;
{ Look at DetermineMemoryFormat for details. Ext should have enough space for
result file extension.}
function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean; cdecl;
{ Look at IsFileFormatSupported for details.}
function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean; cdecl;
{ Look at EnumFileFormats for details.}
function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
var CanSave, IsMultiImageFormat: Boolean): Boolean; cdecl;
{ Inits image list.}
function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean; cdecl;
{ Returns size of image list.}
function ImGetImageListSize(ImageList: TImageDataList): LongInt; cdecl;
{ Returns image list's element at given index. Output image is not cloned it's
Bits point to Bits in list => do not free OutImage.}
function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt;
var OutImage: TImageData): Boolean; cdecl;
{ Sets size of image list.}
function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt): Boolean; cdecl;
{ Sets image list element at given index. Input image is not cloned - image in
list will point to InImage's Bits.}
function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt;
const InImage: TImageData): Boolean; cdecl;
{ Returns True if all images in list pass ImTestImage test. }
function ImTestImagesInList(ImageList: TImageDataList): Boolean; cdecl;
{ Frees image list and all images in it.}
function ImFreeImageList(var ImageList: TImageDataList): Boolean; cdecl;
{ Look at LoadImageFromFile for details.}
function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean; cdecl;
{ Look at LoadImageFromMemory for details.}
function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; cdecl;
{ Look at LoadMultiImageFromFile for details.}
function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList): Boolean; cdecl;
{ Look at LoadMultiImageFromMemory for details.}
function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
var ImageList: TImageDataList): Boolean; cdecl;
{ Look at SaveImageToFile for details.}
function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean; cdecl;
{ Look at SaveImageToMemory for details.}
function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
const Image: TImageData): Boolean; cdecl;
{ Look at SaveMultiImageToFile for details.}
function ImSaveMultiImageToFile(FileName: PAnsiChar; ImageList: TImageDataList): Boolean; cdecl;
{ Look at SaveMultiImageToMemory for details.}
function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
ImageList: TImageDataList): Boolean; cdecl;
{ Look at CloneImage for details.}
function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean; cdecl;
{ Look at ConvertImage for details.}
function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; cdecl;
{ Look at FlipImage for details.}
function ImFlipImage(var Image: TImageData): Boolean; cdecl;
{ Look at MirrorImage for details.}
function ImMirrorImage(var Image: TImageData): Boolean; cdecl;
{ Look at ResizeImage for details.}
function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
Filter: TResizeFilter): Boolean; cdecl;
{ Look at SwapChannels for details.}
function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean; cdecl;
{ Look at ReduceColors for details.}
function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; cdecl;
{ Look at GenerateMipMaps for details.}
function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt;
var MipMaps: TImageDataList): Boolean; cdecl;
{ Look at MapImageToPalette for details.}
function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32;
Entries: LongInt): Boolean; cdecl;
{ Look at SplitImage for details.}
function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
PreserveSize: Boolean; Fill: Pointer): Boolean; cdecl;
{ Look at MakePaletteForImages for details.}
function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
MaxColors: LongInt; ConvertImages: Boolean): Boolean; cdecl;
{ Look at RotateImage for details.}
function ImRotateImage(var Image: TImageData; Angle: Single): Boolean; cdecl;
{ Look at CopyRect for details.}
function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl;
{ Look at FillRect for details.}
function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
Fill: Pointer): Boolean; cdecl;
{ Look at ReplaceColor for details.}
function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
OldPixel, NewPixel: Pointer): Boolean; cdecl;
{ Look at StretchRect for details.}
function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl;
{ Look at GetPixelDirect for details.}
procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl;
{ Look at SetPixelDirect for details.}
procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl;
{ Look at GetPixel32 for details.}
function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl;
{ Look at SetPixel32 for details.}
procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); cdecl;
{ Look at GetPixelFP for details.}
function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl;
{ Look at SetPixelFP for details.}
procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); cdecl;
{ Look at NewPalette for details.}
function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean; cdecl;
{ Look at FreePalette for details.}
function ImFreePalette(var Pal: PPalette32): Boolean; cdecl;
{ Look at CopyPalette for details.}
function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean; cdecl;
{ Look at FindColor for details.}
function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt; cdecl;
{ Look at FillGrayscalePalette for details.}
function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean; cdecl;
{ Look at FillCustomPalette for details.}
function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
BBits: Byte; Alpha: Byte): Boolean; cdecl;
{ Look at SwapChannelsOfPalette for details.}
function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
DstChannel: LongInt): Boolean; cdecl;
{ Look at SetOption for details.}
function ImSetOption(OptionId, Value: LongInt): Boolean; cdecl;
{ Look at GetOption for details.}
function ImGetOption(OptionId: LongInt): LongInt; cdecl;
{ Look at PushOptions for details.}
function ImPushOptions: Boolean; cdecl;
{ Look at PopOptions for details.}
function ImPopOptions: Boolean; cdecl;
{ Look at GetImageFormatInfo for details.}
function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean; cdecl;
{ Look at GetPixelsSize for details.}
function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; cdecl;
{ Look at SetUserFileIO for details.}
procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc;
TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); cdecl;
{ Look at ResetFileIO for details.}
procedure ImResetFileIO; cdecl;
{ These are only for documentation generation reasons.}
{ Loads Imaging functions from dll/so library.}
function ImLoadLibrary: Boolean;
{ Frees Imaging functions loaded from dll/so and releases library.}
function ImFreeLibrary: Boolean;
implementation
uses
SysUtils,
ImagingUtility;
function ImLoadLibrary: Boolean; begin Result := True; end;
function ImFreeLibrary: Boolean; begin Result := True; end;
type
TInternalList = record
List: TDynImageDataArray;
end;
PInternalList = ^TInternalList;
procedure ImGetVersion(var Major, Minor, Patch: LongInt);
begin
Major := ImagingVersionMajor;
Minor := ImagingVersionMinor;
Patch := ImagingVersionPatch;
end;
procedure ImInitImage(var Image: TImageData);
begin
try
Imaging.InitImage(Image);
except
end;
end;
function ImNewImage(Width, Height: LongInt; Format: TImageFormat;
var Image: TImageData): Boolean;
begin
try
Result := Imaging.NewImage(Width, Height, Format, Image);
except
Result := False;
end;
end;
function ImTestImage(var Image: TImageData): Boolean;
begin
try
Result := Imaging.TestImage(Image);
except
Result := False;
end;
end;
function ImFreeImage(var Image: TImageData): Boolean;
begin
try
Imaging.FreeImage(Image);
Result := True;
except
Result := False;
end;
end;
function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean;
var
S: string;
begin
try
S := Imaging.DetermineFileFormat(FileName);
Result := S <> '';
StrCopy(Ext, PAnsiChar(AnsiString(S)));
except
Result := False;
end;
end;
function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean;
var
S: string;
begin
try
S := Imaging.DetermineMemoryFormat(Data, Size);
Result := S <> '';
StrCopy(Ext, PAnsiChar(AnsiString(S)));
except
Result := False;
end;
end;
function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean;
begin
try
Result := Imaging.IsFileFormatSupported(FileName);
except
Result := False;
end;
end;
function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
var CanSave, IsMultiImageFormat: Boolean): Boolean;
var
StrName, StrDefaultExt, StrMasks: string;
begin
try
Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave,
IsMultiImageFormat);
StrCopy(Name, PAnsiChar(AnsiString(StrName)));
StrCopy(DefaultExt, PAnsiChar(AnsiString(StrDefaultExt)));
StrCopy(Masks, PAnsiChar(AnsiString(StrMasks)));
except
Result := False;
end;
end;
function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean;
var
Int: PInternalList;
begin
try
try
ImFreeImageList(ImageList);
except
end;
New(Int);
SetLength(Int.List, Size);
ImageList := TImageDataList(Int);
Result := True;
except
Result := False;
ImageList := nil;
end;
end;
function ImGetImageListSize(ImageList: TImageDataList): LongInt;
begin
try
Result := Length(PInternalList(ImageList).List);
except
Result := -1;
end;
end;
function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt;
var OutImage: TImageData): Boolean;
begin
try
Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1);
ImCloneImage(PInternalList(ImageList).List[Index], OutImage);
Result := True;
except
Result := False;
end;
end;
function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt):
Boolean;
var
I, OldSize: LongInt;
begin
try
OldSize := Length(PInternalList(ImageList).List);
if NewSize < OldSize then
for I := NewSize to OldSize - 1 do
Imaging.FreeImage(PInternalList(ImageList).List[I]);
SetLength(PInternalList(ImageList).List, NewSize);
Result := True;
except
Result := False;
end;
end;
function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt;
const InImage: TImageData): Boolean;
begin
try
Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1);
ImCloneImage(InImage, PInternalList(ImageList).List[Index]);
Result := True;
except
Result := False;
end;
end;
function ImTestImagesInList(ImageList: TImageDataList): Boolean;
var
I: LongInt;
Arr: TDynImageDataArray;
begin
Arr := nil;
try
Arr := PInternalList(ImageList).List;
Result := True;
for I := 0 to Length(Arr) - 1 do
begin
Result := Result and Imaging.TestImage(Arr[I]);
if not Result then Break;
end;
except
Result := False;
end;
end;
function ImFreeImageList(var ImageList: TImageDataList): Boolean;
var
Int: PInternalList;
begin
try
if ImageList <> nil then
begin
Int := PInternalList(ImageList);
FreeImagesInArray(Int.List);
Dispose(Int);
ImageList := nil;
end;
Result := True;
except
Result := False;
end;
end;
function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean;
begin
try
Result := Imaging.LoadImageFromFile(FileName, Image);
except
Result := False;
end;
end;
function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean;
begin
try
Result := Imaging.LoadImageFromMemory(Data, Size, Image);
except
Result := False;
end;
end;
function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList):
Boolean;
begin
try
ImInitImageList(0, ImageList);
Result := Imaging.LoadMultiImageFromFile(FileName,
PInternalList(ImageList).List);
except
Result := False;
end;
end;
function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
var ImageList: TImageDataList): Boolean;
begin
try
ImInitImageList(0, ImageList);
Result := Imaging.LoadMultiImageFromMemory(Data, Size, PInternalList(ImageList).List);
except
Result := False;
end;
end;
function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean;
begin
try
Result := Imaging.SaveImageToFile(FileName, Image);
except
Result := False;
end;
end;
function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
const Image: TImageData): Boolean;
begin
try
Result := Imaging.SaveImageToMemory(Ext, Data, Size, Image);
except
Result := False;
end;
end;
function ImSaveMultiImageToFile(FileName: PAnsiChar;
ImageList: TImageDataList): Boolean;
begin
try
Result := Imaging.SaveMultiImageToFile(FileName,
PInternalList(ImageList).List);
except
Result := False;
end;
end;
function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
ImageList: TImageDataList): Boolean;
begin
try
Result := Imaging.SaveMultiImageToMemory(Ext, Data, Size^,
PInternalList(ImageList).List);
except
Result := False;
end;
end;
function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean;
begin
try
Result := Imaging.CloneImage(Image, Clone);
except
Result := False;
end;
end;
function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean;
begin
try
Result := Imaging.ConvertImage(Image, DestFormat);
except
Result := False;
end;
end;
function ImFlipImage(var Image: TImageData): Boolean;
begin
try
Result := Imaging.FlipImage(Image);
except
Result := False;
end;
end;
function ImMirrorImage(var Image: TImageData): Boolean;
begin
try
Result := Imaging.MirrorImage(Image);
except
Result := False;
end;
end;
function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
Filter: TResizeFilter): Boolean;
begin
try
Result := Imaging.ResizeImage(Image, NewWidth, NewHeight, Filter);
except
Result := False;
end;
end;
function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt):
Boolean;
begin
try
Result := Imaging.SwapChannels(Image, SrcChannel, DstChannel);
except
Result := False;
end;
end;
function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean;
begin
try
Result := Imaging.ReduceColors(Image, MaxColors);
except
Result := False;
end;
end;
function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt;
var MipMaps: TImageDataList): Boolean;
begin
try
ImInitImageList(0, MipMaps);
Result := Imaging.GenerateMipMaps(Image, Levels,
PInternalList(MipMaps).List);
except
Result := False;
end;
end;
function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32;
Entries: LongInt): Boolean;
begin
try
Result := Imaging.MapImageToPalette(Image, Pal, Entries);
except
Result := False;
end;
end;
function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
PreserveSize: Boolean; Fill: Pointer): Boolean;
begin
try
ImInitImageList(0, Chunks);
Result := Imaging.SplitImage(Image, PInternalList(Chunks).List,
ChunkWidth, ChunkHeight, XChunks, YChunks, PreserveSize, Fill);
except
Result := False;
end;
end;
function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
MaxColors: LongInt; ConvertImages: Boolean): Boolean;
begin
try
Result := Imaging.MakePaletteForImages(PInternalList(Images).List,
Pal, MaxColors, ConvertImages);
except
Result := False;
end;
end;
function ImRotateImage(var Image: TImageData; Angle: Single): Boolean;
begin
try
Result := Imaging.RotateImage(Image, Angle);
except
Result := False;
end;
end;
function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl;
begin
try
Result := Imaging.CopyRect(SrcImage, SrcX, SrcY, Width, Height,
DstImage, DstX, DstY);
except
Result := False;
end;
end;
function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
Fill: Pointer): Boolean;
begin
try
Result := Imaging.FillRect(Image, X, Y, Width, Height, Fill);
except
Result := False;
end;
end;
function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
OldPixel, NewPixel: Pointer): Boolean;
begin
try
Result := Imaging.ReplaceColor(Image, X, Y, Width, Height, OldPixel, NewPixel);
except
Result := False;
end;
end;
function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl;
begin
try
Result := Imaging.StretchRect(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight,
DstImage, DstX, DstY, DstWidth, DstHeight, Filter);
except
Result := False;
end;
end;
procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
begin
try
Imaging.GetPixelDirect(Image, X, Y, Pixel);
except
end;
end;
procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
begin
try
Imaging.SetPixelDirect(Image, X, Y, Pixel);
except
end;
end;
function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl;
begin
try
Result := Imaging.GetPixel32(Image, X, Y);
except
Result.Color := 0;
end;
end;
procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec);
begin
try
Imaging.SetPixel32(Image, X, Y, Color);
except
end;
end;
function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl;
begin
try
Result := Imaging.GetPixelFP(Image, X, Y);
except
FillChar(Result, SizeOf(Result), 0);
end;
end;
procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec);
begin
try
Imaging.SetPixelFP(Image, X, Y, Color);
except
end;
end;
function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean;
begin
try
Imaging.NewPalette(Entries, Pal);
Result := True;
except
Result := False;
end;
end;
function ImFreePalette(var Pal: PPalette32): Boolean;
begin
try
Imaging.FreePalette(Pal);
Result := True;
except
Result := False;
end;
end;
function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean;
begin
try
Imaging.CopyPalette(SrcPal, DstPal, SrcIdx, DstIdx, Count);
Result := True;
except
Result := False;
end;
end;
function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt;
begin
try
Result := Imaging.FindColor(Pal, Entries, Color);
except
Result := 0;
end;
end;
function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean;
begin
try
Imaging.FillGrayscalePalette(Pal, Entries);
Result := True;
except
Result := False;
end;
end;
function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
BBits: Byte; Alpha: Byte): Boolean;
begin
try
Imaging.FillCustomPalette(Pal, Entries, RBits, GBits, BBits, Alpha);
Result := True;
except
Result := False;
end;
end;
function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
DstChannel: LongInt): Boolean;
begin
try
Imaging.SwapChannelsOfPalette(Pal, Entries, SrcChannel, DstChannel);
Result := True;
except
Result := False;
end;
end;
function ImSetOption(OptionId, Value: LongInt): Boolean;
begin
try
Result := Imaging.SetOption(OptionId, Value);
except
Result := False;
end;
end;
function ImGetOption(OptionId: LongInt): LongInt;
begin
try
Result := GetOption(OptionId);
except
Result := InvalidOption;
end;
end;
function ImPushOptions: Boolean;
begin
try
Result := Imaging.PushOptions;
except
Result := False;
end;
end;
function ImPopOptions: Boolean;
begin
try
Result := Imaging.PopOptions;
except
Result := False;
end;
end;
function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean;
begin
try
Result := Imaging.GetImageFormatInfo(Format, Info);
except
Result := False;
end;
end;
function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
begin
try
Result := Imaging.GetPixelsSize(Format, Width, Height);
except
Result := 0;
end;
end;
procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc;
TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
begin
try
Imaging.SetUserFileIO(OpenReadProc, OpenWriteProc, CloseProc, EofProc,
SeekProc, TellProc, ReadProc, WriteProc);
except
end;
end;
procedure ImResetFileIO;
begin
try
Imaging.ResetFileIO;
except
end;
end;
{
Changes/Bug Fixes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.26.3 ---------------------------------------------------
- changed PChars to PAnsiChars and some more D2009 friendly
casts.
-- 0.19 -----------------------------------------------------
- updated to reflect changes in low level interface (added pixel set/get, ...)
- changed ImInitImage to procedure to reflect change in Imaging.pas
- added ImIsFileFormatSupported
-- 0.15 -----------------------------------------------------
- behaviour of ImGetImageListElement and ImSetImageListElement
has changed - list items are now cloned rather than referenced,
because of this ImFreeImageListKeepImages was no longer needed
and was removed
- many function headers were changed - mainly pointers were
replaced with var and const parameters
-- 0.13 -----------------------------------------------------
- added TestImagesInList function and new 0.13 functions
- images were not freed when image list was resized in ImSetImageListSize
- ImSaveMultiImageTo* recreated the input image list with size = 0
}
end.

797
Imaging/ImagingFormats.pas
View File

File diff suppressed because it is too large Load Diff

134
Imaging/ImagingGif.pas
View File

@ -1,29 +1,12 @@
{
$Id: ImagingGif.pas 157 2009-02-15 14:24:58Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains image format loader/saver for GIF images.}
@ -55,6 +38,7 @@ type
procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
protected
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
@ -62,7 +46,6 @@ type
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
@ -84,6 +67,7 @@ type
const
GIFSignature: TChar3 = 'GIF';
GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a');
GIFDefaultDelay = 65;
// Masks for accessing fields in PackedFields of TGIFHeader
GIFGlobalColorTable = $80;
@ -111,6 +95,11 @@ const
GIFUserInput = $02;
GIFDisposalMethod = $1C;
const
// Netscape sub block types
GIFAppLoopExtension = 1;
GIFAppBufferExtension = 2;
type
TGIFHeader = packed record
// File header part
@ -149,11 +138,6 @@ type
Terminator: Byte;
end;
const
// Netscape sub block types
GIFAppLoopExtension = 1;
GIFAppBufferExtension = 2;
type
TGIFIdentifierCode = array[0..7] of AnsiChar;
TGIFAuthenticationCode = array[0..2] of AnsiChar;
@ -216,13 +200,11 @@ resourcestring
TGIFFileFormat implementation
}
constructor TGIFFileFormat.Create;
procedure TGIFFileFormat.Define;
begin
inherited Create;
inherited;
FName := SGIFFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := True;
FFeatures := [ffLoad, ffSave, ffMultiImage];
FSupportedFormats := GIFSupportedFormats;
FLoadAnimated := GIFDefaultLoadAnimated;
@ -265,7 +247,7 @@ begin
end;
end;
{ GIF LZW decompresion code is from JVCL JvGIF.pas unit.}
{ GIF LZW decompression code is from JVCL JvGIF.pas unit.}
procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer;
Interlaced: Boolean; Data: Pointer);
var
@ -304,7 +286,7 @@ var
RawCode := Context.Buf[Word(ByteIndex)] +
(Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
if Context.CodeSize > 8 then
RawCode := RawCode + (LongInt(Context.Buf[ByteIndex + 2]) shl 16);
RawCode := RawCode + (Integer(Context.Buf[ByteIndex + 2]) shl 16);
RawCode := RawCode shr (Context.Inx and 7);
Context.Inx := Context.Inx + Byte(Context.CodeSize);
Result := RawCode and Context.ReadMask;
@ -374,7 +356,7 @@ begin
ReadCtxt.Size := 0;
ReadCtxt.CodeSize := MinCodeSize + 1;
ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
// Initialise pixel-output context
// Initialize pixel-output context
OutCtxt.X := 0;
OutCtxt.Y := 0;
OutCtxt.Pass := 0;
@ -470,7 +452,7 @@ begin
end;
end;
{ GIF LZW compresion code is from JVCL JvGIF.pas unit.}
{ GIF LZW compression code is from JVCL JvGIF.pas unit.}
procedure TGIFFileFormat.LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer;
Interlaced: Boolean; Data: Pointer);
var
@ -541,7 +523,7 @@ begin
for I := 0 to HashTableSize - 1 do
HashTable.Add(nil);
// Initialise encoder variables
// Initialize encoder variables
InitCodeSize := BitCount + 1;
if InitCodeSize = 2 then
Inc(InitCodeSize);
@ -735,7 +717,8 @@ var
if BlockSize >= SizeOf(AppRec) then
begin
Read(Handle, @AppRec, SizeOf(AppRec));
if (AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0') then
if ((AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0')) or
((AppRec.Identifier = 'ANIMEXTS') and (AppRec.Authentication = '1.0')) then
begin
Read(Handle, @BlockSize, SizeOf(BlockSize));
while BlockSize <> 0 do
@ -750,6 +733,9 @@ var
// Read loop count
Read(Handle, @LoopCount, SizeOf(LoopCount));
Dec(BlockSize, SizeOf(LoopCount));
if LoopCount > 0 then
Inc(LoopCount); // Netscape extension is really "repeats" not "loops"
FMetadata.SetMetaItem(SMetaAnimationLoops, LoopCount);
end;
GIFAppBufferExtension:
begin
@ -886,7 +872,7 @@ var
Exit;
end;
// If Grahic Control Extension is present make use of it
// If Graphic Control Extension is present make use of it
if HasGraphicExt then
begin
FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
@ -896,6 +882,7 @@ var
FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
end;
FMetadata.SetMetaItem(SMetaFrameDelay, Integer(GraphicExt.DelayTime * 10), Idx);
end
else
FrameInfos[Idx].HasTransparency := False;
@ -972,7 +959,7 @@ var
if FrameInfos[Index].HasTransparency then
BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color;
// Clear whole screen
FillMemoryLongWord(AnimFrame.Bits, AnimFrame.Size, BGColor);
FillMemoryUInt32(AnimFrame.Bits, AnimFrame.Size, BGColor);
// Try to maximize First so we don't have to use all 0 to n raw frames
while First > 0 do
@ -1101,7 +1088,7 @@ begin
end;
function TGIFFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
Header: TGIFHeader;
ImageDesc: TImageDescriptor;
@ -1124,6 +1111,44 @@ var
end;
end;
procedure SetFrameDelay(Idx: Integer; var Ext: TGraphicControlExtension);
begin
if FMetadata.HasMetaItemForSaving(SMetaFrameDelay, Idx) then
Ext.DelayTime := FMetadata.MetaItemsForSavingMulti[SMetaFrameDelay, Idx] div 10
else
Ext.DelayTime := GIFDefaultDelay;
end;
procedure SaveGlobalMetadata;
var
AppExt: TGIFApplicationRec;
BlockSize, LoopExtId: Byte;
Repeats: Word;
begin
if FMetadata.HasMetaItemForSaving(SMetaAnimationLoops) then
with GetIO do
begin
FillChar(AppExt, SizeOf(AppExt), 0);
AppExt.Identifier := 'NETSCAPE';
AppExt.Authentication := '2.0';
Repeats := FMetadata.MetaItemsForSaving[SMetaAnimationLoops];
if Repeats > 0 then
Dec(Repeats);
LoopExtId := GIFAppLoopExtension;
Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
Write(Handle, @GIFApplicationExtension, SizeOf(GIFApplicationExtension));
BlockSize := 11;
Write(Handle, @BlockSize, SizeOf(BlockSize));
Write(Handle, @AppExt, SizeOf(AppExt));
BlockSize := 3;
Write(Handle, @BlockSize, SizeOf(BlockSize));
Write(Handle, @LoopExtId, SizeOf(LoopExtId));
Write(Handle, @Repeats, SizeOf(Repeats));
Write(Handle, @GIFBlockTerminator, SizeOf(GIFBlockTerminator));
end;
end;
begin
// Fill header with data, select size of largest image in array as
// logical screen size
@ -1136,9 +1161,11 @@ begin
// Prepare default GC extension with delay
FillChar(GraphicExt, Sizeof(GraphicExt), 0);
GraphicExt.DelayTime := 65;
GraphicExt.DelayTime := GIFDefaultDelay;
GraphicExt.BlockSize := 4;
SaveGlobalMetadata;
for I := FFirstIdx to FLastIdx do
begin
if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
@ -1147,13 +1174,14 @@ begin
// Write Graphic Control Extension with default delay
Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension));
SetFrameDelay(I, GraphicExt);
Write(Handle, @GraphicExt, SizeOf(GraphicExt));
// Write frame marker and fill and write image descriptor for this frame
Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor));
FillChar(ImageDesc, Sizeof(ImageDesc), 0);
ImageDesc.Width := Width;
ImageDesc.Height := Height;
ImageDesc.PackedFields := GIFLocalColorTable or GIFColorTableSize; // Use lccal color table with 256 entries
ImageDesc.PackedFields := GIFLocalColorTable or GIFColorTableSize; // Use local color table with 256 entries
Write(Handle, @ImageDesc, SizeOf(ImageDesc));
// Write local color table for each frame
@ -1164,7 +1192,7 @@ begin
Write(Handle, @Palette[J].B, SizeOf(Palette[J].B));
end;
// Fonally compress image data
// Finally compress image data
LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits);
finally
@ -1186,7 +1214,7 @@ end;
function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
Header: TGIFHeader;
ReadCount: LongInt;
ReadCount: Integer;
begin
Result := False;
if Handle <> nil then
@ -1208,6 +1236,14 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.77 Changes/Bug Fixes -----------------------------------
- Fixed crash when resaving GIF with animation metadata.
- Writes frame delays of GIF animations from metadata.
- Reads and writes looping of GIF animations stored into/from metadata.
-- 0.26.5 Changes/Bug Fixes ---------------------------------
- Reads frame delays from GIF animations into metadata.
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Fixed bug - loading of GIF with NETSCAPE app extensions
failed with Delphi 2009.
@ -1225,12 +1261,12 @@ initialization
transparent by default.
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Made backround color transparent by default (alpha = 0).
- Made background color transparent by default (alpha = 0).
-- 0.23 Changes/Bug Fixes -----------------------------------
- Fixed other loading bugs (local pal size, transparency).
- Added GIF saving.
- Fixed bug when loading multiframe GIFs and implemented few animation
- Fixed bug when loading multi-frame GIFs and implemented few animation
features (disposal methods, ...).
- Loading of GIFs working.
- Unit created with initial stuff!

243
Imaging/ImagingIO.pas
View File

@ -1,32 +1,15 @@
{
$Id: ImagingIO.pas 100 2007-06-28 21:09:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains default IO functions for reading from/writting to
{ This unit contains default IO functions for reading from/writing to
files, streams and memory.}
unit ImagingIO;
@ -53,9 +36,30 @@ var
{ Helper function that returns size of input (from current position to the end)
represented by Handle (and opened and operated on by members of IOFunctions).}
function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt;
function GetInputSize(const IOFunctions: TIOFunctions; Handle: TImagingHandle): Int64;
{ Helper function that initializes TMemoryIORec with given params.}
function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec;
{ Reads one text line from input (CR+LF, CR, or LF as line delimiter).}
function ReadLine(const IOFunctions: TIOFunctions; Handle: TImagingHandle;
out Line: AnsiString; FailOnControlChars: Boolean = False): Boolean;
{ Writes one text line to input with optional line delimiter.}
procedure WriteLine(const IOFunctions: TIOFunctions; Handle: TImagingHandle;
const Line: AnsiString; const LineEnding: AnsiString = sLineBreak);
type
TReadMemoryStream = class(TCustomMemoryStream)
public
constructor Create(Data: Pointer; Size: Integer);
class function CreateFromIOHandle(const IOFunctions: TIOFunctions; Handle: TImagingHandle): TReadMemoryStream;
end;
TImagingIOStream = class(TStream)
private
FIO: TIOFunctions;
FHandle: TImagingHandle;
public
constructor Create(const IOFunctions: TIOFunctions; Handle: TImagingHandle);
end;
implementation
@ -65,7 +69,7 @@ const
type
{ Based on TaaBufferedStream
Copyright (c) Julian M Bucknall 1997, 1999 }
TBufferedStream = class(TObject)
TBufferedStream = class
private
FBuffer: PByteArray;
FBufSize: Integer;
@ -135,7 +139,7 @@ procedure TBufferedStream.ReadBuffer;
var
SeekResult: Integer;
begin
SeekResult := FStream.Seek(FBufStart, 0);
SeekResult := FStream.Seek(FBufStart, soBeginning);
if SeekResult = -1 then
raise Exception.Create('TBufferedStream.ReadBuffer: seek failed');
FBytesInBuf := FStream.Read(FBuffer^, FBufSize);
@ -148,7 +152,7 @@ var
SeekResult: Integer;
BytesWritten: Integer;
begin
SeekResult := FStream.Seek(FBufStart, 0);
SeekResult := FStream.Seek(FBufStart, soBeginning);
if SeekResult = -1 then
raise Exception.Create('TBufferedStream.WriteBuffer: seek failed');
BytesWritten := FStream.Write(FBuffer^, FBytesInBuf);
@ -167,7 +171,7 @@ end;
function TBufferedStream.Read(var Buffer; Count: Integer): Integer;
var
BufAsBytes : TByteArray absolute Buffer;
BufAsBytes: TByteArray absolute Buffer;
BufIdx, BytesToGo, BytesToRead: Integer;
begin
// Calculate the actual number of bytes we can read - this depends on
@ -215,7 +219,7 @@ begin
BytesToRead := FBytesInBuf;
if BytesToRead > BytesToGo then
BytesToRead := BytesToGo;
// Ccopy from the stream buffer to the caller's buffer
// Copy from the stream buffer to the caller's buffer
Move(FBuffer^, BufAsBytes[BufIdx], BytesToRead);
// Calculate the number of bytes still to read
Dec(BytesToGo, BytesToRead);
@ -338,14 +342,26 @@ end;
{ File IO functions }
function FileOpenRead(FileName: PChar): TImagingHandle; cdecl;
function FileOpen(FileName: PChar; Mode: TOpenMode): TImagingHandle; cdecl;
var
Stream: TStream;
begin
Result := TBufferedStream.Create(TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite));
end;
Stream := nil;
function FileOpenWrite(FileName: PChar): TImagingHandle; cdecl;
begin
Result := TBufferedStream.Create(TFileStream.Create(FileName, fmCreate or fmShareDenyWrite));
case Mode of
omReadOnly: Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
omCreate: Stream := TFileStream.Create(FileName, fmCreate);
omReadWrite:
begin
if FileExists(FileName) then
Stream := TFileStream.Create(FileName, fmOpenReadWrite or fmShareExclusive)
else
Stream := TFileStream.Create(FileName, fmCreate);
end;
end;
Assert(Stream <> nil);
Result := TBufferedStream.Create(Stream);
end;
procedure FileClose(Handle: TImagingHandle); cdecl;
@ -362,37 +378,29 @@ begin
Result := TBufferedStream(Handle).Position = TBufferedStream(Handle).Size;
end;
function FileSeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
LongInt; cdecl;
function FileSeek(Handle: TImagingHandle; Offset: Int64; Mode: TSeekMode): Int64; cdecl;
begin
Result := TBufferedStream(Handle).Seek(Offset, LongInt(Mode));
end;
function FileTell(Handle: TImagingHandle): LongInt; cdecl;
function FileTell(Handle: TImagingHandle): Int64; cdecl;
begin
Result := TBufferedStream(Handle).Position;
end;
function FileRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
LongInt; cdecl;
function FileRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
begin
Result := TBufferedStream(Handle).Read(Buffer^, Count);
end;
function FileWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
LongInt; cdecl;
function FileWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
begin
Result := TBufferedStream(Handle).Write(Buffer^, Count);
end;
{ Stream IO functions }
function StreamOpenRead(FileName: PChar): TImagingHandle; cdecl;
begin
Result := FileName;
end;
function StreamOpenWrite(FileName: PChar): TImagingHandle; cdecl;
function StreamOpen(FileName: PChar; Mode: TOpenMode): TImagingHandle; cdecl;
begin
Result := FileName;
end;
@ -406,13 +414,12 @@ begin
Result := TStream(Handle).Position = TStream(Handle).Size;
end;
function StreamSeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
LongInt; cdecl;
function StreamSeek(Handle: TImagingHandle; Offset: Int64; Mode: TSeekMode): Int64; cdecl;
begin
Result := TStream(Handle).Seek(Offset, LongInt(Mode));
Result := TStream(Handle).Seek(Offset, Word(Mode));
end;
function StreamTell(Handle: TImagingHandle): LongInt; cdecl;
function StreamTell(Handle: TImagingHandle): Int64; cdecl;
begin
Result := TStream(Handle).Position;
end;
@ -423,20 +430,14 @@ begin
Result := TStream(Handle).Read(Buffer^, Count);
end;
function StreamWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
LongInt; cdecl;
function StreamWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
begin
Result := TStream(Handle).Write(Buffer^, Count);
end;
{ Memory IO functions }
function MemoryOpenRead(FileName: PChar): TImagingHandle; cdecl;
begin
Result := FileName;
end;
function MemoryOpenWrite(FileName: PChar): TImagingHandle; cdecl;
function MemoryOpen(FileName: PChar; Mode: TOpenMode): TImagingHandle; cdecl;
begin
Result := FileName;
end;
@ -450,8 +451,7 @@ begin
Result := PMemoryIORec(Handle).Position = PMemoryIORec(Handle).Size;
end;
function MemorySeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
LongInt; cdecl;
function MemorySeek(Handle: TImagingHandle; Offset: Int64; Mode: TSeekMode): Int64; cdecl;
begin
Result := PMemoryIORec(Handle).Position;
case Mode of
@ -463,7 +463,7 @@ begin
PMemoryIORec(Handle).Position := Result;
end;
function MemoryTell(Handle: TImagingHandle): LongInt; cdecl;
function MemoryTell(Handle: TImagingHandle): Int64; cdecl;
begin
Result := PMemoryIORec(Handle).Position;
end;
@ -481,8 +481,7 @@ begin
Rec.Position := Rec.Position + Result;
end;
function MemoryWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
LongInt; cdecl;
function MemoryWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
var
Rec: PMemoryIORec;
begin
@ -496,7 +495,7 @@ end;
{ Helper IO functions }
function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt;
function GetInputSize(const IOFunctions: TIOFunctions; Handle: TImagingHandle): Int64;
var
OldPos: Int64;
begin
@ -513,9 +512,99 @@ begin
Result.Size := Size;
end;
function ReadLine(const IOFunctions: TIOFunctions; Handle: TImagingHandle;
out Line: AnsiString; FailOnControlChars: Boolean): Boolean;
const
MaxLine = 1024;
var
EolPos, Pos: Integer;
C: AnsiChar;
EolReached: Boolean;
Endings: set of AnsiChar;
begin
Line := '';
Pos := 0;
EolPos := 0;
EolReached := False;
Endings := [#10, #13];
Result := True;
while not IOFunctions.Eof(Handle) do
begin
IOFunctions.Read(Handle, @C, SizeOf(C));
if FailOnControlChars and (Byte(C) < $20) then
begin
Break;
end;
if not (C in Endings) then
begin
if EolReached then
begin
IOFunctions.Seek(Handle, EolPos, smFromBeginning);
Exit;
end
else
begin
SetLength(Line, Length(Line) + 1);
Line[Length(Line)] := C;
end;
end
else if not EolReached then
begin
EolReached := True;
EolPos := IOFunctions.Tell(Handle);
end;
Inc(Pos);
if Pos >= MaxLine then
begin
Break;
end;
end;
Result := False;
IOFunctions.Seek(Handle, -Pos, smFromCurrent);
end;
procedure WriteLine(const IOFunctions: TIOFunctions; Handle: TImagingHandle;
const Line: AnsiString; const LineEnding: AnsiString);
var
ToWrite: AnsiString;
begin
ToWrite := Line + LineEnding;
IOFunctions.Write(Handle, @ToWrite[1], Length(ToWrite));
end;
{ TReadMemoryStream }
constructor TReadMemoryStream.Create(Data: Pointer; Size: Integer);
begin
SetPointer(Data, Size);
end;
class function TReadMemoryStream.CreateFromIOHandle(const IOFunctions: TIOFunctions; Handle: TImagingHandle): TReadMemoryStream;
var
Data: Pointer;
Size: Integer;
begin
Size := GetInputSize(IOFunctions, Handle);
GetMem(Data, Size);
IOFunctions.Read(Handle, Data, Size);
Result := TReadMemoryStream.Create(Data, Size);
end;
{ TImagingIOStream }
constructor TImagingIOStream.Create(const IOFunctions: TIOFunctions;
Handle: TImagingHandle);
begin
end;
initialization
OriginalFileIO.OpenRead := FileOpenRead;
OriginalFileIO.OpenWrite := FileOpenWrite;
OriginalFileIO.Open := FileOpen;
OriginalFileIO.Close := FileClose;
OriginalFileIO.Eof := FileEof;
OriginalFileIO.Seek := FileSeek;
@ -523,8 +612,7 @@ initialization
OriginalFileIO.Read := FileRead;
OriginalFileIO.Write := FileWrite;
StreamIO.OpenRead := StreamOpenRead;
StreamIO.OpenWrite := StreamOpenWrite;
StreamIO.Open := StreamOpen;
StreamIO.Close := StreamClose;
StreamIO.Eof := StreamEof;
StreamIO.Seek := StreamSeek;
@ -532,8 +620,7 @@ initialization
StreamIO.Read := StreamRead;
StreamIO.Write := StreamWrite;
MemoryIO.OpenRead := MemoryOpenRead;
MemoryIO.OpenWrite := MemoryOpenWrite;
MemoryIO.Open := MemoryOpen;
MemoryIO.Close := MemoryClose;
MemoryIO.Eof := MemoryEof;
MemoryIO.Seek := MemorySeek;
@ -549,6 +636,14 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.77.3 ---------------------------------------------------
- IO functions now have 64bit sizes and offsets.
- Added helper classes TReadMemoryStream and TImagingIOStream.
-- 0.77.1 ---------------------------------------------------
- Updated IO Open functions according to changes in ImagingTypes.
- Added ReadLine and WriteLine functions.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added merge between buffered read-only and write-only file
stream adapters - TIFF saving needed both reading and writing.
@ -559,7 +654,7 @@ initialization
- Removed TMemoryIORec.Written, use Position to get proper memory
position (Written didn't take Seeks into account).
- Added TBufferedReadFile and TBufferedWriteFile classes for
buffered file reading/writting. File IO functions now use these
buffered file reading/writing. File IO functions now use these
classes resulting in performance increase mainly in file formats
that read/write many small chunks.
- Added fmShareDenyWrite to FileOpenRead. You can now read

262
Imaging/ImagingJpeg.pas
View File

@ -1,29 +1,12 @@
{
$Id: ImagingJpeg.pas 168 2009-08-22 18:50:21Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains image format loader/saver for Jpeg images.}
@ -43,13 +26,22 @@ unit ImagingJpeg;
{$DEFINE IMJPEGLIB}
{ $DEFINE PASJPEG}
{ Automatically use FPC's PasJpeg when compiling with Lazarus. But not when
WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html}
{$IF Defined(LCL) and not Defined(WINDOWS)}
{ Automatically use FPC's PasJpeg when compiling with Lazarus. }
{$IF Defined(LCL)}
{$UNDEF IMJPEGLIB}
{$DEFINE PASJPEG}
{$IFEND}
{ We usually want to skip the rest of the corrupted file when loading JPEG files
instead of getting exception. JpegLib's error handler can only be
exited using setjmp/longjmp ("non-local goto") functions to get error
recovery when loading corrupted JPEG files. This is implemented in assembler
and currently available only for 32bit Delphi targets and FPC.}
{$DEFINE ErrorJmpRecovery}
{$IF Defined(DCC) and not Defined(CPUX86)}
{$UNDEF ErrorJmpRecovery}
{$IFEND}
interface
uses
@ -64,7 +56,8 @@ uses
ImagingUtility;
{$IF Defined(FPC) and Defined(PASJPEG)}
{ When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB}
{ When using FPC's pasjpeg the channel order is BGR instead of RGB.
See RGB_RED_IS_0 in jconfig.inc. }
{$DEFINE RGBSWAPPED}
{$IFEND}
@ -81,6 +74,7 @@ type
FQuality: LongInt;
FProgressive: LongBool;
procedure SetJpegIO(const JpegIO: TIOFunctions); virtual;
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
@ -88,7 +82,6 @@ type
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
procedure CheckOptionsValidity; override;
published
@ -145,15 +138,105 @@ var
JIO: TIOFunctions;
JpegErrorMgr: jpeg_error_mgr;
{ Intenal unit jpeglib support functions }
{ Internal unit jpeglib support functions }
{$IFDEF ErrorJmpRecovery}
{$IFDEF DCC}
type
jmp_buf = record
EBX,
ESI,
EDI,
ESP,
EBP,
EIP: UInt32;
end;
pjmp_buf = ^jmp_buf;
{ JmpLib SetJmp/LongJmp Library
(C)Copyright 2003, 2004 Will DeWitt Jr. <edge@boink.net> }
function SetJmp(out jmpb: jmp_buf): Integer;
asm
{ -> EAX jmpb }
{ <- EAX Result }
MOV EDX, [ESP] // Fetch return address (EIP)
// Save task state
MOV [EAX+jmp_buf.&EBX], EBX
MOV [EAX+jmp_buf.&ESI], ESI
MOV [EAX+jmp_buf.&EDI], EDI
MOV [EAX+jmp_buf.&ESP], ESP
MOV [EAX+jmp_buf.&EBP], EBP
MOV [EAX+jmp_buf.&EIP], EDX
SUB EAX, EAX
@@1:
end;
procedure LongJmp(const jmpb: jmp_buf; retval: Integer);
asm
{ -> EAX jmpb }
{ EDX retval }
{ <- EAX Result }
XCHG EDX, EAX
MOV ECX, [EDX+jmp_buf.&EIP]
// Restore task state
MOV EBX, [EDX+jmp_buf.&EBX]
MOV ESI, [EDX+jmp_buf.&ESI]
MOV EDI, [EDX+jmp_buf.&EDI]
MOV ESP, [EDX+jmp_buf.&ESP]
MOV EBP, [EDX+jmp_buf.&EBP]
MOV [ESP], ECX // Restore return address (EIP)
TEST EAX, EAX // Ensure retval is <> 0
JNZ @@1
MOV EAX, 1
@@1:
end;
{$ENDIF}
type
TJmpBuf = jmp_buf;
TErrorClientData = record
JmpBuf: TJmpBuf;
ScanlineReadReached: Boolean;
end;
PErrorClientData = ^TErrorClientData;
{$ENDIF}
procedure JpegError(CInfo: j_common_ptr);
var
Buffer: string;
procedure RaiseError;
var
Buffer: AnsiString;
begin
// Create the message and raise exception
CInfo.err.format_message(CInfo, Buffer);
// Warning: you can get "Invalid argument index in format" exception when
// using FPC (see http://bugs.freepascal.org/view.php?id=21229).
// Fixed in FPC 2.7.1
{$IF Defined(FPC) and (FPC_FULLVERSION <= 20701)}
raise EImagingError.CreateFmt(SJPEGError + ' %d', [CInfo.err.msg_code]);
{$ELSE}
raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + string(Buffer), [CInfo.err.msg_code]);
{$IFEND}
end;
begin
{ Create the message and raise exception }
CInfo^.err^.format_message(CInfo, buffer);
raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]);
{$IFDEF ErrorJmpRecovery}
// Only recovers on loads and when header is successfully loaded
// (error occurs when reading scanlines)
if (CInfo.client_data <> nil) and
PErrorClientData(CInfo.client_data).ScanlineReadReached then
begin
// Non-local jump to error handler in TJpegFileFormat.LoadData
longjmp(PErrorClientData(CInfo.client_data).JmpBuf, 1)
end
else
RaiseError;
{$ELSE}
RaiseError;
{$ENDIF}
end;
procedure OutputMessage(CurInfo: j_common_ptr);
@ -185,8 +268,8 @@ begin
if NBytes <= 0 then
begin
PChar(Src.Buffer)[0] := #$FF;
PChar(Src.Buffer)[1] := Char(JPEG_EOI);
PByteArray(Src.Buffer)[0] := $FF;
PByteArray(Src.Buffer)[1] := JPEG_EOI;
NBytes := 2;
end;
Src.Pub.next_input_byte := Src.Buffer;
@ -295,14 +378,16 @@ begin
Dest.Output := Handle;
end;
procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
procedure SetupErrorMgr(var jc: TJpegContext);
begin
FillChar(jc, sizeof(jc), 0);
// Set standard error handlers and then override some
jc.common.err := jpeg_std_error(JpegErrorMgr);
jc.common.err.error_exit := JpegError;
jc.common.err.output_message := OutputMessage;
end;
procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
begin
jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
JpegStdioSrc(jc.d, Handle);
jpeg_read_header(@jc.d, True);
@ -319,18 +404,12 @@ end;
procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
Saver: TJpegFileFormat);
begin
FillChar(jc, sizeof(jc), 0);
// Set standard error handlers and then override some
jc.common.err := jpeg_std_error(JpegErrorMgr);
jc.common.err.error_exit := JpegError;
jc.common.err.output_message := OutputMessage;
jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
JpegStdioDest(jc.c, Handle);
if Saver.FGrayScale then
jc.c.in_color_space := JCS_GRAYSCALE
else
jc.c.in_color_space := JCS_YCbCr;
jc.c.in_color_space := JCS_RGB;
jpeg_set_defaults(@jc.c);
jpeg_set_quality(@jc.c, Saver.FQuality, True);
if Saver.FProgressive then
@ -339,13 +418,10 @@ end;
{ TJpegFileFormat class implementation }
constructor TJpegFileFormat.Create;
procedure TJpegFileFormat.Define;
begin
inherited Create;
FName := SJpegFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := False;
FFeatures := [ffLoad, ffSave];
FSupportedFormats := JpegSupportedFormats;
FQuality := JpegDefaultQuality;
@ -371,9 +447,27 @@ var
jc: TJpegContext;
Info: TImageFormatInfo;
Col32: PColor32Rec;
{$IFDEF RGBSWAPPED}
NeedsRedBlueSwap: Boolean;
Pix: PColor24Rec;
{$IFDEF ErrorJmpRecovery}
ErrorClient: TErrorClientData;
{$ENDIF}
procedure LoadMetaData;
var
ResUnit: TResolutionUnit;
begin
// Density unit: 0 - undef, 1 - inch, 2 - cm
if jc.d.saw_JFIF_marker and (jc.d.density_unit > 0) and
(jc.d.X_density > 0) and (jc.d.Y_density > 0) then
begin
ResUnit := ruDpi;
if jc.d.density_unit = 2 then
ResUnit := ruDpcm;
FMetadata.SetPhysicalPixelSize(ResUnit, jc.d.X_density, jc.d.Y_density);
end;
end;
begin
// Copy IO functions to global var used in JpegLib callbacks
Result := False;
@ -382,7 +476,19 @@ begin
with JIO, Images[0] do
try
ZeroMemory(@jc, SizeOf(jc));
SetupErrorMgr(jc);
{$IFDEF ErrorJmpRecovery}
ZeroMemory(@ErrorClient, SizeOf(ErrorClient));
jc.common.client_data := @ErrorClient;
if setjmp(ErrorClient.JmpBuf) <> 0 then
begin
Result := True;
Exit;
end;
{$ENDIF}
InitDecompressor(Handle, jc);
case jc.d.out_color_space of
JCS_GRAYSCALE: Format := ifGray8;
JCS_RGB: Format := ifR8G8B8;
@ -390,6 +496,7 @@ begin
else
Exit;
end;
NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
jpeg_start_decompress(@jc.d);
GetImageFormatInfo(Format, Info);
@ -397,11 +504,22 @@ begin
LinesPerCall := 1;
Dest := Bits;
// If Jpeg's colorspace is RGB and not YCbCr we need to swap
// R and B to get Imaging's native order
NeedsRedBlueSwap := jc.d.jpeg_color_space = JCS_RGB;
{$IFDEF RGBSWAPPED}
// Force R-B swap for FPC's PasJpeg
NeedsRedBlueSwap := True;
{$ENDIF}
{$IFDEF ErrorJmpRecovery}
ErrorClient.ScanlineReadReached := True;
{$ENDIF}
while jc.d.output_scanline < jc.d.output_height do
begin
LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
{$IFDEF RGBSWAPPED}
if Format = ifR8G8B8 then
if NeedsRedBlueSwap and (Format = ifR8G8B8) then
begin
Pix := PColor24Rec(Dest);
for I := 0 to Width - 1 do
@ -410,7 +528,6 @@ begin
Inc(Pix);
end;
end;
{$ENDIF}
Inc(Dest, PtrInc * LinesRead);
end;
@ -427,6 +544,9 @@ begin
end;
end;
// Store supported metadata
LoadMetaData;
jpeg_finish_output(@jc.d);
jpeg_finish_decompress(@jc.d);
Result := True;
@ -448,14 +568,31 @@ var
I: LongInt;
Pix: PColor24Rec;
{$ENDIF}
procedure SaveMetaData;
var
XRes, YRes: Double;
begin
if FMetadata.GetPhysicalPixelSize(ruDpcm, XRes, YRes, True) then
begin
jc.c.density_unit := 2; // Dots per cm
jc.c.X_density := Round(XRes);
jc.c.Y_density := Round(YRes)
end;
end;
begin
Result := False;
// Copy IO functions to global var used in JpegLib callbacks
SetJpegIO(GetIO);
// Makes image to save compatible with Jpeg saving capabilities
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
with JIO, ImageToSave do
try
ZeroMemory(@jc, SizeOf(jc));
SetupErrorMgr(jc);
GetImageFormatInfo(Format, Info);
FGrayScale := Format = ifGray8;
InitCompressor(Handle, jc, Self);
@ -479,6 +616,9 @@ begin
GetMem(Line, PtrInc);
{$ENDIF}
// Save supported metadata
SaveMetaData;
jpeg_start_compress(@jc.c, True);
while (jc.c.next_scanline < jc.c.image_height) do
begin
@ -553,8 +693,20 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.77.1 ---------------------------------------------------
- Able to read corrupted JPEG files - loads partial image
and skips the corrupted parts (FPC and x86 Delphi).
- Fixed reading of physical resolution metadata, could cause
"divided by zero" later on for some files.
-- 0.26.5 Changes/Bug Fixes ---------------------------------
- Fixed loading of some JPEGs with certain APPN markers (bug in JpegLib).
- Fixed swapped Red-Blue order when loading Jpegs with
jc.d.jpeg_color_space = JCS_RGB.
- Added loading and saving of physical pixel size metadata.
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Changed the Jpeg error manager, messages were not properly formated.
- Changed the Jpeg error manager, messages were not properly formatted.
-- 0.26.1 Changes/Bug Fixes ---------------------------------
- Fixed wrong color space setting in InitCompressor.

608
Imaging/ImagingNetworkGraphics.pas
View File

File diff suppressed because it is too large Load Diff

121
Imaging/ImagingOpenGL.pas
View File

@ -1,29 +1,12 @@
{
$Id: ImagingOpenGL.pas 165 2009-08-14 12:34:40Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains functions for loading and saving OpenGL textures
@ -33,17 +16,18 @@ unit ImagingOpenGL;
{$I ImagingOptions.inc}
{ Define this symbol if you want to use dglOpenGL header.}
{ $DEFINE USE_DGL_HEADERS}
{ $DEFINE USE_GLSCENE_HEADERS}
{$DEFINE OPENGL_USE_DGL_HEADERS}
{$IFDEF OPENGL_NO_EXT_HEADERS}
{$UNDEF OPENGL_USE_DGL_HEADERS}
{$ENDIF}
interface
uses
SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats,
{$IF Defined(USE_DGL_HEADERS)}
{$IF Defined(OPENGL_USE_DGL_HEADERS)}
dglOpenGL,
{$ELSEIF Defined(USE_GLSCENE_HEADERS)}
OpenGL1x,
{$ELSE}
gl, glext,
{$IFEND}
@ -144,7 +128,7 @@ function SaveGLTextureToStream(const Ext: string; Stream: TStream; const Texture
Saves all present mipmap levels.}
function SaveGLTextureToMemory(const Ext: string; Data: Pointer; var Size: LongInt; const Texture: GLuint): Boolean;
{ Converts main level of the GL texture to TImageData strucrue. OverrideFormat
{ Converts main level of the GL texture to TImageData structure. OverrideFormat
can be used to convert output image to the specified format rather
than use the format taken from GL texture, ifUnknown means no conversion.}
function CreateImageFromGLTexture(const Texture: GLuint;
@ -168,23 +152,23 @@ var
pow2 texture is created and nonpow2 input image is pasted into it
keeping its original size. This could be useful for some 2D stuff
(and its faster than rescaling of course). Note that this is applied
to all rescaling smaller->bigger operations that might ocurr during
to all rescaling smaller->bigger operations that might occur during
image->texture process (usually only pow2/nonpow2 stuff and when you
set custom Width & Height in CreateGLTextureFrom(Multi)Image).}
PasteNonPow2ImagesIntoPow2: Boolean = False;
{ Standard behaviur if GL_ARB_texture_non_power_of_two extension is not supported
{ Standard behavior if GL_ARB_texture_non_power_of_two extension is not supported
is to rescale image to power of 2 dimensions. NPOT extension is exposed only
when HW has full support for NPOT textures but some cards
(ATI Radeons, some other maybe) have partial NPOT support. Namely Radeons
can use NPOT textures but not mipmapped. If you know what you are doing
(pre-DX10 ATI Radeons, some other maybe) have partial NPOT support.
Namely Radeons can use NPOT textures but not mipmapped. If you know what you are doing
you can disable NPOT support check so the image won't be rescaled to POT
by seting DisableNPOTSupportCheck to True.}
by setting DisableNPOTSupportCheck to True.}
DisableNPOTSupportCheck: Boolean = False;
implementation
const
// cube map consts
// Cube map constants
GL_TEXTURE_BINDING_CUBE_MAP = $8514;
GL_TEXTURE_CUBE_MAP_POSITIVE_X = $8515;
GL_TEXTURE_CUBE_MAP_NEGATIVE_X = $8516;
@ -193,7 +177,7 @@ const
GL_TEXTURE_CUBE_MAP_POSITIVE_Z = $8519;
GL_TEXTURE_CUBE_MAP_NEGATIVE_Z = $851A;
// texture formats
// Texture formats
GL_COLOR_INDEX = $1900;
GL_STENCIL_INDEX = $1901;
GL_DEPTH_COMPONENT = $1902;
@ -208,7 +192,7 @@ const
GL_BGR_EXT = $80E0;
GL_BGRA_EXT = $80E1;
// texture internal formats
// Texture internal formats
GL_ALPHA4 = $803B;
GL_ALPHA8 = $803C;
GL_ALPHA12 = $803D;
@ -242,8 +226,9 @@ const
GL_RGB10_A2 = $8059;
GL_RGBA12 = $805A;
GL_RGBA16 = $805B;
GL_RGB565 = $8D62;
// floating point texture formats
// Floating point texture formats
GL_RGBA32F_ARB = $8814;
GL_INTENSITY32F_ARB = $8817;
GL_LUMINANCE32F_ARB = $8818;
@ -251,22 +236,46 @@ const
GL_INTENSITY16F_ARB = $881D;
GL_LUMINANCE16F_ARB = $881E;
// compressed texture formats
// Compressed texture formats
// S3TC/DXTC
GL_COMPRESSED_RGB_S3TC_DXT1_EXT = $83F0;
GL_COMPRESSED_RGBA_S3TC_DXT1_EXT = $83F1;
GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2;
GL_COMPRESSED_RGBA_S3TC_DXT5_EXT = $83F3;
// 3Dc LATC
GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI = $8837;
GL_COMPRESSED_LUMINANCE_LATC1_EXT = $8C70;
GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT = $8C71;
GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT = $8C72;
GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT = $8C73;
// ETC1 GL_OES_compressed_ETC1_RGB8_texture
GL_ETC1_RGB_OES = $8D64;
// PVRTC GL_IMG_texture_compression_pvrtc
GL_COMPRESSED_RGB_PVRTC_4BPPV1_IMG = $8C00;
GL_COMPRESSED_RGB_PVRTC_2BPPV1_IMG = $8C01;
GL_COMPRESSED_RGBA_PVRTC_4BPPV1_IMG = $8C02;
GL_COMPRESSED_RGBA_PVRTC_2BPPV1_IMG = $8C03;
// AMD ATC
GL_ATC_RGBA_EXPLICIT_ALPHA_AMD = $8C93;
GL_ATC_RGBA_INTERPOLATED_ALPHA_AMD = $87EE;
// ETC2/EAC
GL_COMPRESSED_R11_EAC = $9270;
GL_COMPRESSED_SIGNED_R11_EAC = $9271;
GL_COMPRESSED_RG11_EAC = $9272;
GL_COMPRESSED_SIGNED_RG11_EAC = $9273;
GL_COMPRESSED_RGB8_ETC2 = $9274;
GL_COMPRESSED_SRGB8_ETC2 = $9275;
GL_COMPRESSED_RGB8_PUNCHTHROUGH_ALPHA1_ETC2 = $9276;
GL_COMPRESSED_SRGB8_PUNCHTHROUGH_ALPHA1_ETC2 = $9277;
GL_COMPRESSED_RGBA8_ETC2_EAC = $9278;
GL_COMPRESSED_SRGB8_ALPHA8_ETC2_EAC = $9279;
// various GL extension constants
// Various GL extension constants
GL_MAX_TEXTURE_UNITS = $84E2;
GL_TEXTURE_MAX_ANISOTROPY_EXT = $84FE;
GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT = $84FF;
// texture source data formats
// Texture source data formats
GL_UNSIGNED_BYTE_3_3_2 = $8032;
GL_UNSIGNED_SHORT_4_4_4_4 = $8033;
GL_UNSIGNED_SHORT_5_5_5_1 = $8034;
@ -302,10 +311,10 @@ var
ExtensionBuffer: string = '';
{$IFDEF MSWINDOWS}
function wglGetProcAddress(ProcName: PChar): Pointer; stdcall; external GLLibName;
function wglGetProcAddress(ProcName: PAnsiChar): Pointer; stdcall; external GLLibName;
{$ENDIF}
{$IFDEF UNIX}
function glXGetProcAddress(ProcName: PChar): Pointer; cdecl; external GLLibName;
function glXGetProcAddress(ProcName: PAnsiChar): Pointer; cdecl; external GLLibName;
{$ENDIF}
function IsGLExtensionSupported(const Extension: string): Boolean;
@ -327,16 +336,16 @@ end;
function GetGLProcAddress(const ProcName: string): Pointer;
begin
{$IFDEF MSWINDOWS}
Result := wglGetProcAddress(PChar(ProcName));
Result := wglGetProcAddress(PAnsiChar(AnsiString(ProcName)));
{$ENDIF}
{$IFDEF UNIX}
Result := glXGetProcAddress(PChar(ProcName));
Result := glXGetProcAddress(PAnsiChar(AnsiString(ProcName)));
{$ENDIF}
end;
function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean;
begin
// Check DXTC support and load extension functions if necesary
// Check DXTC support and load extension functions if necessary
Caps.DXTCompression := IsGLExtensionSupported('GL_ARB_texture_compression') and
IsGLExtensionSupported('GL_EXT_texture_compression_s3tc');
if Caps.DXTCompression then
@ -408,7 +417,7 @@ begin
begin
GLFormat := GL_RGB;
GLType := GL_UNSIGNED_SHORT_5_6_5;
GLInternal := GL_RGB5;
GLInternal := GL_RGB5; //GL_RGB565 ot working on Radeons
end;
ifA1R5G5B5, ifX1R5G5B5:
begin
@ -656,7 +665,7 @@ begin
// Generate new texture, bind it and set
glGenTextures(1, @Result);
glBindTexture(GL_TEXTURE_2D, Result);
if Byte(glIsTexture(Result)) <> GL_TRUE then
if glIsTexture(Result) <> GL_TRUE then
Exit;
for I := MainLevelIndex to MipLevels - 1 + MainLevelIndex do
@ -843,12 +852,16 @@ begin
FreeImagesInArray(Images);
SetLength(Images, 0);
Result := False;
if Byte(glIsTexture(Texture)) = GL_TRUE then
if glIsTexture(Texture) = GL_TRUE then
begin
// Check if desired mipmap level count is valid
glBindTexture(GL_TEXTURE_2D, Texture);
if MipLevels <= 0 then
begin
glGetTexLevelParameteriv(GL_TEXTURE_2D, 0, GL_TEXTURE_WIDTH, @Width);
glGetTexLevelParameteriv(GL_TEXTURE_2D, 0, GL_TEXTURE_HEIGHT, @Height);
MipLevels := GetNumMipMapLevels(Width, Height);
end;
SetLength(Images, MipLevels);
ExistingLevels := 0;
@ -883,9 +896,13 @@ initialization
File Notes:
-- TODOS ----------------------------------------------------
- use internal format of texture in CreateMultiImageFromGLTexture
not only A8R8G8B8
- support for cube and 3D maps
-- 0.77.1 ---------------------------------------------------
- Added some new compressed formats IDs
-- 0.26.5 Changes/Bug Fixes ---------------------------------
- Fixed GetGLProcAddress in Unicode Delphi. Compressed
textures didn't work because of this.
-- 0.26.1 Changes/Bug Fixes ---------------------------------
- Added support for GLScene's OpenGL header.

132
Imaging/ImagingOptions.inc
View File

@ -1,5 +1,3 @@
{ $Id: ImagingOptions.inc 174 2009-09-08 09:37:59Z galfar $ }
{
User Options
Following defines and options can be changed by user.
@ -9,21 +7,24 @@
{$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
{$DEFINE USE_ASM} // If defined, assembler versions of some
// functions will be used (only for x86).
// Debug options: If none of these two are defined
// your project settings are used.
{ $DEFINE IMAGING_DEBUG} // If defined, debug info, range/IO/overflow
{.$DEFINE IMAGING_DEBUG} // If defined, debug info, range/IO/overflow
// checking, stack frames, assertions, and
// other debugging options will be turned on.
{$DEFINE IMAGING_RELEASE} // If defined, all debug info is off.
{$DEFINE OPENGL_NO_EXT_HEADERS}
(* File format support linking options.
Define formats which you don't want to be registred automatically.
Default: all formats are registered = no symbols defined.
Define formats which you don't want to be registered automatically (by adding
Imaging.pas unit to your uses clause).
Default: most formats are registered = no symbols defined.
Example: If you want to disable JPEG support just uncomment //{$DEFINE DONT_LINK_JPEG} line
*)
@ -36,18 +37,14 @@
{$DEFINE DONT_LINK_MNG} // link support for MNG images
{$DEFINE DONT_LINK_JNG} // link support for JNG images
{$DEFINE DONT_LINK_PNM} // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM)
{$DEFINE DONT_LINK_RADHDR} // link support for Radiance HDR/RGBE file format
{$DEFINE DONT_LINK_EXTRAS} // link support for file formats defined in
// Extras package. Exactly which formats will be
// Extensions package. Exactly which formats will be
// registered depends on settings in
// ImagingExtras.pas unit.
// ImagingExtFileFormats.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)
{.$DEFINE DONT_LINK_FILE_FORMATS} // no auto link support of any file format
{
Auto Options
@ -62,26 +59,29 @@
{$BOOLEVAL OFF} // Boolean eval: off
{$EXTENDEDSYNTAX ON} // Extended syntax: on
{$LONGSTRINGS ON} // string = AnsiString: on
{$MINENUMSIZE 4} // Min enum size: 4 B
{$MINENUMSIZE 1} // Min enum size: 1 B
{$TYPEDADDRESS OFF} // Typed pointers: off
{$WRITEABLECONST OFF} // Writeable constants: off
{$IFNDEF FPC}
{$DEFINE DCC} // if not using FPC then DCC compiler is used (Delphi/Kylix)
{$DEFINE DCC} // if not using FPC then DCC compiler is used (Delphi/BCB)
// others are not supported
{$ENDIF}
{$IFDEF DCC}
{$IFDEF LINUX}
{$DEFINE KYLIX} // using Kylix
{$ENDIF}
{$DEFINE DELPHI}
{$IF (Defined(DCC) and (CompilerVersion >= 25.0))}
{$LEGACYIFEND ON}
{$IFEND}
{$ENDIF}
{$IFDEF DCC}
{$IFNDEF KYLIX}
{$DEFINE DELPHI} // using Delphi
{$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}
{$ENDIF}
{$IFEND}
{$IF Defined(IMAGING_DEBUG)}
{$ASSERTIONS ON}
@ -115,32 +115,87 @@
{$ENDIF}
{$IFEND}
{$IF Defined(CPU86) and not Defined(CPUX86)}
{$DEFINE CPUX86} // Compatibility with Delphi
{$IFEND}
{$IF Defined(CPUX86_64) and not Defined(CPUX64)}
{$DEFINE CPUX64} // Compatibility with Delphi
{$IFEND}
{$IF Defined(DARWIN) and not Defined(MACOS)}
{$DEFINE MACOS} // Compatibility with Delphi
{$IFEND}
{$IF Defined(MACOS)}
{$DEFINE MACOSX}
{$IFEND}
{$IF Defined(DCC) and (CompilerVersion < 23)} // < XE2
{$DEFINE CPUX86} // Compatibility with older Delphi
{$IFEND}
{$IF Defined(WIN32) or Defined(WIN64)}
{$DEFINE MSWINDOWS} // Compatibility with Delphi
{$IFEND}
{$IF Defined(UNIX) and not Defined(POSIX)}
{$DEFINE POSIX} // Compatibility with Delphi
{$IFEND}
{ Compiler capabilities }
// Define if compiler supports inlining of functions and procedures
// Note that FPC inline support crashed in older versions (1.9.8)
{$IF (Defined(FPC) and Defined(CPU86))}
{$IF (Defined(DCC) and (CompilerVersion >= 17)) or Defined(FPC)}
{$DEFINE HAS_INLINE}
{$IFEND}
// Define if compiler supports advanced records with methods
{$IF (Defined(DCC) and (CompilerVersion >= 18)) or
(Defined(FPC) and (FPC_FULLVERSION >= 20600))}
{$DEFINE HAS_ADVANCED_RECORDS}
{$IFEND}
// Define if compiler supports operator overloading
// (unfortunately Delphi and FPC operator overloaing is not compatible)
{$IF Defined(FPC)}
// (unfortunately Delphi and FPC operator overloading is not compatible).
// FPC supports Delphi compatible operator overloads since 2.6.0
{$IF (Defined(DCC) and (CompilerVersion >= 18)) or
(Defined(FPC) and (FPC_FULLVERSION >= 20600))}
{$DEFINE HAS_OPERATOR_OVERLOADING}
{$IFEND}
// Anonymous methods
{$IF Defined(DCC) and (CompilerVersion >= 20) }
{$DEFINE HAS_ANON_METHODS}
{$IFEND}
// Generic types (Delphi and FPC implementations incompatible).
// Update: FPC supports Delphi compatible generics since 2.6.0
{$IF (Defined(DCC) and (CompilerVersion >= 20)) or
(Defined(FPC) and (FPC_FULLVERSION >= 20600))}
{$DEFINE HAS_GENERICS}
{$IFEND}
{ Compiler pecularities }
// Delphi 64bit POSIX targets
{$IF Defined(DCC) and (SizeOf(Integer) <> SizeOf(LongInt))}
{$DEFINE LONGINT_IS_NOT_INTEGER}
{$IFEND}
// They used to force IFEND, now they warn about it
{$IF Defined(DCC) and (CompilerVersion >= 33)}
{$LEGACYIFEND ON}
{$IFEND}
{ Imaging options check}
{$IFNDEF HAS_INLINE}
{$UNDEF USE_INLINE}
{$ENDIF}
{$IFDEF FPC}
{$IFNDEF CPU86}
{$IF not Defined(CPUX86)}
{$UNDEF USE_ASM}
{$ENDIF}
{$ENDIF}
{$IFEND}
{$IFDEF FPC}
{$DEFINE COMPONENT_SET_LCL}
@ -152,20 +207,6 @@
{$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)
@ -175,7 +216,6 @@
{$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}

163
Imaging/ImagingPortableMaps.pas
View File

@ -1,29 +1,12 @@
{
$Id: ImagingPortableMaps.pas 163 2009-07-28 21:44:10Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains loader/saver for Portable Maps file format family (or PNM).
@ -65,12 +48,13 @@ type
protected
FIdNumbers: TChar2;
FSaveBinary: LongBool;
FUSFormat: TFormatSettings;
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
{ If set to True images will be saved in binary format. If it is False
@ -85,32 +69,30 @@ type
PBM images can be loaded but not saved. Loaded images are returned in
ifGray8 format (witch pixel values scaled from 1bit to 8bit).}
TPBMFileFormat = class(TPortableMapFileFormat)
public
constructor Create; override;
protected
procedure Define; override;
end;
{ Portable Gray Map is used to store grayscale 8bit or 16bit images.
Raster data can be saved as text or binary data.}
TPGMFileFormat = class(TPortableMapFileFormat)
protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
end;
{ Portable Pixel Map is used to store RGB images with 8bit or 16bit channels.
Raster data can be saved as text or binary data.}
TPPMFileFormat = class(TPortableMapFileFormat)
protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
end;
{ Portable Arbitrary Map is format that can store image data formats
@ -120,12 +102,11 @@ type
ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.}
TPAMFileFormat = class(TPortableMapFileFormat)
protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
end;
{ Portable Float Map is unofficial extension of PNM format family which
@ -134,12 +115,11 @@ type
or RGB images are supported by PFM format (so no alpha).}
TPFMFileFormat = class(TPortableMapFileFormat)
protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
end;
implementation
@ -161,7 +141,7 @@ const
ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16];
SPFMFormatName = 'Portable Float Map';
SPFMMasks = '*.pfm';
PFMSupportedFormats = [ifR32F, ifA32B32G32R32F];
PFMSupportedFormats = [ifR32F, ifB32G32R32F];
const
{ TAB, CR, LF, and Space are used as seperators in Portable map headers and data.}
@ -183,13 +163,12 @@ const
{ TPortableMapFileFormat }
constructor TPortableMapFileFormat.Create;
procedure TPortableMapFileFormat.Define;
begin
inherited Create;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := False;
inherited;
FFeatures := [ffLoad, ffSave];
FSaveBinary := PortableMapDefaultBinary;
FUSFormat := GetFormatSettingsForFloats;
end;
function TPortableMapFileFormat.LoadData(Handle: TImagingHandle;
@ -199,7 +178,6 @@ var
Dest: PByte;
MonoData: Pointer;
Info: TImageFormatInfo;
PixelFP: TColorFPRec;
LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar;
LineEnd, LinePos: LongInt;
MapInfo: TPortableMapInfo;
@ -263,7 +241,7 @@ var
C := LineBuffer[LinePos];
Inc(LinePos);
until not (C in WhiteSpaces) or (LineEnd = 0);
// Dec pos, current is the begining of the the string
// Dec pos, current is the beginning of the the string
Dec(LinePos);
Result := string(S);
@ -296,7 +274,6 @@ var
I: TTupleType;
TupleTypeName: string;
Scale: Single;
OldSeparator: Char;
begin
Result := False;
with GetIO do
@ -368,10 +345,7 @@ var
// Read header of PFM file
MapInfo.Width := ReadIntValue;
MapInfo.Height := ReadIntValue;
OldSeparator := DecimalSeparator;
DecimalSeparator := '.';
Scale := StrToFloatDef(ReadString, 0);
DecimalSeparator := OldSeparator;
Scale := StrToFloatDef(ReadString, 0, FUSFormat);
MapInfo.IsBigEndian := Scale > 0.0;
if Id[1] = 'F' then
MapInfo.TupleType := ttRGBFP
@ -387,7 +361,7 @@ var
if MapInfo.Binary and not (Id[1] in ['F', 'f']) then
begin
// Mimic the behaviour of Photoshop and other editors/viewers:
// If linenreaks in file are DOS CR/LF 16bit binary values are
// If linereaks in file are DOS CR/LF 16bit binary values are
// little endian, Unix LF only linebreak indicates big endian.
MapInfo.IsBigEndian := LineBreak = #10;
end;
@ -411,6 +385,7 @@ begin
LineEnd := 0;
LinePos := 0;
SetLength(Images, 1);
with GetIO, Images[0] do
begin
Format := ifUnknown;
@ -425,7 +400,7 @@ begin
ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
ttGrayScaleFP: Format := ifR32F;
ttRGBFP: Format := ifA32B32G32R32F;
ttRGBFP: Format := ifB32G32R32F;
end;
// Exit if no matching data format was found
if Format = ifUnknown then Exit;
@ -482,27 +457,9 @@ begin
// FP images are in BGR order and endian swap maybe needed.
// Some programs store scanlines in bottom-up order but
// I will stick with Photoshops behaviour here
for I := 0 to Width * Height - 1 do
begin
Read(Handle, @PixelFP, MapInfo.BitCount div 8);
if MapInfo.TupleType = ttRGBFP then
with PColorFPRec(Dest)^ do
begin
A := 1.0;
R := PixelFP.R;
G := PixelFP.G;
B := PixelFP.B;
Read(Handle, Bits, Size);
if MapInfo.IsBigEndian then
SwapEndianLongWord(PLongWord(Dest), 3);
end
else
begin
PSingle(Dest)^ := PixelFP.B;
if MapInfo.IsBigEndian then
SwapEndianLongWord(PLongWord(Dest), 1);
end;
Inc(Dest, Info.BytesPerPixel);
end;
SwapEndianUInt32(PUInt32(Dest), Size div SizeOf(UInt32));
end;
if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
@ -532,8 +489,8 @@ begin
GetMem(MonoData, MonoSize);
try
Read(Handle, MonoData, MonoSize);
Convert1To8(MonoData, Bits, Width, Height, ScanLineSize);
// 1bit mono images must be scaled to 8bit (where 0=white, 1=black)
Convert1To8(MonoData, Bits, Width, Height, ScanLineSize, False);
// 1bit mono images must be scaled to 8bit, but inverted (where 0=white, 1=black)
for I := 0 to Width * Height - 1 do
PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255;
finally
@ -565,7 +522,7 @@ begin
end;
function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer; var MapInfo: TPortableMapInfo): Boolean;
const Images: TDynImageDataArray; Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
const
// Use Unix linebreak, for many viewers/editors it means that
// 16bit samples are stored as big endian - so we need to swap byte order
@ -595,8 +552,6 @@ var
end;
procedure WriteHeader;
var
OldSeparator: Char;
begin
WriteString('P' + MapInfo.FormatId);
if not MapInfo.HasPAMHeader then
@ -608,11 +563,8 @@ var
ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1));
ttGrayScaleFP, ttRGBFP:
begin
OldSeparator := DecimalSeparator;
DecimalSeparator := '.';
// Negative value indicates that raster data is saved in little endian
WriteString(FloatToStr(-1.0));
DecimalSeparator := OldSeparator;
WriteString(FloatToStr(-1.0, FUSFormat));
end;
end;
end
@ -699,7 +651,7 @@ begin
end
else
begin
// 8bit RGB/ARGB images: read and blue must be swapped and
// 8bit RGB/ARGB images: red and blue must be swapped and
// 3 or 4 bytes must be written
Src := Bits;
for I := 0 to Width * Height - 1 do
@ -750,23 +702,7 @@ begin
begin
// Floating point images (no need to swap endian here - little
// endian is specified in file header)
if MapInfo.TupleType = ttGrayScaleFP then
begin
// Grayscale images can be written in one Write call
Write(Handle, Bits, Size);
end
else
begin
// Expected data format of PFM RGB file is B32G32R32F which is not
// supported by Imaging. We must write pixels one by one and
// write only RGB part of A32B32G32B32 image.
Src := Bits;
for I := 0 to Width * Height - 1 do
begin
Write(Handle, Src, SizeOf(Single) * 3);
Inc(Src, Info.BytesPerPixel);
end;
end;
end;
end;
Result := True;
@ -794,20 +730,20 @@ end;
{ TPBMFileFormat }
constructor TPBMFileFormat.Create;
procedure TPBMFileFormat.Define;
begin
inherited Create;
inherited;
FName := SPBMFormatName;
FCanSave := False;
FFeatures := [ffLoad];
AddMasks(SPBMMasks);
FIdNumbers := '14';
end;
{ TPGMFileFormat }
constructor TPGMFileFormat.Create;
procedure TPGMFileFormat.Define;
begin
inherited Create;
inherited;
FName := SPGMFormatName;
FSupportedFormats := PGMSupportedFormats;
AddMasks(SPGMMasks);
@ -816,7 +752,7 @@ begin
end;
function TPGMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
MapInfo: TPortableMapInfo;
begin
@ -853,9 +789,9 @@ end;
{ TPPMFileFormat }
constructor TPPMFileFormat.Create;
procedure TPPMFileFormat.Define;
begin
inherited Create;
inherited;
FName := SPPMFormatName;
FSupportedFormats := PPMSupportedFormats;
AddMasks(SPPMMasks);
@ -864,7 +800,7 @@ begin
end;
function TPPMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
MapInfo: TPortableMapInfo;
begin
@ -901,9 +837,9 @@ end;
{ TPAMFileFormat }
constructor TPAMFileFormat.Create;
procedure TPAMFileFormat.Define;
begin
inherited Create;
inherited;
FName := SPAMFormatName;
FSupportedFormats := PAMSupportedFormats;
AddMasks(SPAMMasks);
@ -911,7 +847,7 @@ begin
end;
function TPAMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
MapInfo: TPortableMapInfo;
begin
@ -943,9 +879,9 @@ end;
{ TPFMFileFormat }
constructor TPFMFileFormat.Create;
procedure TPFMFileFormat.Define;
begin
inherited Create;
inherited;
FName := SPFMFormatName;
AddMasks(SPFMMasks);
FIdNumbers := 'Ff';
@ -953,7 +889,7 @@ begin
end;
function TPFMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
Info: TImageFormatInfo;
MapInfo: TPortableMapInfo;
@ -979,7 +915,7 @@ procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
begin
if (Info.ChannelCount > 1) or Info.IsIndexed then
ConvertImage(Image, ifA32B32G32R32F)
ConvertImage(Image, ifB32G32R32F)
else
ConvertImage(Image, ifR32F);
end;
@ -997,6 +933,11 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.77.1 Changes/Bug Fixes -----------------------------------
- Native RGB floating point format of PFM is now supported by Imaging
so we use it now for saving instead of A32B32G32B32.
- String to float formatting changes (don't change global settings).
-- 0.26.3 Changes/Bug Fixes -----------------------------------
- Fixed D2009 Unicode related bug in PNM saving.

480
Imaging/ImagingRadiance.pas Normal file
View File

@ -0,0 +1,480 @@
{
Vampyre Imaging Library
by Marek Mauder
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains image format loader/saver for Radiance HDR/RGBE images.}
unit ImagingRadiance;
{$I ImagingOptions.inc}
interface
uses
SysUtils, Classes, Imaging, ImagingTypes, ImagingUtility;
type
{ Radiance is a suite of tools for performing lighting simulation. It's
development started in 1985 and it pioneered the concept of
high dynamic range imaging. Radiance defined an image format for storing
HDR images, now described as RGBE image format. Since it was the first
HDR image format, this format is supported by many other software packages.
Radiance image file consists of three sections: a header, resolution string,
followed by the pixel data. Each pixel is stored as 4 bytes, one byte
mantissa for each r, g, b and a shared one byte exponent.
The pixel data may be stored uncompressed or using run length encoding.
Imaging translates RGBE pixels to original float values and stores them
in ifR32G32B32F data format. It can read both compressed and uncompressed
files, and saves files as compressed.}
THdrFileFormat = class(TImageFileFormat)
protected
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
function TestFormat(Handle: TImagingHandle): Boolean; override;
end;
implementation
uses
Math, ImagingIO;
const
SHdrFormatName = 'Radiance HDR/RGBE';
SHdrMasks = '*.hdr';
HdrSupportedFormats: TImageFormats = [ifR32G32B32F];
type
TSignature = array[0..9] of AnsiChar;
THdrFormat = (hfRgb, hfXyz);
THdrHeader = record
Format: THdrFormat;
Width: Integer;
Height: Integer;
end;
TRgbe = packed record
R, G, B, E: Byte;
end;
TDynRgbeArray = array of TRgbe;
const
RadianceSignature: TSignature = '#?RADIANCE';
RgbeSignature: TSignature = '#?RGBE';
SFmtRgbeRle = '32-bit_rle_rgbe';
SFmtXyzeRle = '32-bit_rle_xyze';
resourcestring
SErrorBadHeader = 'Bad HDR/RGBE header format.';
SWrongScanLineWidth = 'Wrong scanline width.';
SXyzNotSupported = 'XYZ color space not supported.';
{ THdrFileFormat }
procedure THdrFileFormat.Define;
begin
inherited;
FName := SHdrFormatName;
FFeatures := [ffLoad, ffSave];
FSupportedFormats := HdrSupportedFormats;
AddMasks(SHdrMasks);
end;
function THdrFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
Header: THdrHeader;
IO: TIOFunctions;
function ReadHeader: Boolean;
const
CommentIds: TAnsiCharSet = ['#', '!'];
var
Line: AnsiString;
HasResolution: Boolean;
Count, Idx: Integer;
ValStr, NativeLine: string;
ValFloat: Double;
begin
Result := False;
HasResolution := False;
Count := 0;
repeat
if not ReadLine(IO, Handle, Line) then
Exit;
Inc(Count);
if Count > 16 then // Too long header for HDR
Exit;
if Length(Line) = 0 then
Continue;
if Line[1] in CommentIds then
Continue;
NativeLine := string(Line);
if StrMaskMatch(NativeLine, 'Format=*') then
begin
// Data format parsing
ValStr := Copy(NativeLine, 8, MaxInt);
if ValStr = SFmtRgbeRle then
Header.Format := hfRgb
else if ValStr = SFmtXyzeRle then
Header.Format := hfXyz
else
Exit;
end;
if StrMaskMatch(NativeLine, 'Gamma=*') then
begin
ValStr := Copy(NativeLine, 7, MaxInt);
if TryStrToFloat(ValStr, ValFloat, GetFormatSettingsForFloats) then
FMetadata.SetMetaItem(SMetaGamma, ValFloat);
end;
if StrMaskMatch(NativeLine, 'Exposure=*') then
begin
ValStr := Copy(NativeLine, 10, MaxInt);
if TryStrToFloat(ValStr, ValFloat, GetFormatSettingsForFloats) then
FMetadata.SetMetaItem(SMetaExposure, ValFloat);
end;
if StrMaskMatch(NativeLine, '?Y * ?X *') then
begin
Idx := Pos('X', NativeLine);
ValStr := SubString(NativeLine, 4, Idx - 2);
if not TryStrToInt(ValStr, Header.Height) then
Exit;
ValStr := Copy(NativeLine, Idx + 2, MaxInt);
if not TryStrToInt(ValStr, Header.Width) then
Exit;
if (NativeLine[1] = '-') then
Header.Height := -Header.Height;
if (NativeLine[Idx - 1] = '-') then
Header.Width := -Header.Width;
HasResolution := True;
end;
until HasResolution;
Result := True;
end;
procedure DecodeRgbe(const Src: TRgbe; Dest: PColor96FPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
var
Mult: Single;
begin
if Src.E > 0 then
begin
Mult := Math.Ldexp(1, Src.E - 128);
Dest.R := Src.R / 255 * Mult;
Dest.G := Src.G / 255 * Mult;
Dest.B := Src.B / 255 * Mult;
end
else
begin
Dest.R := 0;
Dest.G := 0;
Dest.B := 0;
end;
end;
procedure ReadCompressedLine(Width, Y: Integer; var DestBuffer: TDynRgbeArray);
var
Pos: Integer;
I, X, Count: Integer;
Code, Value: Byte;
LineBuff: TDynByteArray;
Rgbe: TRgbe;
Ptr: PByte;
begin
SetLength(LineBuff, Width);
IO.Read(Handle, @Rgbe, SizeOf(Rgbe));
if ((Rgbe.B shl 8) or Rgbe.E) <> Width then
RaiseImaging(SWrongScanLineWidth);
for I := 0 to 3 do
begin
Pos := 0;
while Pos < Width do
begin
IO.Read(Handle, @Code, SizeOf(Byte));
if Code > 128 then
begin
Count := Code - 128;
IO.Read(Handle, @Value, SizeOf(Byte));
FillMemoryByte(@LineBuff[Pos], Count, Value);
end
else
begin
Count := Code;
IO.Read(Handle, @LineBuff[Pos], Count * SizeOf(Byte));
end;
Inc(Pos, Count);
end;
Ptr := @PByteArray(@DestBuffer[0])[I];
for X := 0 to Width - 1 do
begin
Ptr^ := LineBuff[X];
Inc(Ptr, 4);
end;
end;
end;
procedure ReadPixels(var Image: TImageData);
var
Y, X, SrcLineLen: Integer;
Dest: PColor96FPRec;
Compressed: Boolean;
Rgbe: TRgbe;
Buffer: TDynRgbeArray;
begin
Dest := Image.Bits;
Compressed := not ((Image.Width < 8) or (Image.Width > $7FFFF));
SrcLineLen := Image.Width * SizeOf(TRgbe);
IO.Read(Handle, @Rgbe, SizeOf(Rgbe));
IO.Seek(Handle, -SizeOf(Rgbe), smFromCurrent);
if (Rgbe.R <> 2) or (Rgbe.G <> 2) or ((Rgbe.B and 128) > 0) then
Compressed := False;
SetLength(Buffer, Image.Width);
for Y := 0 to Image.Height - 1 do
begin
if Compressed then
ReadCompressedLine(Image.Width, Y, Buffer)
else
IO.Read(Handle, @Buffer[0], SrcLineLen);
for X := 0 to Image.Width - 1 do
begin
DecodeRgbe(Buffer[X], Dest);
Inc(Dest);
end;
end;
end;
begin
IO := GetIO;
SetLength(Images, 1);
// Read header, allocate new image and, then read and convert the pixels
if not ReadHeader then
RaiseImaging(SErrorBadHeader);
if (Header.Format = hfXyz) then
RaiseImaging(SXyzNotSupported);
NewImage(Abs(Header.Width), Abs(Header.Height), ifR32G32B32F, Images[0]);
ReadPixels(Images[0]);
// Flip/mirror the image as needed (height < 0 is default top-down)
if Header.Width < 0 then
MirrorImage(Images[0]);
if Header.Height > 0 then
FlipImage(Images[0]);
Result := True;
end;
function THdrFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
const
LineEnd = #$0A;
SPrgComment = '#Made with Vampyre Imaging Library';
SSizeFmt = '-Y %d +X %d';
var
ImageToSave: TImageData;
MustBeFreed: Boolean;
IO: TIOFunctions;
procedure SaveHeader;
begin
WriteLine(IO, Handle, RadianceSignature, LineEnd);
WriteLine(IO, Handle, SPrgComment, LineEnd);
WriteLine(IO, Handle, 'FORMAT=' + SFmtRgbeRle, LineEnd + LineEnd);
WriteLine(IO, Handle, AnsiString(Format(SSizeFmt, [ImageToSave.Height, ImageToSave.Width])), LineEnd);
end;
procedure EncodeRgbe(const Src: TColor96FPRec; var DestR, DestG, DestB, DestE: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF}
var
V, M: {$IFDEF FPC}Float{$ELSE}Extended{$ENDIF};
E: Integer;
begin
V := Src.R;
if (Src.G > V) then
V := Src.G;
if (Src.B > V) then
V := Src.B;
if V < 1e-32 then
begin
DestR := 0;
DestG := 0;
DestB := 0;
DestE := 0;
end
else
begin
Frexp(V, M, E);
V := M * 256.0 / V;
DestR := ClampToByte(Round(Src.R * V));
DestG := ClampToByte(Round(Src.G * V));
DestB := ClampToByte(Round(Src.B * V));
DestE := ClampToByte(E + 128);
end;
end;
procedure WriteRleLine(const Line: array of Byte; Width: Integer);
const
MinRunLength = 4;
var
Cur, BeginRun, RunCount, OldRunCount, NonRunCount: Integer;
Buf: array[0..1] of Byte;
begin
Cur := 0;
while Cur < Width do
begin
BeginRun := Cur;
RunCount := 0;
OldRunCount := 0;
while (RunCount < MinRunLength) and (BeginRun < Width) do
begin
Inc(BeginRun, RunCount);
OldRunCount := RunCount;
RunCount := 1;
while (BeginRun + RunCount < Width) and (RunCount < 127) and (Line[BeginRun] = Line[BeginRun + RunCount]) do
Inc(RunCount);
end;
if (OldRunCount > 1) and (OldRunCount = BeginRun - Cur) then
begin
Buf[0] := 128 + OldRunCount;
Buf[1] := Line[Cur];
IO.Write(Handle, @Buf, 2);
Cur := BeginRun;
end;
while Cur < BeginRun do
begin
NonRunCount := Min(128, BeginRun - Cur);
Buf[0] := NonRunCount;
IO.Write(Handle, @Buf, 1);
IO.Write(Handle, @Line[Cur], NonRunCount);
Inc(Cur, NonRunCount);
end;
if RunCount >= MinRunLength then
begin
Buf[0] := 128 + RunCount;
Buf[1] := Line[BeginRun];
IO.Write(Handle, @Buf, 2);
Inc(Cur, RunCount);
end;
end;
end;
procedure SavePixels;
var
Y, X, I, Width: Integer;
SrcPtr: PColor96FPRecArray;
Components: array of array of Byte;
StartLine: array[0..3] of Byte;
begin
Width := ImageToSave.Width;
// Save using RLE, each component is compressed separately
SetLength(Components, 4, Width);
for Y := 0 to ImageToSave.Height - 1 do
begin
SrcPtr := @PColor96FPRecArray(ImageToSave.Bits)[ImageToSave.Width * Y];
// Identify line as using "new" RLE scheme (separate components)
StartLine[0] := 2;
StartLine[1] := 2;
StartLine[2] := Width shr 8;
StartLine[3] := Width and $FF;
IO.Write(Handle, @StartLine, SizeOf(StartLine));
for X := 0 to Width - 1 do
begin
EncodeRgbe(SrcPtr[X], Components[0, X], Components[1, X],
Components[2, X], Components[3, X]);
end;
for I := 0 to 3 do
WriteRleLine(Components[I], Width);
end;
end;
begin
Result := False;
IO := GetIO;
// Makes image to save compatible with Jpeg saving capabilities
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
with ImageToSave do
try
// Save header
SaveHeader;
// Save uncompressed pixels
SavePixels;
Result := True;
finally
if MustBeFreed then
FreeImage(ImageToSave);
end;
end;
procedure THdrFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo);
begin
ConvertImage(Image, ifR32G32B32F);
end;
function THdrFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
FileSig: TSignature;
ReadCount: Integer;
begin
Result := False;
if Handle <> nil then
begin
ReadCount := GetIO.Read(Handle, @FileSig, SizeOf(FileSig));
GetIO.Seek(Handle, -ReadCount, smFromCurrent);
Result := (ReadCount = SizeOf(FileSig)) and
((FileSig = RadianceSignature) or CompareMem(@FileSig, @RgbeSignature, 6));
end;
end;
initialization
RegisterImageFileFormat(THdrFileFormat);
{
File Notes:
-- 0.77.1 ---------------------------------------------------
- Added RLE compression to saving.
- Added image saving.
- Unit created with initial stuff (loading only).
}
end.

73
Imaging/ImagingTarga.pas
View File

@ -1,29 +1,12 @@
{
$Id: ImagingTarga.pas 139 2008-09-18 02:01:42Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains image format loader/saver for Targa images.}
@ -43,6 +26,7 @@ type
TTargaFileFormat = class(TImageFileFormat)
protected
FUseRLE: LongBool;
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
@ -50,7 +34,6 @@ type
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
{ Controls that RLE compression is used during saving. Accessible trough
@ -89,8 +72,8 @@ type
{ Footer at the end of TGA file.}
TTargaFooter = packed record
ExtOff: LongWord; // Extension Area Offset
DevDirOff: LongWord; // Developer Directory Offset
ExtOff: UInt32; // Extension Area Offset
DevDirOff: UInt32; // Developer Directory Offset
Signature: TChar16; // TRUEVISION-XFILE
Reserved: Byte; // ASCII period '.'
NullChar: Byte; // 0
@ -99,13 +82,11 @@ type
{ TTargaFileFormat class implementation }
constructor TTargaFileFormat.Create;
procedure TTargaFileFormat.Define;
begin
inherited Create;
inherited;
FName := STargaFormatName;
FCanLoad := True;
FCanSave := True;
FIsMultiImageFormat := False;
FFeatures := [ffLoad, ffSave];
FSupportedFormats := TargaSupportedFormats;
FUseRLE := TargaDefaultRLE;
@ -120,7 +101,7 @@ var
Hdr: TTargaHeader;
Foo: TTargaFooter;
FooterFound, ExtFound: Boolean;
I, PSize, PalSize: LongWord;
I, PSize, PalSize: Integer;
Pal: Pointer;
FmtInfo: TImageFormatInfo;
WordValue: Word;
@ -134,7 +115,7 @@ var
begin
with GetIO, Images[0] do
begin
// Alocates buffer large enough to hold the worst case
// Allocates buffer large enough to hold the worst case
// RLE compressed data and reads then from input
BufSize := Width * Height * FmtInfo.BytesPerPixel;
BufSize := BufSize + BufSize div 2 + 1;
@ -162,7 +143,7 @@ var
1: Dest^ := Src^;
2: PWord(Dest)^ := PWord(Src)^;
3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
4: PLongWord(Dest)^ := PLongWord(Src)^;
4: PUInt32(Dest)^ := PUInt32(Src)^;
end;
Inc(Src, Bpp);
Inc(Dest, Bpp);
@ -180,7 +161,7 @@ var
1: Dest^ := Src^;
2: PWord(Dest)^ := PWord(Src)^;
3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
4: PLongWord(Dest)^ := PLongWord(Src)^;
4: PUInt32(Dest)^ := PUInt32(Src)^;
end;
Inc(Dest, Bpp);
end;
@ -188,7 +169,7 @@ var
end;
end;
// set position in source to real end of compressed data
Seek(Handle, -(BufSize - LongInt(LongWord(Src) - LongWord(Buffer))),
Seek(Handle, -(BufSize - (PtrUInt(Src) - PtrUInt(Buffer))),
smFromCurrent);
FreeMem(Buffer);
end;
@ -340,8 +321,8 @@ var
function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt;
var
Pixel: LongWord;
NextPixel: LongWord;
Pixel: UInt32;
NextPixel: UInt32;
N: LongInt;
begin
N := 0;
@ -356,7 +337,7 @@ var
1: Pixel := Data^;
2: Pixel := PWord(Data)^;
3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
4: Pixel := PLongWord(Data)^;
4: Pixel := PUInt32(Data)^;
end;
while PixelCount > 1 do
begin
@ -365,7 +346,7 @@ var
1: NextPixel := Data^;
2: NextPixel := PWord(Data)^;
3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
4: NextPixel := PLongWord(Data)^;
4: NextPixel := PUInt32(Data)^;
end;
if NextPixel = Pixel then
Break;
@ -381,8 +362,8 @@ var
function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt;
var
Pixel: LongWord;
NextPixel: LongWord;
Pixel: UInt32;
NextPixel: UInt32;
N: LongInt;
begin
N := 1;
@ -392,7 +373,7 @@ var
1: Pixel := Data^;
2: Pixel := PWord(Data)^;
3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
4: Pixel := PLongWord(Data)^;
4: Pixel := PUInt32(Data)^;
end;
PixelCount := PixelCount - 1;
while PixelCount > 0 do
@ -402,7 +383,7 @@ var
1: NextPixel := Data^;
2: NextPixel := PWord(Data)^;
3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
4: NextPixel := PLongWord(Data)^;
4: NextPixel := PUInt32(Data)^;
end;
if NextPixel <> Pixel then
Break;
@ -413,7 +394,7 @@ var
end;
procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest:
PByte; var Written: LongInt);
PByte; out Written: LongInt);
const
MaxRun = 128;
var
@ -451,7 +432,7 @@ var
1: Dest^ := Data^;
2: PWord(Dest)^ := PWord(Data)^;
3: PColor24Rec(Dest)^ := PColor24Rec(Data)^;
4: PLongWord(Dest)^ := PLongWord(Data)^;
4: PUInt32(Dest)^ := PUInt32(Data)^;
end;
Inc(Data, Bpp);
Inc(Dest, Bpp);

187
Imaging/ImagingTypes.pas
View File

@ -1,29 +1,12 @@
{
$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
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains basic types and constants used by Imaging library.}
@ -37,9 +20,7 @@ const
{ Current Major version of Imaging.}
ImagingVersionMajor = 0;
{ Current Minor version of Imaging.}
ImagingVersionMinor = 26;
{ Current patch of Imaging.}
ImagingVersionPatch = 4;
ImagingVersionMinor = 82;
{ Imaging Option Ids whose values can be set/get by SetOption/
GetOption functions.}
@ -88,7 +69,7 @@ const
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).
Allowed values are in range 0 (no compression) to 9 (best compression).
Default value is 5.}
ImagingPNGCompressLevel = 26;
{ Boolean option that specifies whether PNG images with more frames (APNG format)
@ -96,28 +77,32 @@ const
raw frames are loaded and sent to user (if you want to animate APNG yourself).
Default value is 1.}
ImagingPNGLoadAnimated = 27;
{ Sets ZLib compression strategy used when saving PNG files (see deflateInit2()
in ZLib for details). Allowed values are: 0 (default), 1 (filtered),
2 (huffman only). Default value is 0.}
ImagingPNGZLibStrategy = 28;
{ Specifies whether MNG animation frames are saved with lossy or lossless
compression. Lossless frames are saved as PNG images and lossy frames are
saved as JNG images. Allowed values are 0 (False) and 1 (True).
Default value is 0.}
ImagingMNGLossyCompression = 28;
ImagingMNGLossyCompression = 32;
{ Defines whether alpha channel of lossy compressed MNG frames
(when ImagingMNGLossyCompression is 1) is lossy compressed too.
Allowed values are 0 (False) and 1 (True). Default value is 0.}
ImagingMNGLossyAlpha = 29;
ImagingMNGLossyAlpha = 33;
{ Sets precompression filter used when saving MNG frames as PNG images.
For details look at ImagingPNGPreFilter.}
ImagingMNGPreFilter = 30;
ImagingMNGPreFilter = 34;
{ Sets ZLib compression level used when saving MNG frames as PNG images.
For details look at ImagingPNGCompressLevel.}
ImagingMNGCompressLevel = 31;
ImagingMNGCompressLevel = 35;
{ Specifies compression quality used when saving MNG frames as JNG images.
For details look at ImagingJpegQuality.}
ImagingMNGQuality = 32;
ImagingMNGQuality = 36;
{ Specifies whether images are saved in progressive format when saving MNG
frames as JNG images. For details look at ImagingJpegProgressive.}
ImagingMNGProgressive = 33;
ImagingMNGProgressive = 37;
{ Specifies whether alpha channels of JNG images are lossy compressed.
Allowed values are 0 (False) and 1 (True). Default value is 0.}
@ -134,14 +119,17 @@ const
{ 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).
@ -155,22 +143,22 @@ const
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
slow processing of large images with many colors so you can
use lower masks to speed it up (FC, F8 and F0 are good
choices). Allowed values are in range <0, $FF> and default is
$FE. }
ImagingColorReductionMask = 128;
{ This option can be used to override image data format during image
loading. If set to format different from ifUnknown all loaded images
are automaticaly converted to this format. Useful when you have
are automatically converted to this format. Useful when you have
many files in various formats but you want them all in one format for
further proccessing. Allowed values are in
further processing. 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.
to be saved are automatically internally converted to this format.
Note that image file formats support only a subset of Imaging data formats
so final saved file may in different format than this override.
Allowed values are in range <Ord(Low(TImageFormat)), Ord(High(TImageFormat))>
@ -182,6 +170,10 @@ const
<Ord(Low(ImagingFormats.TSamplingFilter)), Ord(High(ImagingFormats.TSamplingFilter))>
and default value is 1 (linear filter).}
ImagingMipMapFilter = 131;
{ Specifies threshold value used when automatically converting images to
ifBinary format. For adaptive thresholding see ImagingBinary.pas unit.
Default value is 128 and allowed range is 0..255.}
ImagingBinaryThreshold = 132;
{ Returned by GetOption if given Option Id is invalid.}
InvalidOption = -$7FFFFFFF;
@ -195,22 +187,42 @@ const
ChannelAlpha = 3;
type
{$IFDEF DCC}
{$IF CompilerVersion <= 18.5}
PtrUInt = Cardinal;
PtrInt = Integer;
{ Some new Delphi platforms have 64bit LongInt/LongWord so rather use
Int32/UInt32 where you really want 32bits. }
Int32 = Integer;
UInt32 = Cardinal;
Int16 = SmallInt;
{$ELSE}
PtrUInt = NativeUInt;
PtrInt = NativeInt;
{$IFEND}
{ Not sure which Delphi version defined these (e.g. XE3 has UInt32 but not PUInt32). }
{$IF not Defined(PInt32) or not Defined(PUInt32)}
PInt32 = ^Int32;
PUInt32 = ^UInt32;
{$IFEND}
{$ENDIF}
{ Enum defining image data format. In formats with more channels,
first channel after "if" is stored in the most significant bits and channel
before end is stored in the least significant.}
TImageFormat = (
ifUnknown = 0,
ifDefault = 1,
{ Indexed formats using palette.}
{ Indexed formats using palette }
ifIndex8 = 10,
{ Grayscale/Luminance formats.}
{ Grayscale/Luminance formats }
ifGray8 = 40,
ifA8Gray8 = 41,
ifGray16 = 42,
ifGray32 = 43,
ifGray64 = 44,
ifA16Gray16 = 45,
{ ARGB formats.}
{ ARGB formats }
ifX5R1G1B1 = 80,
ifR3G3B2 = 81,
ifR5G6B5 = 82,
@ -225,23 +237,35 @@ type
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);
{ Floating point formats }
ifR32F = 160,
ifA32R32G32B32F = 161,
ifA32B32G32R32F = 162,
ifR16F = 163,
ifA16R16G16B16F = 164,
ifA16B16G16R16F = 165,
ifR32G32B32F = 166,
ifB32G32R32F = 167,
{ Special formats }
ifDXT1 = 200,
ifDXT3 = 201,
ifDXT5 = 202,
ifBTC = 203,
ifATI1N = 204,
ifATI2N = 205,
ifBinary = 206,
{ Passthrough formats }
{ifETC1 = 220,
ifETC2RGB = 221,
ifETC2RGBA = 222,
ifETC2PA = 223,
ifDXBC6 = 224,
ifDXBC7 = 225}
ifLast = 255
);
{ Color value for 32 bit images.}
TColor32 = LongWord;
TColor32 = UInt32;
PColor32 = ^TColor32;
{ Color value for 64 bit images.}
@ -296,12 +320,24 @@ type
TColor64RecArray = array[0..MaxInt div SizeOf(TColor64Rec) - 1] of TColor64Rec;
PColor64RecArray = ^TColor64RecArray;
{ Color record for 96 bit floating point images, which allows access to
individual color channels.}
TColor96FPRec = packed record
case Integer of
0: (B, G, R: Single);
1: (Channels: array[0..2] of Single);
end;
PColor96FPRec = ^TColor96FPRec;
TColor96FPRecArray = array[0..MaxInt div SizeOf(TColor96FPRec) - 1] of TColor96FPRec;
PColor96FPRecArray = ^TColor96FPRecArray;
{ Color record for 128 bit floating point images, which allows access to
individual color channels.}
TColorFPRec = packed record
case LongInt of
0: (B, G, R, A: Single);
1: (Channels: array[0..3] of Single);
2: (Color96Rec: TColor96FPRec);
end;
PColorFPRec = ^TColorFPRec;
TColorFPRecArray = array[0..MaxInt div SizeOf(TColorFPRec) - 1] of TColorFPRec;
@ -341,6 +377,7 @@ type
Size: LongInt; // Size of image bits in Bytes
Bits: Pointer; // Pointer to memory containing image bits
Palette: PPalette32; // Image palette for indexed images
Tag: Pointer; // User data
end;
PImageData = ^TImageData;
@ -348,7 +385,7 @@ type
image formats.}
TPixelFormatInfo = packed record
ABitCount, RBitCount, GBitCount, BBitCount: Byte;
ABitMask, RBitMask, GBitMask, BBitMask: LongWord;
ABitMask, RBitMask, GBitMask, BBitMask: UInt32;
AShift, RShift, GShift, BShift: Byte;
ARecDiv, RRecDiv, GRecDiv, BRecDiv: Byte;
end;
@ -400,6 +437,9 @@ type
// format does not exist
IsIndexed: Boolean; // True if image uses palette
IsSpecial: Boolean; // True if image is in special format
IsPassthrough: Boolean; // True if image is in passthrough program (Imaging
// itself doesn't know how to decode and encode it -
// complex texture compressions etc.)
PixelFormat: PPixelFormatInfo; // Pixel format structure
GetPixelsSize: TFormatGetPixelsSizeFunc; // Returns size in bytes of
// Width * Height pixels of image
@ -427,7 +467,8 @@ type
TResizeFilter = (
rfNearest = 0,
rfBilinear = 1,
rfBicubic = 2);
rfBicubic = 2,
rfLanczos = 3);
{ Seek origin mode for IO function Seek.}
TSeekMode = (
@ -435,16 +476,22 @@ type
smFromCurrent = 1,
smFromEnd = 2);
TOpenMode = (
omReadOnly = 0, // Opens file for reading only
omCreate = 1, // Creates new file (overwriting any existing) and opens it for writing
omReadWrite = 2 // Opens for reading and writing. Non existing file is created.
);
{ IO functions used for reading and writing images from/to input/output.}
TOpenReadProc = function(Source: PChar): TImagingHandle; cdecl;
TOpenWriteProc = function(Source: PChar): TImagingHandle; cdecl;
TOpenProc = function(Source: PChar; Mode: TOpenMode): 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;
TSeekProc = function(Handle: TImagingHandle; Offset: Int64; Mode: TSeekMode): Int64; cdecl;
TTellProc = function(Handle: TImagingHandle): Int64; cdecl;
TReadProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
TWriteProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
implementation
{
@ -453,6 +500,24 @@ implementation
-- TODOS ----------------------------------------------------
- add lookup tables to pixel formats for fast conversions
-- 0.80 -----------------------------------------------------
- Dropped "patch version".
-- 0.77.3 ---------------------------------------------------
- IO functions now have 64bit sizes and offsets.
-- 0.77.1 ---------------------------------------------------
- Added Tag to TImageData for storing user data.
- Added ImagingPNGZLibStrategy option.
- Changed IO functions. Merged open functions to one
and added third open mode R/W (for TIFF append etc.).
- Added new image data formats and related structures:
ifR32G32B32F, ifB32G32G32F.
-- 0.26.5 Changes/Bug Fixes ---------------------------------
- Added ifBinary image format and ImagingBinaryThreshold option.
- Lanczos filter added to TResizeFilter enum.
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- Added ifATI1N and ifATI2N image data formats.

604
Imaging/ImagingUtility.pas
View File

@ -1,29 +1,12 @@
{
$Id: ImagingUtility.pas 175 2009-10-06 11:55:15Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
The contents of this file are used with permission, subject to the Mozilla
Public License Version 1.1 (the "License"); you may not use this file except
in compliance with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
- - - - -
This Source Code Form is subject to the terms of the Mozilla Public
License, v. 2.0. If a copy of the MPL was not distributed with this
file, You can obtain one at https://mozilla.org/MPL/2.0.
}
{ This unit contains utility functions and types for Imaging library.}
@ -41,14 +24,21 @@ const
SFalse = 'False';
type
{$IF Defined(DELPHI)}
{$IF not Defined(UInt32)}
UInt32 = Cardinal;
{$IFEND}
{$IF not Defined(PUInt32)}
PUInt32 = ^UInt32;
{$IFEND}
{$IFEND}
TByteArray = array[0..MaxInt - 1] of Byte;
PByteArray = ^TByteArray;
TWordArray = array[0..MaxInt div 2 - 1] of Word;
PWordArray = ^TWordArray;
TLongIntArray = array[0..MaxInt div 4 - 1] of LongInt;
PLongIntArray = ^TLongIntArray;
TLongWordArray = array[0..MaxInt div 4 - 1] of LongWord;
PLongWordArray = ^TLongWordArray;
TUInt32Array = array[0..MaxInt div 4 - 1] of UInt32;
PUInt32Array = ^TUInt32Array;
TInt64Array = array[0..MaxInt div 8 - 1] of Int64;
PInt64Array = ^TInt64Array;
TSingleArray = array[0..MaxInt div 4 - 1] of Single;
@ -59,6 +49,7 @@ type
TDynByteArray = array of Byte;
TDynIntegerArray = array of Integer;
TDynBooleanArray = array of Boolean;
TDynStringArray = array of string;
TWordRec = packed record
case Integer of
@ -69,22 +60,22 @@ type
TWordRecArray = array[0..MaxInt div 2 - 1] of TWordRec;
PWordRecArray = ^TWordRecArray;
TLongWordRec = packed record
TUInt32Rec = packed record
case Integer of
0: (LongWordValue: LongWord);
0: (UInt32Value: UInt32);
1: (Low, High: Word);
{ Array variants - Index 0 means lowest significant byte (word, ...).}
2: (Words: array[0..1] of Word);
3: (Bytes: array[0..3] of Byte);
end;
PLongWordRec = ^TLongWordRec;
TLongWordRecArray = array[0..MaxInt div 4 - 1] of TLongWordRec;
PLongWordRecArray = ^TLongWordRecArray;
PUInt32Rec = ^TUInt32Rec;
TUInt32RecArray = array[0..MaxInt div 4 - 1] of TUInt32Rec;
PUInt32RecArray = ^TUInt32RecArray;
TInt64Rec = packed record
case Integer of
0: (Int64Value: Int64);
1: (Low, High: LongWord);
1: (Low, High: UInt32);
{ Array variants - Index 0 means lowest significant byte (word, ...).}
2: (Words: array[0..3] of Word);
3: (Bytes: array[0..7] of Byte);
@ -94,16 +85,32 @@ type
PInt64RecArray = ^TInt64RecArray;
TFloatHelper = record
Data1: Int64;
Data2: Int64;
Data: Int64;
case Integer of
0: (Data64: Int64);
1: (Data32: UInt32);
end;
PFloatHelper = ^TFloatHelper;
TFloatPoint = record
X, Y: Single;
end;
TFloatRect = record
Left, Top, Right, Bottom: Single;
end;
TChar2 = array[0..1] of AnsiChar;
TChar3 = array[0..2] of AnsiChar;
TChar4 = array[0..3] of AnsiChar;
TChar8 = array[0..7] of AnsiChar;
TChar16 = array[0..15] of AnsiChar;
TAnsiCharSet = set of AnsiChar;
ENotImplemented = class(Exception)
public
constructor Create;
end;
{ Options for BuildFileList function:
flFullNames - file names in result will have full path names
@ -126,20 +133,26 @@ procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns time value with microsecond resolution.}
function GetTimeMicroseconds: Int64;
{ Returns time value with milisecond resolution.}
{ Returns time value with millisecond resolution.}
function GetTimeMilliseconds: Int64;
{ Returns file extension (without "." dot)}
function GetFileExt(const FileName: string): string;
{ Returns file name of application's executable.}
function GetAppExe: string;
{ Returns directory where application's exceutable is located without
{ Returns directory where application's executable is located without
path delimiter at the end.}
function GetAppDir: string;
{ Returns True if FileName matches given Mask with optional case sensitivity.
{ Works like SysUtils.ExtractFileName but supports '/' and '\' dir delimiters
at the same time (whereas ExtractFileName supports on default delimiter on current platform).}
function GetFileName(const FileName: string): string;
{ Works like SysUtils.ExtractFileDir but supports '/' and '\' dir delimiters
at the same time (whereas ExtractFileDir supports on default delimiter on current platform).}
function GetFileDir(const FileName: string): string;
{ Returns True if Subject matches given Mask with optional case sensitivity.
Mask can contain ? and * special characters: ? matches
one character, * matches zero or more characters.}
function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean = False): Boolean;
function StrMaskMatch(const Subject, Mask: string; CaseSensitive: Boolean = False): Boolean;
{ This function fills Files string list with names of files found
with FindFirst/FindNext functions (See details on Path/Atrr here).
- BuildFileList('c:\*.*', faAnyFile, List, [flRecursive]) returns
@ -149,7 +162,9 @@ function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean
function BuildFileList(Path: string; Attr: LongInt; Files: TStrings;
Options: TFileListOptions = []): Boolean;
{ Similar to RTL's Pos function but with optional Offset where search will start.
This function is in the RTL StrUtils unit but }
In recent FPC and Delphi XE3+ regular SysUtils.Pos has the Offset parameter as well.
This function is in the RTL StrUtils unit, it's here to depend on additional
unit for just this one function. }
function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
{ Same as PosEx but without case sensitivity.}
function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -161,10 +176,26 @@ function StrTokenEnd(var S: string; Sep: Char): string;
{ Fills instance of TStrings with tokens from string S where tokens are separated by
one of Seps characters.}
procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
{ Returns string representation of integer number (with digit grouping).}
{ Returns string representation of integer number (with digit grouping).
Uses current locale.}
function IntToStrFmt(const I: Int64): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns string representation of float number (with digit grouping).}
{ Returns string representation of float number (with digit grouping).
Uses current locale.}
function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns format settings for parsing floats (dot as decimal separator).
Useful when formatting/parsing floats etc.}
function GetFormatSettingsForFloats: TFormatSettings;
{ Returns True if S contains at least one of the substrings in SubStrs array. Case sensitive.}
function ContainsAnySubStr(const S: string; const SubStrs: array of string): Boolean;
{ Extracts substring starting at IdxStart ending at IdxEnd.
S[IdxEnd] is not included in the result.}
function SubString(const S: string; IdxStart, IdxEnd: Integer): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Similar to Trim() but removes only characters in a given set.
Part of FPC RTL here for Delphi compatibility. }
function TrimSet(const S: string; const CharSet: TSysCharSet): string;
{ Similar to TrimLeft() but removes only characters in a given set.
Part of FPC RTL here for Delphi compatibility. }
function TrimLeftSet(const S: string; const CharSet:TSysCharSet): string;
{ Clamps integer value to range <Min, Max>}
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -177,7 +208,7 @@ function ClampToWord(Value: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF
{ Returns True if Num is power of 2.}
function IsPow2(Num: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns next power of 2 greater than or equal to Num
(if Num itself is power of 2 then it retuns Num).}
(if Num itself is power of 2 then it returns Num).}
function NextPow2(Num: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Raises 2 to the given integer power (in range [0, 30]).}
function Pow2Int(Exponent: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -187,6 +218,8 @@ function Power(const Base, Exponent: Single): Single;
function Log2Int(X: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns log base 2 of X.}
function Log2(X: Single): Single;
{ Returns log base 10 of X.}
function Log10(X: Single): Single;
{ Returns largest integer <= Val (for 5.9 returns 5).}
function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns smallest integer >= Val (for 5.1 returns 6).}
@ -198,46 +231,58 @@ function MinFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns greater of two integer numbers.}
function Max(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns greater of two float numbers.}
function MaxFloat(A, B: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
function MaxFloat(A, B: Single): Single; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns greater of two float numbers.}
function MaxFloat(const A, B: Double): Double; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns result from multiplying Number by Numerator and then dividing by Denominator.
Denominator must be greater than 0.}
function MulDiv(Number, Numerator, Denominator: Word): Word; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns true if give floats are the equal within given delta.}
function SameFloat(A, B: Single; Delta: Single = 0.001): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns true if give floats are the equal within given delta.}
function SameFloat(const A, B: Double; const Delta: Double = 0.000001): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Switches Boolean value.}
procedure Switch(var Value: Boolean); {$IFDEF USE_INLINE}inline;{$ENDIF}
{ If Condition is True then TruePart is retured, otherwise
{ If Condition is True then TruePart is returned, otherwise
FalsePart is returned.}
function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ If Condition is True then TruePart is retured, otherwise
function Iff(Condition: Boolean; TruePart, FalsePart: Integer): Integer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ If Condition is True then TruePart is returned, otherwise
FalsePart is returned.}
function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ If Condition is True then TruePart is retured, otherwise
function IffUnsigned(Condition: Boolean; TruePart, FalsePart: Cardinal): Cardinal; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ If Condition is True then TruePart is returned, otherwise
FalsePart is returned.}
function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ If Condition is True then TruePart is retured, otherwise
{ If Condition is True then TruePart is returned, otherwise
FalsePart is returned.}
function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ If Condition is True then TruePart is retured, otherwise
{ If Condition is True then TruePart is returned, otherwise
FalsePart is returned.}
function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ If Condition is True then TruePart is retured, otherwise
{ If Condition is True then TruePart is returned, otherwise
FalsePart is returned.}
function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ If Condition is True then TruePart is retured, otherwise
{ If Condition is True then TruePart is returned, otherwise
FalsePart is returned.}
function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ If Condition is True then TruePart is retured, otherwise
{ If Condition is True then TruePart is returned, otherwise
FalsePart is returned.}
function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Swaps two Boolean values}
procedure SwapValues(var A, B: Boolean); overload;
{ Swaps two Byte values}
procedure SwapValues(var A, B: Byte); overload;
{ Swaps two Word values}
procedure SwapValues(var A, B: Word); overload;
{ Swaps two Integer values}
procedure SwapValues(var A, B: Integer); overload;
{$IFDEF LONGINT_IS_NOT_INTEGER}
{ Swaps two LongInt values}
procedure SwapValues(var A, B: LongInt); overload;
{$ENDIF}
{ Swaps two Single values}
procedure SwapValues(var A, B: Single); overload;
{ Swaps two LongInt values if necessary to ensure that Min <= Max.}
{ Swaps two values if necessary to ensure that Min <= Max.}
procedure SwapMin(var Min, Max: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
{ This function returns True if running on little endian machine.}
function IsLittleEndian: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -245,19 +290,22 @@ function IsLittleEndian: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
function SwapEndianWord(Value: Word): Word; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Swaps byte order of multiple Word values.}
procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload;
{ Swaps byte order of LongWord value.}
function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Swaps byte order of multiple LongWord values.}
procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload;
{ Swaps byte order of UInt32 value.}
function SwapEndianUInt32(Value: UInt32): UInt32; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Swaps byte order of multiple UInt32 values.}
procedure SwapEndianUInt32(P: PUInt32; Count: LongInt); overload;
{ Calculates CRC32 for the given data.}
procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
procedure CalcCrc32(var Crc: UInt32; Data: Pointer; Size: LongInt);
{ Fills given memory with given Byte value. Size is size of buffer in bytes.}
procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
{ Fills given memory with given Word value. Size is size of buffer in bytes.}
procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
{ Fills given memory with given LongWord value. Size is size of buffer in bytes.}
procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
{ Fills given memory with given UInt32 value. Size is size of buffer in bytes.}
procedure FillMemoryUInt32(Data: Pointer; Size: LongInt; Value: UInt32);
{ Fills given memory zeroes.}
{$EXTERNALSYM ZeroMemory} // Conflicts with WinAPI ZeroMemory in C++ Builder
procedure ZeroMemory(Data: Pointer; Size: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns how many mipmap levels can be created for image of given size.}
function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
@ -285,10 +333,30 @@ procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY,
{ Scales one rectangle to fit into another. Proportions are preserved so
it could be used for 'Stretch To Fit Window' image drawing for instance.}
function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
{ Scales given size to fit into max size while keeping the original aspect ratio.
Useful for calculating thumbnail dimensions etc.}
function ScaleSizeToFit(const CurrentSize, MaxSize: TSize): TSize;
{ Returns width of given rect. Part of RTL in newer Delphi.}
function RectWidth(const Rect: TRect): Integer;
{ Returns height of given rect. Part of RTL in newer Delphi.}
function RectHeight(const Rect: TRect): Integer;
{ Returns True if R1 fits into R2.}
function RectInRect(const R1, R2: TRect): Boolean;
{ Returns True if R1 and R2 intersects.}
function RectIntersects(const R1, R2: TRect): Boolean;
{ Ensures that rect's right>left and bottom>top. }
procedure NormalizeRect(var R: TRect);
{ Converts pixel size in micrometers to corresponding DPI.}
function PixelSizeToDpi(SizeInMicroMeters: Single): Single;
{ Converts DPI to corresponding pixel size in micrometers.}
function DpiToPixelSize(Dpi: Single): Single;
function FloatPoint(AX, AY: Single): TFloatPoint; {$IFDEF USE_INLINE}inline;{$ENDIF}
function FloatRect(ALeft, ATop, ARight, ABottom: Single): TFloatRect;
function FloatRectWidth(const R: TFloatRect): Single;
function FloatRectHeight(const R: TFloatRect): Single;
function FloatRectFromRect(const R: TRect): TFloatRect;
{ Formats given message for usage in Exception.Create(..). Use only
in except block - returned message contains message of last raised exception.}
@ -300,16 +368,21 @@ procedure DebugMsg(const Msg: string; const Args: array of const);
implementation
uses
{$IFDEF MSWINDOWS}
{$IF Defined(MSWINDOWS)}
Windows;
{$ENDIF}
{$IFDEF UNIX}
{$IFDEF KYLIX}
Libc;
{$ELSE}
{$ELSEIF Defined(FPC)}
Dos, BaseUnix, Unix;
{$ENDIF}
{$ENDIF}
{$ELSEIF Defined(DELPHI)}
Posix.SysTime;
{$IFEND}
var
FloatFormatSettings: TFormatSettings;
constructor ENotImplemented.Create;
begin
inherited Create('Not implemented');
end;
procedure FreeAndNil(var Obj);
var
@ -337,10 +410,10 @@ begin
Result := Exception(ExceptObject);
end;
{$IFDEF MSWINDOWS}
{$IF Defined(MSWINDOWS)}
var
PerfFrequency: Int64;
InvPerfFrequency: Single;
InvPerfFrequency: Extended;
function GetTimeMicroseconds: Int64;
var
@ -349,56 +422,23 @@ begin
QueryPerformanceCounter(Time);
Result := Round(1000000 * InvPerfFrequency * Time);
end;
{$ENDIF}
{$IFDEF UNIX}
{$ELSEIF Defined(DELPHI)}
function GetTimeMicroseconds: Int64;
var
Time: TimeVal;
begin
Posix.SysTime.GetTimeOfDay(Time, nil);
Result := Int64(Time.tv_sec) * 1000000 + Time.tv_usec;
end;
{$ELSEIF Defined(FPC)}
function GetTimeMicroseconds: Int64;
var
TimeVal: TTimeVal;
begin
{$IFDEF KYLIX}
GetTimeOfDay(TimeVal, nil);
{$ELSE}
fpGetTimeOfDay(@TimeVal, nil);
{$ENDIF}
Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec;
end;
{$ENDIF}
{$IFDEF MSDOS}
function GetTimeMicroseconds: Int64;
asm
XOR EAX, EAX
CLI
OUT $43, AL
MOV EDX, FS:[$46C]
IN AL, $40
DB $EB, 0, $EB, 0, $EB, 0
MOV AH, AL
IN AL, $40
DB $EB, 0, $EB, 0, $EB, 0
XCHG AL, AH
NEG AX
MOVZX EDI, AX
STI
MOV EBX, $10000
MOV EAX, EDX
XOR EDX, EDX
MUL EBX
ADD EAX, EDI
ADC EDX, 0
PUSH EDX
PUSH EAX
MOV ECX, $82BF1000
MOVZX EAX, WORD PTR FS:[$470]
MUL ECX
MOV ECX, EAX
POP EAX
POP EDX
ADD EAX, ECX
ADC EDX, 0
end;
{$ENDIF}
{$IFEND}
function GetTimeMilliseconds: Int64;
begin
@ -413,29 +453,22 @@ begin
end;
function GetAppExe: string;
{$IFDEF MSWINDOWS}
{$IF Defined(MSWINDOWS)}
var
FileName: array[0..MAX_PATH] of Char;
begin
SetString(Result, FileName,
Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
{$ENDIF}
{$IFDEF UNIX}
{$IFDEF KYLIX}
{$ELSEIF Defined(DELPHI)} // Delphi non Win targets
var
FileName: array[0..FILENAME_MAX] of Char;
FileName: array[0..1024] of Char;
begin
SetString(Result, FileName,
System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
{$ELSE}
{$ELSE}
begin
Result := FExpand(ParamStr(0));
{$ENDIF}
{$ENDIF}
{$IFDEF MSDOS}
begin
Result := ParamStr(0);
{$ENDIF}
Result := ExpandFileName(ParamStr(0));
{$IFEND}
end;
function GetAppDir: string;
@ -443,7 +476,28 @@ begin
Result := ExtractFileDir(GetAppExe);
end;
function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean): Boolean;
function GetFileName(const FileName: string): string;
var
I: Integer;
begin
I := LastDelimiter('\/' + DriveDelim, FileName);
Result := Copy(FileName, I + 1, MaxInt);
end;
function GetFileDir(const FileName: string): string;
const
Delims = '\/' + DriveDelim;
var
I: Integer;
begin
I := LastDelimiter(Delims, Filename);
if (I > 1) and
((FileName[I] = Delims[1]) or (FileName[I] = Delims[2])) and
(not IsDelimiter(Delims, FileName, I - 1)) then Dec(I);
Result := Copy(FileName, 1, I);
end;
function StrMaskMatch(const Subject, Mask: string; CaseSensitive: Boolean): Boolean;
var
MaskLen, KeyLen : LongInt;
@ -486,7 +540,7 @@ var
Exit;
end;
else
if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then
if not CharMatch(Mask[MaskPos], Subject[KeyPos]) then
begin
Result := False;
Exit;
@ -499,7 +553,7 @@ var
end;
end;
while (MaskPos <= MaskLen) and (Mask[MaskPos] in ['?', '*']) do
while (MaskPos <= MaskLen) and (AnsiChar(Mask[MaskPos]) in ['?', '*']) do
Inc(MaskPos);
if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then
begin
@ -512,7 +566,7 @@ var
begin
MaskLen := Length(Mask);
KeyLen := Length(FileName);
KeyLen := Length(Subject);
if MaskLen = 0 then
begin
Result := True;
@ -707,6 +761,58 @@ begin
Result := Format('%.' + IntToStr(Precision) + 'n', [F]);
end;
function GetFormatSettingsForFloats: TFormatSettings;
begin
Result := FloatFormatSettings;
end;
function ContainsAnySubStr(const S: string; const SubStrs: array of string): Boolean;
var
I: Integer;
begin
Result := False;
for I := 0 to High(SubStrs) do
begin
Result := Pos(SubStrs[I], S) > 0;
if Result then
Exit;
end;
end;
function SubString(const S: string; IdxStart, IdxEnd: Integer): string;
begin
Result := Copy(S, IdxStart, IdxEnd - IdxStart);
end;
function TrimSet(const S: string; const CharSet: TSysCharSet): string;
var
I, L: Integer;
begin
L := Length(S);
I := 1;
while (I <= L) and (S[I] in CharSet) do
Inc(I);
if I > L then
Result := ''
else
begin
while S[L] in CharSet do
Dec(L);
Result := Copy(S, I, L - I + 1);
end;
end;
function TrimLeftSet(const S: string; const CharSet: TSysCharSet): string;
var
I, L: Integer;
begin
L := Length(S);
I := 1;
while (I <= L) and (S[I] in CharSet) do
Inc(I);
Result := Copy(S, I, MaxInt);
end;
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
begin
Result := Number;
@ -810,23 +916,48 @@ begin
end;
function Log2(X: Single): Single;
{$IFDEF USE_ASM}
asm
FLD1
FLD X
FYL2X
FWAIT
end;
{$ELSE}
const
Ln2: Single = 0.6931471;
begin
Result := Ln(X) / Ln2;
end;
{$ENDIF}
function Log10(X: Single): Single;
{$IFDEF USE_ASM}
asm
FLDLG2
FLD X
FYL2X
FWAIT
end;
{$ELSE}
const
Ln10: Single = 2.30258509299405;
begin
Result := Ln(X) / Ln10;
end;
{$ENDIF}
function Floor(Value: Single): LongInt;
begin
Result := Trunc(Value);
if Frac(Value) < 0.0 then
if Value < Result then
Dec(Result);
end;
function Ceil(Value: Single): LongInt;
begin
Result := Trunc(Value);
if Frac(Value) > 0.0 then
if Value > Result then
Inc(Result);
end;
@ -835,7 +966,7 @@ begin
Value := not Value;
end;
function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt;
function Iff(Condition: Boolean; TruePart, FalsePart: Integer): Integer;
begin
if Condition then
Result := TruePart
@ -843,7 +974,7 @@ begin
Result := FalsePart;
end;
function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord;
function IffUnsigned(Condition: Boolean; TruePart, FalsePart: Cardinal): Cardinal;
begin
if Condition then
Result := TruePart
@ -899,6 +1030,15 @@ begin
Result := FalsePart;
end;
procedure SwapValues(var A, B: Boolean);
var
Tmp: Boolean;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure SwapValues(var A, B: Byte);
var
Tmp: Byte;
@ -917,6 +1057,16 @@ begin
B := Tmp;
end;
procedure SwapValues(var A, B: Integer);
var
Tmp: Integer;
begin
Tmp := A;
A := B;
B := Tmp;
end;
{$IFDEF LONGINT_IS_NOT_INTEGER}
procedure SwapValues(var A, B: LongInt);
var
Tmp: LongInt;
@ -925,6 +1075,7 @@ begin
A := B;
B := Tmp;
end;
{$ENDIF}
procedure SwapValues(var A, B: Single);
var
@ -979,6 +1130,14 @@ begin
Result := B;
end;
function MaxFloat(const A, B: Double): Double;
begin
if A > B then
Result := A
else
Result := B;
end;
function MulDiv(Number, Numerator, Denominator: Word): Word;
{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
asm
@ -991,6 +1150,16 @@ begin
end;
{$IFEND}
function SameFloat(A, B: Single; Delta: Single): Boolean;
begin
Result := Abs(A - B) <= Delta;
end;
function SameFloat(const A, B: Double; const Delta: Double): Boolean;
begin
Result := Abs(A - B) <= Delta;
end;
function IsLittleEndian: Boolean;
var
W: Word;
@ -1036,21 +1205,21 @@ begin
end;
{$ENDIF}
function SwapEndianLongWord(Value: LongWord): LongWord;
function SwapEndianUInt32(Value: UInt32): UInt32;
{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
asm
BSWAP EAX
end;
{$ELSE}
begin
TLongWordRec(Result).Bytes[0] := TLongWordRec(Value).Bytes[3];
TLongWordRec(Result).Bytes[1] := TLongWordRec(Value).Bytes[2];
TLongWordRec(Result).Bytes[2] := TLongWordRec(Value).Bytes[1];
TLongWordRec(Result).Bytes[3] := TLongWordRec(Value).Bytes[0];
TUInt32Rec(Result).Bytes[0] := TUInt32Rec(Value).Bytes[3];
TUInt32Rec(Result).Bytes[1] := TUInt32Rec(Value).Bytes[2];
TUInt32Rec(Result).Bytes[2] := TUInt32Rec(Value).Bytes[1];
TUInt32Rec(Result).Bytes[3] := TUInt32Rec(Value).Bytes[0];
end;
{$IFEND}
procedure SwapEndianLongWord(P: PLongWord; Count: LongInt);
procedure SwapEndianUInt32(P: PUInt32; Count: LongInt);
{$IFDEF USE_ASM}
asm
@Loop:
@ -1064,21 +1233,21 @@ end;
{$ELSE}
var
I: LongInt;
Temp: LongWord;
Temp: UInt32;
begin
for I := 0 to Count - 1 do
begin
Temp := PLongWordArray(P)[I];
TLongWordRec(PLongWordArray(P)[I]).Bytes[0] := TLongWordRec(Temp).Bytes[3];
TLongWordRec(PLongWordArray(P)[I]).Bytes[1] := TLongWordRec(Temp).Bytes[2];
TLongWordRec(PLongWordArray(P)[I]).Bytes[2] := TLongWordRec(Temp).Bytes[1];
TLongWordRec(PLongWordArray(P)[I]).Bytes[3] := TLongWordRec(Temp).Bytes[0];
Temp := PUInt32Array(P)[I];
TUInt32Rec(PUInt32Array(P)[I]).Bytes[0] := TUInt32Rec(Temp).Bytes[3];
TUInt32Rec(PUInt32Array(P)[I]).Bytes[1] := TUInt32Rec(Temp).Bytes[2];
TUInt32Rec(PUInt32Array(P)[I]).Bytes[2] := TUInt32Rec(Temp).Bytes[1];
TUInt32Rec(PUInt32Array(P)[I]).Bytes[3] := TUInt32Rec(Temp).Bytes[0];
end;
end;
{$ENDIF}
type
TCrcTable = array[Byte] of LongWord;
TCrcTable = array[Byte] of UInt32;
var
CrcTable: TCrcTable;
@ -1087,7 +1256,7 @@ const
Polynom = $EDB88320;
var
I, J: LongInt;
C: LongWord;
C: UInt32;
begin
for I := 0 to 255 do
begin
@ -1103,7 +1272,7 @@ begin
end;
end;
procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
procedure CalcCrc32(var Crc: UInt32; Data: Pointer; Size: LongInt);
var
I: LongInt;
B: PByte;
@ -1174,11 +1343,11 @@ asm
end;
{$ELSE}
var
I, V: LongWord;
I, V: UInt32;
begin
V := Value * $10000 + Value;
for I := 0 to Size div 4 - 1 do
PLongWordArray(Data)[I] := V;
PUInt32Array(Data)[I] := V;
case Size mod 4 of
1: PByteArray(Data)[Size - 1] := Lo(Value);
2: PWordArray(Data)[Size div 2] := Value;
@ -1191,7 +1360,7 @@ begin
end;
{$ENDIF}
procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
procedure FillMemoryUInt32(Data: Pointer; Size: LongInt; Value: UInt32);
{$IFDEF USE_ASM}
asm
PUSH EDI
@ -1223,19 +1392,24 @@ var
I: LongInt;
begin
for I := 0 to Size div 4 - 1 do
PLongWordArray(Data)[I] := Value;
PUInt32Array(Data)[I] := Value;
case Size mod 4 of
1: PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
2: PWordArray(Data)[Size div 2] := TLongWordRec(Value).Words[0];
1: PByteArray(Data)[Size - 1] := TUInt32Rec(Value).Bytes[0];
2: PWordArray(Data)[Size div 2] := TUInt32Rec(Value).Words[0];
3:
begin
PWordArray(Data)[Size div 2 - 1] := TLongWordRec(Value).Words[0];
PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0];
PWordArray(Data)[Size div 2 - 1] := TUInt32Rec(Value).Words[0];
PByteArray(Data)[Size - 1] := TUInt32Rec(Value).Bytes[0];
end;
end;
end;
{$ENDIF}
procedure ZeroMemory(Data: Pointer; Size: Integer);
begin
FillMemoryByte(Data, Size, 0);
end;
function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
begin
Result := 0;
@ -1407,6 +1581,27 @@ begin
end;
end;
function ScaleSizeToFit(const CurrentSize, MaxSize: Types.TSize): Types.TSize;
var
SR, TR, ScaledRect: TRect;
begin
SR := Types.Rect(0, 0, CurrentSize.CX, CurrentSize.CY);
TR := Types.Rect(0, 0, MaxSize.CX, MaxSize.CY);
ScaledRect := ScaleRectToRect(SR, TR);
Result.CX := ScaledRect.Right - ScaledRect.Left;
Result.CY := ScaledRect.Bottom - ScaledRect.Top;
end;
function RectWidth(const Rect: TRect): Integer;
begin
Result := Rect.Right - Rect.Left;
end;
function RectHeight(const Rect: TRect): Integer;
begin
Result := Rect.Bottom - Rect.Top;
end;
function RectInRect(const R1, R2: TRect): Boolean;
begin
Result:=
@ -1425,6 +1620,56 @@ begin
not (R1.Bottom < R2.Top);
end;
procedure NormalizeRect(var R: TRect);
begin
if R.Right < R.Left then
SwapValues(R.Right, R.Left);
if R.Bottom < R.Top then
SwapValues(R.Bottom, R.Top);
end;
function PixelSizeToDpi(SizeInMicroMeters: Single): Single;
begin
Result := 25400 / SizeInMicroMeters;
end;
function DpiToPixelSize(Dpi: Single): Single;
begin
Result := 1e03 / (Dpi / 25.4);
end;
function FloatPoint(AX, AY: Single): TFloatPoint;
begin
Result.X := AX;
Result.Y := AY;
end;
function FloatRect(ALeft, ATop, ARight, ABottom: Single): TFloatRect;
begin
with Result do
begin
Left := ALeft;
Top := ATop;
Right := ARight;
Bottom := ABottom;
end;
end;
function FloatRectWidth(const R: TFloatRect): Single;
begin
Result := R.Right - R.Left;
end;
function FloatRectHeight(const R: TFloatRect): Single;
begin
Result := R.Bottom - R.Top;
end;
function FloatRectFromRect(const R: TRect): TFloatRect;
begin
Result := FloatRect(R.Left, R.Top, R.Right, R.Bottom);
end;
function FormatExceptMsg(const Msg: string; const Args: array of const): string;
begin
Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args);
@ -1455,22 +1700,38 @@ initialization
QueryPerformanceFrequency(PerfFrequency);
InvPerfFrequency := 1.0 / PerfFrequency;
{$ENDIF}
{$IFDEF MSDOS}
// reset PIT
asm
MOV EAX, $34
OUT $43, AL
XOR EAX, EAX
OUT $40, AL
OUT $40, AL
end;
{$ENDIF}
{$IF Defined(DELPHI)}
{$IF CompilerVersion >= 23}
FloatFormatSettings := TFormatSettings.Create('en-US');
{$ELSE}
GetLocaleFormatSettings(1033, FloatFormatSettings);
{$IFEND}
{$ELSE FPC}
FloatFormatSettings := DefaultFormatSettings;
FloatFormatSettings.DecimalSeparator := '.';
FloatFormatSettings.ThousandSeparator := ',';
{$IFEND}
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.77.1 ----------------------------------------------------
- Added GetFileName, GetFileDir, RectWidth, RectHeight function.
- Added ScaleSizeToFit function.
- Added ZeroMemory and SwapValues for Booleans.
- Added Substring function.
- Renamed MatchFileNameMask to StrMaskMatch (it's for general use not
just filenames).
- Delphi XE2 new targets (Win64, OSX32) compatibility changes.
- Added GetFormatSettingsForFloats function.
-- 0.26.5 Changes/Bug Fixes -----------------------------------
- Added Log10 function.
- Added TFloatRect type and helper functions FloatRect, FloatRectWidth,
FloatRectHeight.
- Added string function ContainsAnySubStr.
- Added functions PixelSizeToDpi, DpiToPixelSize.
-- 0.26.1 Changes/Bug Fixes -----------------------------------
- Some formatting changes.
@ -1521,3 +1782,4 @@ initialization
}
end.

9
Imaging/JpegLib/imjcapimin.pas
View File

@ -1,5 +1,5 @@
unit imjcapimin;
{$N+}
{ This file contains application interface code for the compression half
of the JPEG library. These are the "minimum" API routines that may be
needed in either the normal full-compression case or the transcoding-only
@ -157,15 +157,14 @@ begin
{ For debugging purposes, we zero the whole master structure.
But the application has already set the err pointer, and may have set
client_data, so we have to save and restore those fields.
Note: if application hasn't set client_data, tools like Purify may
complain here. }
client_data, so we have to save and restore those fields. }
err := cinfo^.err;
client_data := cinfo^.client_data; { ignore Purify complaint here }
client_data := cinfo^.client_data;
MEMZERO(cinfo, SIZEOF(jpeg_compress_struct));
cinfo^.err := err;
cinfo^.is_decompressor := FALSE;
cinfo^.client_data := client_data;
{ Initialize a memory manager instance for this object }
jinit_memory_mgr(j_common_ptr(cinfo));

39
Imaging/JpegLib/imjccolor.pas
View File

@ -24,8 +24,7 @@ implementation
{ Private subobject }
type
jTInt32 = 0..Pred(MaxInt div SizeOf(INT32));
INT32_FIELD = array[jTInt32] of INT32;
INT32_FIELD = array[0..MaxInt div SizeOf(INT32) - 1] of INT32;
INT32_FIELD_PTR = ^INT32_FIELD;
type
@ -94,14 +93,14 @@ const
{METHODDEF}
procedure rgb_ycc_start (cinfo : j_compress_ptr);
const
FIX_0_29900 = INT32(Round (0.29900 * (1 shl SCALEBITS)) );
FIX_0_58700 = INT32(Round (0.58700 * (1 shl SCALEBITS)) );
FIX_0_11400 = INT32(Round (0.11400 * (1 shl SCALEBITS)) );
FIX_0_16874 = INT32(Round (0.16874 * (1 shl SCALEBITS)) );
FIX_0_33126 = INT32(Round (0.33126 * (1 shl SCALEBITS)) );
FIX_0_50000 = INT32(Round (0.50000 * (1 shl SCALEBITS)) );
FIX_0_41869 = INT32(Round (0.41869 * (1 shl SCALEBITS)) );
FIX_0_08131 = INT32(Round (0.08131 * (1 shl SCALEBITS)) );
FIX_0_29900 = INT32(Round(0.29900 * (1 shl SCALEBITS)));
FIX_0_58700 = INT32(Round(0.58700 * (1 shl SCALEBITS)));
FIX_0_11400 = INT32(Round(0.11400 * (1 shl SCALEBITS)));
FIX_0_16874 = INT32(Round(0.16874 * (1 shl SCALEBITS)));
FIX_0_33126 = INT32(Round(0.33126 * (1 shl SCALEBITS)));
FIX_0_50000 = INT32(Round(0.50000 * (1 shl SCALEBITS)));
FIX_0_41869 = INT32(Round(0.41869 * (1 shl SCALEBITS)));
FIX_0_08131 = INT32(Round(0.08131 * (1 shl SCALEBITS)));
var
cconvert : my_cconvert_ptr;
rgb_ycc_tab : INT32_FIELD_PTR;
@ -232,26 +231,24 @@ begin
while (num_rows > 0) do
begin
Dec(num_rows);
inptr := input_buf^[0];
inptr := input_buf[0];
Inc(JSAMPROW_PTR(input_buf));
outptr := output_buf^[0]^[output_row];
outptr := output_buf[0][output_row];
Inc(output_row);
for col := 0 to pred(num_cols) do
for col := 0 to num_cols - 1 do
begin
r := GETJSAMPLE(inptr^[RGB_RED]);
g := GETJSAMPLE(inptr^[RGB_GREEN]);
b := GETJSAMPLE(inptr^[RGB_BLUE]);
r := GETJSAMPLE(inptr[RGB_RED]);
g := GETJSAMPLE(inptr[RGB_GREEN]);
b := GETJSAMPLE(inptr[RGB_BLUE]);
Inc(JSAMPLE_PTR(inptr), RGB_PIXELSIZE);
(* Y *)
// kylix 3 compiler crashes on this
{$IF (not Defined(LINUX)) or Defined(FPC)}
outptr^[col] := JSAMPLE (
((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF])
shr SCALEBITS) );
// it also crashes Delphi OSX compiler 9 years later :(
{$IF not (Defined(DCC) and not Defined(MSWINDOWS))}
outptr[col] := JSAMPLE(((ctab[r+R_Y_OFF] + ctab[g+G_Y_OFF] + ctab[b+B_Y_OFF]) shr SCALEBITS));
{$IFEND}
end;
end;
end;

1
Imaging/JpegLib/imjcdctmgr.pas
View File

@ -12,7 +12,6 @@ unit imjcdctmgr;
interface
{$N+}
{$I imjconfig.inc}
uses

2
Imaging/JpegLib/imjconfig.inc
View File

@ -121,4 +121,6 @@
{!CHANGE: Added this}
{$define Delphi_Stream}
{$Q-}
{$MINENUMSIZE 4}
{$ALIGN 8}

2
Imaging/JpegLib/imjdapimin.pas
View File

@ -1,7 +1,5 @@
unit imjdapimin;
{$N+} { Nomssi: cinfo^.output_gamma }
{ This file contains application interface code for the decompression half
of the JPEG library. These are the "minimum" API routines that may be
needed in either the normal full-decompression case or the

2
Imaging/JpegLib/imjddctmgr.pas
View File

@ -15,8 +15,6 @@ interface
{$I imjconfig.inc}
{$N+}
uses
imjmorecfg,
imjinclude,

1
Imaging/JpegLib/imjdhuff.pas
View File

@ -1172,6 +1172,7 @@ begin
end;
{ Account for restart interval (no-op if not using restarts) }
if entropy^.restarts_to_go > 0 then
Dec(entropy^.restarts_to_go);
decode_mcu := TRUE;

2
Imaging/JpegLib/imjdmainct.pas
View File

@ -601,7 +601,7 @@ begin
cinfo^.min_DCT_scaled_size; { height of a row group of component }
main^.buffer[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE,
compptr^.width_in_blocks * LongWord(compptr^.DCT_scaled_size),
compptr^.width_in_blocks * uInt(compptr^.DCT_scaled_size),
JDIMENSION (rgroup * ngroups));
Inc(compptr);
end;

6
Imaging/JpegLib/imjdmarker.pas
View File

@ -1631,7 +1631,7 @@ function get_interesting_appn (cinfo : j_decompress_ptr) : boolean;
var
length : INT32;
b : array[0..APPN_DATA_LEN-1] of JOCTET;
i, numtoread : uint;
i, numtoread: uint;
var
datasrc : jpeg_source_mgr_ptr;
next_input_byte : JOCTETptr;
@ -1692,6 +1692,9 @@ begin
numtoread := uint(length)
else
numtoread := 0;
if numtoread > 0 then
begin
for i := 0 to numtoread-1 do
begin
{ Read a byte into b[i]. If must suspend, return FALSE. }
@ -1714,6 +1717,7 @@ begin
b[i] := GETJOCTET(next_input_byte^);
Inc(next_input_byte);
end;
end;
Dec(length, numtoread);

14
Imaging/JpegLib/imjerror.pas
View File

@ -42,7 +42,7 @@ procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE;
p1 : int; p2 : int; p3 : int; p4 : int);
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string);
str : AnsiString);
{ Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
@ -78,7 +78,7 @@ procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; code : J_MESSAGE_CODE;
p5 : int; p6 : int; p7 : int; p8 : int);
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string);
code : J_MESSAGE_CODE; str : AnsiString);
implementation
@ -179,7 +179,7 @@ begin
end;
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string);
str : AnsiString);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] }
@ -286,7 +286,7 @@ begin
end;
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string);
code : J_MESSAGE_CODE; str : AnsiString);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX }
@ -296,7 +296,7 @@ end;
{METHODDEF}
procedure output_message (cinfo : j_common_ptr);
var
buffer : string; {[JMSG_LENGTH_MAX];}
buffer : AnsiString; {[JMSG_LENGTH_MAX];}
begin
{ Create the message }
cinfo^.err^.format_message (cinfo, buffer);
@ -350,11 +350,11 @@ end;
{METHODDEF}
procedure format_message (cinfo : j_common_ptr; var buffer : string);
procedure format_message (cinfo : j_common_ptr; var buffer : AnsiString);
var
err : jpeg_error_mgr_ptr;
msg_code : J_MESSAGE_CODE;
msgtext : string;
msgtext : AnsiString;
isstring : boolean;
begin
err := cinfo^.err;

1
Imaging/JpegLib/imjfdctflt.pas
View File

@ -1,6 +1,5 @@
unit imjfdctflt;
{$N+}
{ This file contains a floating-point implementation of the
forward DCT (Discrete Cosine Transform).

2
Imaging/JpegLib/imjidctasm.pas
View File

@ -510,7 +510,7 @@ asm
mov edi, DWORD PTR [ebx+eax*4] { 4 = SizeOf(pointer) }
{Inc(JSAMPLE_PTR(outptr), output_col);}
add edi, LongWord(output_col)
add edi, uInt(output_col)
{ Rows of zeroes can be exploited in the same way as we did with columns.
However, the column calculation has created many nonzero AC terms, so

1
Imaging/JpegLib/imjidctflt.pas
View File

@ -1,6 +1,5 @@
unit imjidctflt;
{$N+}
{ This file contains a floating-point implementation of the
inverse DCT (Discrete Cosine Transform). In the IJG code, this routine
must also perform dequantization of the input coefficients.

42
Imaging/JpegLib/imjmorecfg.pas
View File

@ -10,40 +10,13 @@ interface
{$I imjconfig.inc}
{$IFDEF FPC} { Free Pascal Compiler }
type
int = longint;
uInt = Cardinal; { unsigned int }
short = Integer;
ushort = Word;
long = longint;
{$ELSE}
{$IFDEF WIN32}
{ Delphi 2.0 }
type
type
int = Integer;
uInt = Cardinal;
short = SmallInt;
ushort = Word;
long = longint;
{$ELSE}
{$IFDEF VIRTUALPASCAL}
type
int = longint;
uInt = longint; { unsigned int }
short = system.Integer;
ushort = system.Word;
long = longint;
{$ELSE}
type
int = Integer;
uInt = Word; { unsigned int }
short = Integer;
ushort = Word;
long = longint;
{$ENDIF}
{$ENDIF}
{$ENDIF}
long = LongInt;
type
voidp = pointer;
@ -58,6 +31,7 @@ type
JPEG standard, and the IJG code does not support anything else!
We do not support run-time selection of data precision, sorry. }
{$ifdef BITS_IN_JSAMPLE_IS_8} { use 8 or 12 }
const
BITS_IN_JSAMPLE = 8;
@ -67,8 +41,6 @@ const
{$endif}
{ Maximum number of components (color channels) allowed in JPEG image.
To meet the letter of the JPEG spec, set this to 255. However, darn
few applications need more than 4 channels (maybe 5 for CMYK + alpha
@ -159,7 +131,7 @@ type
{ UINT8 must hold at least the values 0..255. }
type
UINT8 = byte;
UINT8 = Byte;
{ UINT16 must hold at least the values 0..65535. }
@ -167,11 +139,11 @@ type
{ INT16 must hold at least the values -32768..32767. }
INT16 = int;
INT16 = SmallInt;
{ INT32 must hold at least signed 32-bit values. }
INT32 = longint;
INT32 = LongInt;
type
INT32PTR = ^INT32;

2
Imaging/JpegLib/imjpeglib.pas
View File

@ -722,7 +722,7 @@ type
{ Routine that actually outputs a trace or error message }
output_message : procedure (cinfo : j_common_ptr);
{ Format a message string for the most recent JPEG error or message }
format_message : procedure (cinfo : j_common_ptr; var buffer : string);
format_message : procedure (cinfo : j_common_ptr; var buffer : AnsiString);
{ Reset error state variables at start of a new image }
reset_error_mgr : procedure (cinfo : j_common_ptr);

55
Imaging/ZLib/dzlib.pas
View File

@ -45,43 +45,43 @@ unit dzlib;
interface
{$DEFINE IMPASZLIB}
{ $DEFINE ZLIBPAS}
{ $DEFINE FPCPASZLIB}
{ $DEFINE ZLIBEX}
{ $DEFINE DELPHIZLIB}
{ $DEFINE ZLIBPAS}
{$DEFINE IMPASZLIB}
{ $DEFINE FPCPASZLIB}
{ Automatically use FPC's PasZLib when compiling with Lazarus.}
{ Automatically use FPC's PasZLib when compiling with FPC.}
{$IFDEF LCL}
{$IFDEF FPC}
{$UNDEF IMPASZLIB}
{$DEFINE FPCPASZLIB}
{$ENDIF}
uses
{$IF Defined(ZLIBEX)}
{ Use ZlibEx unit.}
ZLibEx,
{$ELSEIF Defined(DELPHIZLIB)}
{ Use ZLib unit shipped with Delphi.}
ZLib,
{$ELSEIF Defined(ZLIBPAS)}
{ Pascal interface to ZLib shipped with ZLib C source.}
zlibpas,
{$ELSEIF Defined(IMPASZLIB)}
{ Use paszlib modified by me for Delphi and FPC.}
{$IF Defined(IMPASZLIB)}
{ Use paszlib modified by me for Delphi and FPC }
imzdeflate, imzinflate, impaszlib,
{$ELSEIF Defined(FPCPASZLIB)}
{ Use FPC's paszlib.}
{ Use FPC's paszlib }
zbase, paszlib,
{$ELSEIF Defined(ZLIBPAS)}
{ Pascal interface to ZLib shipped with ZLib C source }
zlibpas,
{$ELSEIF Defined(ZLIBEX)}
{ Use ZlibEx unit }
ZLibEx,
{$ELSEIF Defined(DELPHIZLIB)}
{ Use ZLib unit shipped with Delphi }
ZLib,
{$IFEND}
SysUtils, Classes;
ImagingTypes, SysUtils, Classes;
{$IF Defined(IMPASZLIB) or Defined(FPCPASZLIB) or Defined(ZLIBPAS)}
type
TZStreamRec = z_stream;
{$IFEND}
{$IFDEF ZLIBEX}
const
Z_NO_FLUSH = 0;
Z_PARTIAL_FLUSH = 1;
@ -114,7 +114,6 @@ const
Z_UNKNOWN = 2;
Z_DEFLATED = 8;
{$ENDIF}
type
{ Abstract ancestor class }
@ -208,7 +207,8 @@ type
OutBytes = number of bytes in OutBuf }
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
var OutBuf: Pointer; var OutBytes: Integer;
CompressLevel: Integer = Z_DEFAULT_COMPRESSION);
CompressLevel: Integer = Z_DEFAULT_COMPRESSION;
CompressStrategy: Integer = Z_DEFAULT_STRATEGY);
{ DecompressBuf decompresses data, buffer to buffer, in one call.
In: InBuf = ptr to compressed data
@ -266,7 +266,7 @@ end;
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
var OutBuf: Pointer; var OutBytes: Integer;
CompressLevel: Integer);
CompressLevel, CompressStrategy: Integer);
var
strm: TZStreamRec;
P: Pointer;
@ -283,14 +283,17 @@ begin
strm.avail_in := InBytes;
strm.next_out := OutBuf;
strm.avail_out := OutBytes;
CCheck(deflateInit_(strm, CompressLevel, zlib_version, sizeof(strm)));
CCheck(deflateInit2(strm, CompressLevel, Z_DEFLATED, MAX_WBITS,
DEF_MEM_LEVEL, CompressStrategy));
try
while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
begin
P := OutBuf;
Inc(OutBytes, 256);
ReallocMem(OutBuf, OutBytes);
strm.next_out := Pointer(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
strm.next_out := Pointer(PtrUInt(OutBuf) + (PtrUInt(strm.next_out) - PtrUInt(P)));
strm.avail_out := 256;
end;
finally
@ -334,7 +337,7 @@ begin
P := OutBuf;
Inc(OutBytes, BufInc);
ReallocMem(OutBuf, OutBytes);
strm.next_out := Pointer(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
strm.next_out := Pointer(PtrUInt(OutBuf) + (PtrUInt(strm.next_out) - PtrUInt(P)));
strm.avail_out := BufInc;
end;
finally
@ -404,6 +407,7 @@ end;
function TCompressionStream.Read(var Buffer; Count: Longint): Longint;
begin
Result := 0;
raise ECompressionError.Create('Invalid stream operation');
end;
@ -485,6 +489,7 @@ end;
function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
begin
Result := 0;
raise EDecompressionError.Create('Invalid stream operation');
end;

12
Imaging/ZLib/imzutil.pas
View File

@ -32,10 +32,14 @@ type
puIntf = ^uIntf;
puLong = ^uLongf;
ptr2int = uInt;
{ a pointer to integer casting is used to do pointer arithmetic.
ptr2int must be an integer type and sizeof(ptr2int) must be less
than sizeof(pointer) - Nomssi }
{$IF Defined(FPC)}
ptr2int = PtrUInt;
{$ELSEIF CompilerVersion >= 20}
ptr2int = NativeUInt;
{$ELSE}
ptr2int = Cardinal;
{$IFEND}
{ a pointer to integer casting is used to do pointer arithmetic. }
type
zByteArray = array[0..(MaxInt div SizeOf(Bytef))-1] of Bytef;

2
UOLib/ULight.pas
View File

@ -84,7 +84,7 @@ begin
color32.A := 255
else
color32.A := 0;
PColor32(FGraphic.PixelPointers[x, y])^ := color32.Color;
PColor32(FGraphic.PixelPointer[x, y])^ := color32.Color;
end;
buffer.Free;
end;