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

6
Client/UfrmRadar.pas
View File

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

1262
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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains image format loader/saver for Windows Bitmap images.} {
This unit contains image format loader/saver for Windows Bitmap images.
}
unit ImagingBitmap; unit ImagingBitmap;
{$I ImagingOptions.inc} {$I ImagingOptions.inc}
@ -44,6 +29,7 @@ type
TBitmapFileFormat = class(TImageFileFormat) TBitmapFileFormat = class(TImageFileFormat)
protected protected
FUseRLE: LongBool; FUseRLE: LongBool;
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override; OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
@ -51,7 +37,6 @@ type
procedure ConvertToSupported(var Image: TImageData; procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override; const Info: TImageFormatInfo); override;
public public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override; function TestFormat(Handle: TImagingHandle): Boolean; override;
published published
{ Controls that RLE compression is used during saving. Accessible trough { Controls that RLE compression is used during saving. Accessible trough
@ -85,39 +70,39 @@ type
{ File Header for Windows/OS2 bitmap file.} { File Header for Windows/OS2 bitmap file.}
TBitmapFileHeader = packed record TBitmapFileHeader = packed record
ID: Word; // Is always 19778 : 'BM' ID: Word; // Is always 19778 : 'BM'
Size: LongWord; // Filesize Size: UInt32; // File size
Reserved1: Word; Reserved1: Word;
Reserved2: 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; end;
{ Info Header for Windows bitmap file version 4.} { Info Header for Windows bitmap file version 4.}
TBitmapInfoHeader = packed record TBitmapInfoHeader = packed record
Size: LongWord; Size: UInt32;
Width: LongInt; Width: Int32;
Height: LongInt; Height: Int32;
Planes: Word; Planes: Word;
BitCount: Word; BitCount: Word;
Compression: LongWord; Compression: UInt32;
SizeImage: LongWord; SizeImage: UInt32;
XPelsPerMeter: LongInt; XPelsPerMeter: Int32;
YPelsPerMeter: LongInt; YPelsPerMeter: Int32;
ClrUsed: LongInt; ClrUsed: UInt32;
ClrImportant: LongInt; ClrImportant: UInt32;
RedMask: LongWord; RedMask: UInt32;
GreenMask: LongWord; GreenMask: UInt32;
BlueMask: LongWord; BlueMask: UInt32;
AlphaMask: LongWord; AlphaMask: UInt32;
CSType: LongWord; CSType: UInt32;
EndPoints: array[0..8] of LongWord; EndPoints: array[0..8] of UInt32;
GammaRed: LongWord; GammaRed: UInt32;
GammaGreen: LongWord; GammaGreen: UInt32;
GammaBlue: LongWord; GammaBlue: UInt32;
end; end;
{ Info Header for OS2 bitmaps.} { Info Header for OS2 bitmaps.}
TBitmapCoreHeader = packed record TBitmapCoreHeader = packed record
Size: LongWord; Size: UInt32;
Width: Word; Width: Word;
Height: Word; Height: Word;
Planes: Word; Planes: Word;
@ -133,13 +118,11 @@ type
{ TBitmapFileFormat class implementation } { TBitmapFileFormat class implementation }
constructor TBitmapFileFormat.Create; procedure TBitmapFileFormat.Define;
begin begin
inherited Create; inherited;
FName := SBitmapFormatName; FName := SBitmapFormatName;
FCanLoad := True; FFeatures := [ffLoad, ffSave];
FCanSave := True;
FIsMultiImageFormat := False;
FSupportedFormats := BitmapSupportedFormats; FSupportedFormats := BitmapSupportedFormats;
FUseRLE := BitmapDefaultRLE; FUseRLE := BitmapDefaultRLE;
@ -211,8 +194,8 @@ var
procedure LoadRLE4; procedure LoadRLE4;
var var
RLESrc: PByteArray; RLESrc: PByteArray;
Row, Col, WriteRow, I: LongInt; Row, Col, WriteRow, I: Integer;
SrcPos: LongWord; SrcPos: UInt32;
DeltaX, DeltaY, Low, High: Byte; DeltaX, DeltaY, Low, High: Byte;
Pixels: PByteArray; Pixels: PByteArray;
OpCode: TRLEOpcode; OpCode: TRLEOpcode;
@ -228,7 +211,7 @@ var
NegHeightBitmap := BI.Height < 0; NegHeightBitmap := BI.Height < 0;
Row := 0; // Current row in dest image Row := 0; // Current row in dest image
Col := 0; // Current column 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); WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
while (Row < Height) and (SrcPos < BI.SizeImage) do while (Row < Height) and (SrcPos < BI.SizeImage) do
begin begin
@ -308,8 +291,8 @@ var
procedure LoadRLE8; procedure LoadRLE8;
var var
RLESrc: PByteArray; RLESrc: PByteArray;
SrcCount, Row, Col, WriteRow: LongInt; SrcCount, Row, Col, WriteRow: Integer;
SrcPos: LongWord; SrcPos: UInt32;
DeltaX, DeltaY: Byte; DeltaX, DeltaY: Byte;
Pixels: PByteArray; Pixels: PByteArray;
OpCode: TRLEOpcode; OpCode: TRLEOpcode;
@ -324,7 +307,7 @@ var
NegHeightBitmap := BI.Height < 0; NegHeightBitmap := BI.Height < 0;
Row := 0; // Current row in dest image Row := 0; // Current row in dest image
Col := 0; // Current column 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); WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
while (Row < Height) and (SrcPos < BI.SizeImage) do while (Row < Height) and (SrcPos < BI.SizeImage) do
begin begin
@ -425,7 +408,7 @@ begin
BI.SizeImage := BF.Size - BF.Offset; BI.SizeImage := BF.Size - BF.Offset;
end; end;
// Bit mask reading. Only read it if there is V3 header, V4 header has // 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 if (BI.Compression = BI_BITFIELDS) and (BI.Size = V3InfoHeaderSize) then
Read(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3); Read(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3);
@ -455,7 +438,7 @@ begin
// Palette settings and reading // Palette settings and reading
if BI.BitCount <= 8 then if BI.BitCount <= 8 then
begin begin
// Seek to the begining of palette // Seek to the beginning of palette
Seek(Handle, StartPos + SizeOf(TBitmapFileHeader) + LongInt(BI.Size), Seek(Handle, StartPos + SizeOf(TBitmapFileHeader) + LongInt(BI.Size),
smFromBeginning); smFromBeginning);
if IsOS2 then if IsOS2 then
@ -523,12 +506,12 @@ begin
// 1 and 4 bpp images are supported only for loading which is now // 1 and 4 bpp images are supported only for loading which is now
// so we now convert them to 8bpp (and unalign scanlines). // so we now convert them to 8bpp (and unalign scanlines).
case BI.BitCount of case BI.BitCount of
1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes); 1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes, False);
4: 4:
begin begin
// RLE4 bitmaps are translated to 8bit during RLE decoding // RLE4 bitmaps are translated to 8bit during RLE decoding
if BI.Compression <> BI_RLE4 then if BI.Compression <> BI_RLE4 then
Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes); Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes, False);
end; end;
end; end;
// Enlarge palette // Enlarge palette
@ -829,7 +812,7 @@ initialization
Should be less buggy an more readable (load inspired by Colosseum Builders' code). Should be less buggy an more readable (load inspired by Colosseum Builders' code).
- Made public properties for options registered to SetOption/GetOption - Made public properties for options registered to SetOption/GetOption
functions. 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). bitmap loading).
- Moved Convert1To8 and Convert4To8 to ImagingFormats - Moved Convert1To8 and Convert4To8 to ImagingFormats
- Changed extensions to filename masks. - Changed extensions to filename masks.
@ -849,7 +832,7 @@ initialization
-- 0.13 Changes/Bug Fixes ----------------------------------- -- 0.13 Changes/Bug Fixes -----------------------------------
- when loading 1/4 bit images with dword aligned dimensions - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ { This unit contains canvas classes for drawing and applying effects.}
This unit contains canvas classes for drawing and applying effects.
}
unit ImagingCanvases; unit ImagingCanvases;
{$I ImagingOptions.inc} {$I ImagingOptions.inc}
@ -132,7 +113,7 @@ type
TImagingCanvas works for all image data formats except special ones TImagingCanvas works for all image data formats except special ones
(compressed). Because of this its methods are quite slow (they usually work (compressed). Because of this its methods are quite slow (they usually work
with colors in ifA32R32G32B32F format). If you want fast drawing you 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 work only for few select formats (or only one) but they are optimized thus
much faster. much faster.
} }
@ -179,7 +160,7 @@ type
procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual; 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 CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; 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; procedure StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor;
Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc); Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc);
@ -230,13 +211,13 @@ type
Resulting destination pixel color is: Resulting destination pixel color is:
SrcColor * SrcFactor + DstColor * DstFactor} SrcColor * SrcFactor + DstColor * DstFactor}
procedure DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; 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 { Draws contents of this canvas onto another one with typical alpha
blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} 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 { Draws contents of this canvas onto another one using additive blending
(source and dest factors are bfOne).} (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 { Draws stretched and filtered contents of this canvas onto another canvas
with pixel blending. Blending factors are chosen using TBlendingFactor parameters. with pixel blending. Blending factors are chosen using TBlendingFactor parameters.
Resulting destination pixel color is: Resulting destination pixel color is:
@ -293,7 +274,7 @@ type
procedure ModifyContrastBrightness(Contrast, Brightness: Single); procedure ModifyContrastBrightness(Contrast, Brightness: Single);
{ Gamma correction of individual color channels. Range is (0, +inf), { Gamma correction of individual color channels. Range is (0, +inf),
1.0 means no change.} 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.} { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.}
procedure InvertColors; virtual; procedure InvertColors; virtual;
{ Simple single level thresholding with threshold level (in range [0, 1]) { 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; property PixelsFP[X, Y: LongInt]: TColorFPRec read GetPixelFP write SetPixelFP;
{ Clipping rectangle of this canvas. No pixels outside this rectangle are { Clipping rectangle of this canvas. No pixels outside this rectangle are
altered by canvas methods if Clipping property is True. Clip rect gets 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; property ClipRect: TRect read FClipRect write SetClipRect;
{ Extended format information.} { Extended format information.}
property FormatInfo: TImageFormatInfo read FFormatInfo; 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.} may crash.}
property Valid: Boolean read GetValid; property Valid: Boolean read GetValid;
@ -379,7 +360,7 @@ type
procedure UpdateCanvasState; override; 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; procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override; const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override;
procedure InvertColors; override; procedure InvertColors; override;
@ -395,7 +376,8 @@ const
Kernel: ((1, 1, 1), Kernel: ((1, 1, 1),
(1, 1, 1), (1, 1, 1),
(1, 1, 1)); (1, 1, 1));
Divisor: 9); Divisor: 9;
Bias: 0);
{ Kernel for 5x5 average smoothing filter.} { Kernel for 5x5 average smoothing filter.}
FilterAverage5x5: TConvolutionFilter5x5 = ( FilterAverage5x5: TConvolutionFilter5x5 = (
@ -404,14 +386,16 @@ const
(1, 1, 1, 1, 1), (1, 1, 1, 1, 1),
(1, 1, 1, 1, 1), (1, 1, 1, 1, 1),
(1, 1, 1, 1, 1)); (1, 1, 1, 1, 1));
Divisor: 25); Divisor: 25;
Bias: 0);
{ Kernel for 3x3 Gaussian smoothing filter.} { Kernel for 3x3 Gaussian smoothing filter.}
FilterGaussian3x3: TConvolutionFilter3x3 = ( FilterGaussian3x3: TConvolutionFilter3x3 = (
Kernel: ((1, 2, 1), Kernel: ((1, 2, 1),
(2, 4, 2), (2, 4, 2),
(1, 2, 1)); (1, 2, 1));
Divisor: 16); Divisor: 16;
Bias: 0);
{ Kernel for 5x5 Gaussian smoothing filter.} { Kernel for 5x5 Gaussian smoothing filter.}
FilterGaussian5x5: TConvolutionFilter5x5 = ( FilterGaussian5x5: TConvolutionFilter5x5 = (
@ -420,49 +404,56 @@ const
(6, 24, 36, 24, 6), (6, 24, 36, 24, 6),
(4, 16, 24, 16, 4), (4, 16, 24, 16, 4),
(1, 4, 6, 4, 1)); (1, 4, 6, 4, 1));
Divisor: 256); Divisor: 256;
Bias: 0);
{ Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).} { Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).}
FilterSobelHorz3x3: TConvolutionFilter3x3 = ( FilterSobelHorz3x3: TConvolutionFilter3x3 = (
Kernel: (( 1, 2, 1), Kernel: (( 1, 2, 1),
( 0, 0, 0), ( 0, 0, 0),
(-1, -2, -1)); (-1, -2, -1));
Divisor: 1); Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).} { Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).}
FilterSobelVert3x3: TConvolutionFilter3x3 = ( FilterSobelVert3x3: TConvolutionFilter3x3 = (
Kernel: ((-1, 0, 1), Kernel: ((-1, 0, 1),
(-2, 0, 2), (-2, 0, 2),
(-1, 0, 1)); (-1, 0, 1));
Divisor: 1); Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Prewitt horizontal edge detection filter.} { Kernel for 3x3 Prewitt horizontal edge detection filter.}
FilterPrewittHorz3x3: TConvolutionFilter3x3 = ( FilterPrewittHorz3x3: TConvolutionFilter3x3 = (
Kernel: (( 1, 1, 1), Kernel: (( 1, 1, 1),
( 0, 0, 0), ( 0, 0, 0),
(-1, -1, -1)); (-1, -1, -1));
Divisor: 1); Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Prewitt vertical edge detection filter.} { Kernel for 3x3 Prewitt vertical edge detection filter.}
FilterPrewittVert3x3: TConvolutionFilter3x3 = ( FilterPrewittVert3x3: TConvolutionFilter3x3 = (
Kernel: ((-1, 0, 1), Kernel: ((-1, 0, 1),
(-1, 0, 1), (-1, 0, 1),
(-1, 0, 1)); (-1, 0, 1));
Divisor: 1); Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Kirsh horizontal edge detection filter.} { Kernel for 3x3 Kirsh horizontal edge detection filter.}
FilterKirshHorz3x3: TConvolutionFilter3x3 = ( FilterKirshHorz3x3: TConvolutionFilter3x3 = (
Kernel: (( 5, 5, 5), Kernel: (( 5, 5, 5),
(-3, 0, -3), (-3, 0, -3),
(-3, -3, -3)); (-3, -3, -3));
Divisor: 1); Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Kirsh vertical edge detection filter.} { Kernel for 3x3 Kirsh vertical edge detection filter.}
FilterKirshVert3x3: TConvolutionFilter3x3 = ( FilterKirshVert3x3: TConvolutionFilter3x3 = (
Kernel: ((5, -3, -3), Kernel: ((5, -3, -3),
(5, 0, -3), (5, 0, -3),
(5, -3, -3)); (5, -3, -3));
Divisor: 1); Divisor: 1;
Bias: 0);
{ Kernel for 3x3 Laplace omni-directional edge detection filter { Kernel for 3x3 Laplace omni-directional edge detection filter
(2nd derivative approximation).} (2nd derivative approximation).}
@ -470,7 +461,8 @@ const
Kernel: ((-1, -1, -1), Kernel: ((-1, -1, -1),
(-1, 8, -1), (-1, 8, -1),
(-1, -1, -1)); (-1, -1, -1));
Divisor: 1); Divisor: 1;
Bias: 0);
{ Kernel for 5x5 Laplace omni-directional edge detection filter { Kernel for 5x5 Laplace omni-directional edge detection filter
(2nd derivative approximation).} (2nd derivative approximation).}
@ -480,23 +472,26 @@ const
(-1, -1, 24, -1, -1), (-1, -1, 24, -1, -1),
(-1, -1, -1, -1, -1), (-1, -1, -1, -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 = ( FilterSharpen3x3: TConvolutionFilter3x3 = (
Kernel: ((-1, -1, -1), Kernel: ((-1, -1, -1),
(-1, 9, -1), (-1, 9, -1),
(-1, -1, -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 = ( FilterSharpen5x5: TConvolutionFilter5x5 = (
Kernel: ((-1, -1, -1, -1, -1), Kernel: ((-1, -1, -1, -1, -1),
(-1, -1, -1, -1, -1), (-1, -1, -1, -1, -1),
(-1, -1, 25, -1, -1), (-1, -1, 25, -1, -1),
(-1, -1, -1, -1, -1), (-1, -1, -1, -1, -1),
(-1, -1, -1, -1, -1)); (-1, -1, -1, -1, -1));
Divisor: 1); Divisor: 1;
Bias: 0);
{ Kernel for 5x5 glow filter.} { Kernel for 5x5 glow filter.}
FilterGlow5x5: TConvolutionFilter5x5 = ( FilterGlow5x5: TConvolutionFilter5x5 = (
@ -505,17 +500,19 @@ const
( 2, 0, -20, 0, 2), ( 2, 0, -20, 0, 2),
( 2, 0, 0, 0, 2), ( 2, 0, 0, 0, 2),
( 1, 2, 2, 2, 1)); ( 1, 2, 2, 2, 1));
Divisor: 8); Divisor: 8;
Bias: 0);
{ Kernel for 3x3 edge enhancement filter.} { Kernel for 3x3 edge enhancement filter.}
FilterEdgeEnhance3x3: TConvolutionFilter3x3 = ( FilterEdgeEnhance3x3: TConvolutionFilter3x3 = (
Kernel: ((-1, -2, -1), Kernel: ((-1, -2, -1),
(-2, 16, -2), (-2, 16, -2),
(-1, -2, -1)); (-1, -2, -1));
Divisor: 4); Divisor: 4;
Bias: 0);
{ Kernel for 3x3 contour enhancement filter.} { Kernel for 3x3 contour enhancement filter.}
FilterTraceControur3x3: TConvolutionFilter3x3 = ( FilterTraceContour3x3: TConvolutionFilter3x3 = (
Kernel: ((-6, -6, -2), Kernel: ((-6, -6, -2),
(-1, 32, -1), (-1, 32, -1),
(-6, -2, -6)); (-6, -2, -6));
@ -616,6 +613,8 @@ begin
bfOneMinusDstAlpha: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A); bfOneMinusDstAlpha: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A);
bfDstColor: FSrc := ColorFP(DestPix.A, DestPix.R, DestPix.G, DestPix.B); 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); bfOneMinusDstColor: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.R, 1 - DestPix.G, 1 - DestPix.B);
else
Assert(False);
end; end;
case DestFactor of case DestFactor of
bfZero: FDst := ColorFP(0, 0, 0, 0); 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); 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); 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); bfOneMinusSrcColor: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.R, 1 - SrcPix.G, 1 - SrcPix.B);
else
Assert(False);
end; end;
// Compute blending formula // Compute blending formula
DestPix.R := SrcPix.R * FSrc.R + DestPix.R * FDst.R; DestPix.R := SrcPix.R * FSrc.R + DestPix.R * FDst.R;
@ -645,7 +646,10 @@ begin
DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
// Blend the two pixels (Src 'over' Dest alpha composition operation) // Blend the two pixels (Src 'over' Dest alpha composition operation)
DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A; 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; DestAlpha := 1.0 - SrcAlpha;
DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha; DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha;
DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha; DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha;
@ -786,9 +790,9 @@ end;
function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
begin begin
Result.A := Pixel.A; Result.A := Pixel.A;
Result.R := Result.R * Pixel.A; Result.R := Pixel.R * Pixel.A;
Result.G := Result.G * Pixel.A; Result.G := Pixel.G * Pixel.A;
Result.B := Result.B * Pixel.A; Result.B := Pixel.B * Pixel.A;
end; end;
function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
@ -796,9 +800,9 @@ begin
Result.A := Pixel.A; Result.A := Pixel.A;
if Pixel.A <> 0.0 then if Pixel.A <> 0.0 then
begin begin
Result.R := Result.R / Pixel.A; Result.R := Pixel.R / Pixel.A;
Result.G := Result.G / Pixel.A; Result.G := Pixel.G / Pixel.A;
Result.B := Result.B / Pixel.A; Result.B := Pixel.B / Pixel.A;
end end
else else
begin begin
@ -906,8 +910,7 @@ end;
procedure TImagingCanvas.SetClipRect(const Value: TRect); procedure TImagingCanvas.SetClipRect(const Value: TRect);
begin begin
FClipRect := Value; FClipRect := Value;
SwapMin(FClipRect.Left, FClipRect.Right); NormalizeRect(FClipRect);
SwapMin(FClipRect.Top, FClipRect.Bottom);
IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height)); IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height));
end; end;
@ -987,7 +990,7 @@ begin
case Bpp of case Bpp of
1: FillMemoryByte(PixelPtr, WidthBytes, PByte(Color)^); 1: FillMemoryByte(PixelPtr, WidthBytes, PByte(Color)^);
2: FillMemoryWord(PixelPtr, WidthBytes, PWord(Color)^); 2: FillMemoryWord(PixelPtr, WidthBytes, PWord(Color)^);
4: FillMemoryLongWord(PixelPtr, WidthBytes, PLongWord(Color)^); 4: FillMemoryUInt32(PixelPtr, WidthBytes, PUInt32(Color)^);
else else
for I := X1 to X2 do for I := X1 to X2 do
begin begin
@ -1046,16 +1049,16 @@ begin
if FPenMode = pmClear then Exit; if FPenMode = pmClear then Exit;
// If line is vertical or horizontal just call appropriate method // If line is vertical or horizontal just call appropriate method
if X2 - X1 = 0 then if X2 = X1 then
begin
HorzLine(X1, X2, Y1);
Exit;
end;
if Y2 - Y1 = 0 then
begin begin
VertLine(X1, Y1, Y2); VertLine(X1, Y1, Y2);
Exit; Exit;
end; end;
if Y2 = Y1 then
begin
HorzLine(X1, X2, Y1);
Exit;
end;
// Determine if line is steep (angle with X-axis > 45 degrees) // Determine if line is steep (angle with X-axis > 45 degrees)
Steep := Abs(Y2 - Y1) > Abs(X2 - X1); Steep := Abs(Y2 - Y1) > Abs(X2 - X1);
@ -1354,10 +1357,10 @@ begin
end; end;
procedure TImagingCanvas.DrawInternal(const SrcRect: TRect; procedure TImagingCanvas.DrawInternal(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor, DestCanvas: TImagingCanvas; DestX, DestY: LongInt; SrcFactor,
DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc); DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
var var
X, Y, SrcX, SrcY, Width, Height, SrcBpp, DestBpp: Integer; X, Y, SrcX, SrcY, Width, Height, SrcBpp, DestBpp: LongInt;
PSrc: TColorFPRec; PSrc: TColorFPRec;
SrcPointer, DestPointer: PByte; SrcPointer, DestPointer: PByte;
begin begin
@ -1391,19 +1394,19 @@ begin
end; end;
procedure TImagingCanvas.DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; procedure TImagingCanvas.DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas;
DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor); DestX, DestY: LongInt; SrcFactor, DestFactor: TBlendingFactor);
begin begin
DrawInternal(SrcRect, DestCanvas, DestX, DestY, SrcFactor, DestFactor, PixelBlendProc); DrawInternal(SrcRect, DestCanvas, DestX, DestY, SrcFactor, DestFactor, PixelBlendProc);
end; end;
procedure TImagingCanvas.DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; procedure TImagingCanvas.DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
DestX, DestY: Integer); DestX, DestY: LongInt);
begin begin
DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAlphaProc); DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAlphaProc);
end; end;
procedure TImagingCanvas.DrawAdd(const SrcRect: TRect; procedure TImagingCanvas.DrawAdd(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer); DestCanvas: TImagingCanvas; DestX, DestY: LongInt);
begin begin
DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAddProc); DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAddProc);
end; end;
@ -1414,13 +1417,13 @@ procedure TImagingCanvas.StretchDrawInternal(const SrcRect: TRect;
PixelWriteProc: TPixelWriteProc); PixelWriteProc: TPixelWriteProc);
const const
FilterMapping: array[TResizeFilter] of TSamplingFilter = FilterMapping: array[TResizeFilter] of TSamplingFilter =
(sfNearest, sfLinear, DefaultCubicFilter); (sfNearest, sfLinear, DefaultCubicFilter, sfLanczos);
var var
X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: Integer; X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: Integer; DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: LongInt;
SrcPix, PDest: TColorFPRec; SrcPix: TColorFPRec;
MapX, MapY: TMappingTable; MapX, MapY: TMappingTable;
XMinimum, XMaximum: Integer; XMinimum, XMaximum: LongInt;
LineBuffer: array of TColorFPRec; LineBuffer: array of TColorFPRec;
ClusterX, ClusterY: TCluster; ClusterX, ClusterY: TCluster;
Weight, AccumA, AccumR, AccumG, AccumB: Single; Weight, AccumA, AccumR, AccumG, AccumB: Single;
@ -1572,10 +1575,10 @@ begin
PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1); PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1);
SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp]; 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 // colors to accumulators weighted by filter kernel values
Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette); Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette);
KernelValue := PLongIntArray(Kernel)[J * KernelSize + I]; KernelValue := PUInt32Array(Kernel)[J * KernelSize + I];
R := R + Pixel.R * KernelValue; R := R + Pixel.R * KernelValue;
G := G + Pixel.G * KernelValue; G := G + Pixel.G * KernelValue;
@ -1714,7 +1717,7 @@ begin
Brightness / 100, 0); Brightness / 100, 0);
end; end;
procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single); procedure TImagingCanvas.GammaCorrection(Red, Green, Blue: Single);
begin begin
PointTransform(TransformGamma, Red, Green, Blue); PointTransform(TransformGamma, Red, Green, Blue);
end; end;
@ -1852,9 +1855,9 @@ begin
end; end;
procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect; procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer); DestCanvas: TImagingCanvas; DestX, DestY: LongInt);
var var
X, Y, SrcX, SrcY, Width, Height: Integer; X, Y, SrcX, SrcY, Width, Height: LongInt;
SrcPix, DestPix: PColor32Rec; SrcPix, DestPix: PColor32Rec;
begin begin
if DestCanvas.ClassType <> Self.ClassType then if DestCanvas.ClassType <> Self.ClassType then
@ -1900,10 +1903,10 @@ end;
procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect; procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect;
DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
var var
X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4, X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4, InvFracY, T1, T2: Integer;
FracX, FracY, InvFracY, T1, T2: Integer; FracX, FracY: Cardinal;
SrcX, SrcY, SrcWidth, SrcHeight: Integer; SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
DestX, DestY, DestWidth, DestHeight: Integer; DestX, DestY, DestWidth, DestHeight: LongInt;
SrcLine, SrcLine2: PColor32RecArray; SrcLine, SrcLine2: PColor32RecArray;
DestPix: PColor32Rec; DestPix: PColor32Rec;
Accum: TColor32Rec; Accum: TColor32Rec;
@ -1985,9 +1988,9 @@ begin
end; end;
T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1); 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; Weight1:= InvFracY - Weight2;
Weight4:= (Cardinal(FracY) * FracX) shr 16; Weight4:= Integer((Cardinal(FracY) * FracX) shr 16);
Weight3:= FracY - Weight4; Weight3:= FracY - Weight4;
Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 + Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 +
@ -2007,83 +2010,12 @@ begin
Inc(Yp, ScaleY); Inc(Yp, ScaleY);
end; end;
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; end;
procedure TFastARGB32Canvas.UpdateCanvasState; procedure TFastARGB32Canvas.UpdateCanvasState;
var var
I: LongInt; I: LongInt;
ScanPos: PLongWord; ScanPos: PUInt32;
begin begin
inherited UpdateCanvasState; inherited UpdateCanvasState;
@ -2133,9 +2065,14 @@ finalization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- more more more ... - more more more ...
- implement pen width everywhere - implement pen width everywhere
- add blending (*image and object drawing)
- more objects (arc, polygon) - 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 --------------------------------- -- 0.26.3 Changes/Bug Fixes ---------------------------------
- Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha) - Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha)
- Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation. - Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation.
@ -2146,7 +2083,7 @@ finalization
- Added FloodFill method. - Added FloodFill method.
- Added GetHistogram method. - Added GetHistogram method.
- Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes - Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes
(thanks to Carlos González). (thanks to Carlos Gonzalez).
- Added TImagingCanvas.AdjustColorLevels method. - Added TImagingCanvas.AdjustColorLevels method.
-- 0.25.0 Changes/Bug Fixes --------------------------------- -- 0.25.0 Changes/Bug Fixes ---------------------------------
@ -2169,7 +2106,7 @@ finalization
-- 0.19 Changes/Bug Fixes ----------------------------------- -- 0.19 Changes/Bug Fixes -----------------------------------
- added TFastARGB32Canvas - added TFastARGB32Canvas
- added convolutions, hline, vline - added convolutions, hline, vline
- unit created, intial stuff added - unit created, initial stuff added
} }

486
Imaging/ImagingClasses.pas
View File

@ -1,29 +1,12 @@
{ {
$Id: ImagingClasses.pas 173 2009-09-04 17:05:52Z galfar $
Vampyre Imaging Library Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains class based wrapper to Imaging library.} { 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 { Base abstract high level class wrapper to low level Imaging structures and
functions.} functions.}
TBaseImage = class(TPersistent) TBaseImage = class(TPersistent)
private
function GetEmpty: Boolean;
protected protected
FPData: PImageData; FPData: PImageData;
FOnDataSizeChanged: TNotifyEvent; FOnDataSizeChanged: TNotifyEvent;
FOnPixelsChanged: TNotifyEvent; FOnPixelsChanged: TNotifyEvent;
function GetFormat: TImageFormat; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetFormat: TImageFormat; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetHeight: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetHeight: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetSize: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetSize: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetWidth: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetWidth: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetBits: Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetBits: Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPalette: PPalette32; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetPalette: PPalette32; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPaletteEntries: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetPaletteEntries: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetScanLine(Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetScanline(Index: Integer): Pointer;
function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} 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 GetFormatInfo: TImageFormatInfo; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetBoundsRect: TRect; function GetBoundsRect: TRect;
procedure SetFormat(const Value: TImageFormat); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetFormat(const Value: TImageFormat); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetHeight(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetHeight(const Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetWidth(const Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetPointer; virtual; abstract; procedure SetPointer; virtual; abstract;
procedure DoDataSizeChanged; virtual; procedure DoDataSizeChanged; virtual;
procedure DoPixelsChanged; virtual; procedure DoPixelsChanged; virtual;
published
public public
constructor Create; virtual; constructor Create; virtual;
constructor CreateFromImage(AImage: TBaseImage); constructor CreateFromImage(AImage: TBaseImage);
destructor Destroy; override; destructor Destroy; override;
{ Returns info about current image.} { 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 { Creates a new image data with the given size and format. Old image
data is lost. Works only for the current image of TMultiImage.} 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.} { 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 { Flips current image. Reverses the image along its horizontal axis the top
becomes the bottom and vice versa.} becomes the bottom and vice versa.}
procedure Flip; procedure Flip;
@ -88,21 +82,27 @@ type
negative X and Y coordinates. negative X and Y coordinates.
Note that copying is fastest for images in the same data format Note that copying is fastest for images in the same data format
(and slowest for images in special formats).} (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 { Stretches the contents of the source rectangle to the destination rectangle
with optional resampling. No blending is performed - alpha is with optional resampling. No blending is performed - alpha is
simply copied/resampled to destination image. Note that stretching is simply copied/resampled to destination image. Note that stretching is
fastest for images in the same data format (and slowest for fastest for images in the same data format (and slowest for
images in special formats).} 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. { Replaces pixels with OldPixel in the given rectangle by NewPixel.
OldPixel and NewPixel should point to the pixels in the same format OldPixel and NewPixel should point to the pixels in the same format
as the given image is in.} 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. { Swaps SrcChannel and DstChannel color or alpha channels of image.
Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
identify channels.} identify channels.}
procedure SwapChannels(SrcChannel, DstChannel: LongInt); procedure SwapChannels(SrcChannel, DstChannel: Integer);
{ Loads current image data from file.} { Loads current image data from file.}
procedure LoadFromFile(const FileName: string); virtual; procedure LoadFromFile(const FileName: string); virtual;
@ -110,31 +110,33 @@ type
procedure LoadFromStream(Stream: TStream); virtual; procedure LoadFromStream(Stream: TStream); virtual;
{ Saves current image data to file.} { 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 { Saves current image data to stream. Ext identifies desired image file
format (jpg, png, dds, ...)} format (jpg, png, dds, ...).}
procedure SaveToStream(const Ext: string; Stream: TStream); function SaveToStream(const Ext: string; Stream: TStream): Boolean;
{ Width of current image in pixels.} { 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.} { 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.} { Image data format of current image.}
property Format: TImageFormat read GetFormat write SetFormat; property Format: TImageFormat read GetFormat write SetFormat;
{ Size in bytes of current image's data.} { Size in bytes of current image's data.}
property Size: LongInt read GetSize; property Size: Integer read GetSize;
{ Pointer to memory containing image bits.} { Pointer to memory containing image bits.}
property Bits: Pointer read GetBits; property Bits: Pointer read GetBits;
{ Pointer to palette for indexed format images. It is nil for others. { Pointer to palette for indexed format images. It is nil for others.
Max palette entry is at index [PaletteEntries - 1].} Max palette entry is at index [PaletteEntries - 1].}
property Palette: PPalette32 read GetPalette; property Palette: PPalette32 read GetPalette;
{ Number of entries in image's palette} { 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 { Provides indexed access to each line of pixels. Does not work with special
format images (like DXT).} 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.} { 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.} { Extended image format information.}
property FormatInfo: TImageFormatInfo read GetFormatInfo; property FormatInfo: TImageFormatInfo read GetFormatInfo;
{ This gives complete access to underlying TImageData record. { This gives complete access to underlying TImageData record.
@ -144,7 +146,9 @@ type
{ Indicates whether the current image is valid (proper format, { Indicates whether the current image is valid (proper format,
allowed dimensions, right size, ...).} allowed dimensions, right size, ...).}
property Valid: Boolean read GetValid; 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; property BoundsRect: TRect read GetBoundsRect;
{ This event occurs when the image data size has just changed. That means { This event occurs when the image data size has just changed. That means
image width, height, or format has been changed.} image width, height, or format has been changed.}
@ -161,13 +165,15 @@ type
procedure SetPointer; override; procedure SetPointer; override;
public public
constructor Create; override; 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 CreateFromData(const AData: TImageData);
constructor CreateFromFile(const FileName: string); constructor CreateFromFile(const FileName: string);
constructor CreateFromStream(Stream: TStream); constructor CreateFromStream(Stream: TStream);
destructor Destroy; override; destructor Destroy; override;
{ Assigns single image from another single image or multi image.} { Assigns single image from another single image or multi image.}
procedure Assign(Source: TPersistent); override; procedure Assign(Source: TPersistent); override;
{ Assigns single image from image data record.}
procedure AssignFromImageData(const AImageData: TImageData);
end; end;
{ Extension of TBaseImage which uses array of TImageData records to { Extension of TBaseImage which uses array of TImageData records to
@ -180,70 +186,74 @@ type
TMultiImage = class(TBaseImage) TMultiImage = class(TBaseImage)
protected protected
FDataArray: TDynImageDataArray; FDataArray: TDynImageDataArray;
FActiveImage: LongInt; FActiveImage: Integer;
procedure SetActiveImage(Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetActiveImage(Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetImageCount: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetImageCount: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetImageCount(Value: LongInt); procedure SetImageCount(Value: Integer);
function GetAllImagesValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetAllImagesValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetImage(Index: LongInt): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF} function GetImage(Index: Integer): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetImage(Index: LongInt; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetImage(Index: Integer; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetPointer; override; procedure SetPointer; override;
function PrepareInsert(Index, Count: LongInt): Boolean; function PrepareInsert(Index, InsertCount: Integer): Boolean;
procedure DoInsertImages(Index: LongInt; const Images: TDynImageDataArray); procedure DoInsertImages(Index: Integer; const Images: TDynImageDataArray);
procedure DoInsertNew(Index: LongInt; AWidth, AHeight: LongInt; AFormat: TImageFormat); procedure DoInsertNew(Index: Integer; AWidth, AHeight: Integer; AFormat: TImageFormat);
public public
constructor Create; override; constructor Create; override;
constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat; Images: LongInt); constructor CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat; ImageCount: Integer);
constructor CreateFromArray(ADataArray: TDynImageDataArray); constructor CreateFromArray(const ADataArray: TDynImageDataArray);
constructor CreateFromFile(const FileName: string); constructor CreateFromFile(const FileName: string);
constructor CreateFromStream(Stream: TStream); constructor CreateFromStream(Stream: TStream);
destructor Destroy; override; destructor Destroy; override;
{ Assigns multi image from another multi image or single image.} { Assigns multi image from another multi image or single image.}
procedure Assign(Source: TPersistent); override; 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. } { Adds new image at the end of the image array. Returns index of the added image.}
procedure AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload; function AddImage(AWidth, AHeight: Integer; AFormat: TImageFormat = ifDefault): Integer; overload;
{ Adds existing image at the end of the image array. } { Adds existing image at the end of the image array. Returns index of the added image.}
procedure AddImage(const Image: TImageData); overload; function AddImage(const Image: TImageData): Integer; overload;
{ Adds existing image (Active image of a TmultiImage) { Adds existing image (or active image of a TMultiImage)
at the end of the image array. } at the end of the image array. Returns index of the added image.}
procedure AddImage(Image: TBaseImage); overload; function AddImage(Image: TBaseImage): Integer; overload;
{ Adds existing image array ((all images of a multi image)) { Adds existing image array (all images of a multi image)
at the end of the image array.} at the end of the image array.}
procedure AddImages(const Images: TDynImageDataArray); overload; 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; procedure AddImages(Images: TMultiImage); overload;
{ Inserts new image image at the given position in the image array. } { 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. } { Inserts existing image at the given position in the image array. }
procedure InsertImage(Index: LongInt; const Image: TImageData); overload; procedure InsertImage(Index: Integer; const Image: TImageData); overload;
{ Inserts existing image (Active image of a TmultiImage) { Inserts existing image (Active image of a TMultiImage)
at the given position in the image array. } 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. } { Inserts existing image at the given position in the image array. }
procedure InsertImages(Index: LongInt; const Images: TDynImageDataArray); overload; procedure InsertImages(Index: Integer; const Images: TDynImageDataArray); overload;
{ Inserts existing images (all images of a TmultiImage) at { Inserts existing images (all images of a TMultiImage) at
the given position in the image array. } 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. } { 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.} { 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.} { Rearranges images so that the first image will become last and vice versa.}
procedure ReverseImages; procedure ReverseImages;
{ Deletes all images.}
procedure ClearAll;
{ Converts all images to another image data format.} { Converts all images to another image data format.}
procedure ConvertImages(Format: TImageFormat); procedure ConvertImages(Format: TImageFormat);
{ Resizes all images.} { 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 { Overloaded loading method that will add new image to multi-image if
image array is empty bero loading. } image array is empty before loading. If it's not empty the active image is replaced.}
procedure LoadFromFile(const FileName: string); override; procedure LoadFromFile(const FileName: string); override;
{ Overloaded loading method that will add new image to multiimage if { Overloaded loading method that will add new image to multi-image if
image array is empty bero loading. } image array is empty before loading. If it's not empty the active image is replaced.}
procedure LoadFromStream(Stream: TStream); override; procedure LoadFromStream(Stream: TStream); override;
{ Loads whole multi image from file.} { Loads whole multi image from file.}
@ -251,16 +261,16 @@ type
{ Loads whole multi image from stream.} { Loads whole multi image from stream.}
procedure LoadMultiFromStream(Stream: TStream); procedure LoadMultiFromStream(Stream: TStream);
{ Saves whole multi image to file.} { 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 { Saves whole multi image to stream. Ext identifies desired
image file format (jpg, png, dds, ...).} 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 { Indicates active image of this multi image. All methods inherited
from TBaseImage operate on this image only.} 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.} { 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.} { This value is True if all images of this TMultiImage are valid.}
property AllImagesValid: Boolean read GetAllImagesValid; property AllImagesValid: Boolean read GetAllImagesValid;
{ This gives complete access to underlying TDynImageDataArray. { This gives complete access to underlying TDynImageDataArray.
@ -269,7 +279,7 @@ type
property DataArray: TDynImageDataArray read FDataArray; property DataArray: TDynImageDataArray read FDataArray;
{ Array property for accessing individual images of TMultiImage. When you { 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.} 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; end;
implementation implementation
@ -277,7 +287,6 @@ implementation
const const
DefaultWidth = 16; DefaultWidth = 16;
DefaultHeight = 16; DefaultHeight = 16;
DefaultImages = 1;
function GetArrayFromImageData(const ImageData: TImageData): TDynImageDataArray; function GetArrayFromImageData(const ImageData: TImageData): TDynImageDataArray;
begin begin
@ -303,7 +312,7 @@ begin
inherited Destroy; inherited Destroy;
end; end;
function TBaseImage.GetWidth: LongInt; function TBaseImage.GetWidth: Integer;
begin begin
if Valid then if Valid then
Result := FPData.Width Result := FPData.Width
@ -311,7 +320,7 @@ begin
Result := 0; Result := 0;
end; end;
function TBaseImage.GetHeight: LongInt; function TBaseImage.GetHeight: Integer;
begin begin
if Valid then if Valid then
Result := FPData.Height Result := FPData.Height
@ -327,7 +336,7 @@ begin
Result := ifUnknown; Result := ifUnknown;
end; end;
function TBaseImage.GetScanLine(Index: LongInt): Pointer; function TBaseImage.GetScanline(Index: Integer): Pointer;
var var
Info: TImageFormatInfo; Info: TImageFormatInfo;
begin begin
@ -343,7 +352,15 @@ begin
Result := nil; Result := nil;
end; 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 begin
if Valid then if Valid then
Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * GetFormatInfo.BytesPerPixel] Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * GetFormatInfo.BytesPerPixel]
@ -351,7 +368,7 @@ begin
Result := nil; Result := nil;
end; end;
function TBaseImage.GetSize: LongInt; function TBaseImage.GetSize: Integer;
begin begin
if Valid then if Valid then
Result := FPData.Size Result := FPData.Size
@ -375,7 +392,7 @@ begin
Result := nil; Result := nil;
end; end;
function TBaseImage.GetPaletteEntries: LongInt; function TBaseImage.GetPaletteEntries: Integer;
begin begin
Result := GetFormatInfo.PaletteEntries; Result := GetFormatInfo.PaletteEntries;
end; end;
@ -398,12 +415,17 @@ begin
Result := Rect(0, 0, GetWidth, GetHeight); Result := Rect(0, 0, GetWidth, GetHeight);
end; end;
procedure TBaseImage.SetWidth(const Value: LongInt); function TBaseImage.GetEmpty: Boolean;
begin
Result := FPData.Size = 0;
end;
procedure TBaseImage.SetWidth(const Value: Integer);
begin begin
Resize(Value, GetHeight, rfNearest); Resize(Value, GetHeight, rfNearest);
end; end;
procedure TBaseImage.SetHeight(const Value: LongInt); procedure TBaseImage.SetHeight(const Value: Integer);
begin begin
Resize(GetWidth, Value, rfNearest); Resize(GetWidth, Value, rfNearest);
end; end;
@ -427,18 +449,45 @@ begin
FOnPixelsChanged(Self); FOnPixelsChanged(Self);
end; end;
procedure TBaseImage.RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat); procedure TBaseImage.RecreateImageData(AWidth, AHeight: Integer; AFormat: TImageFormat);
begin begin
if Assigned(FPData) and Imaging.NewImage(AWidth, AHeight, AFormat, FPData^) then if Assigned(FPData) and Imaging.NewImage(AWidth, AHeight, AFormat, FPData^) then
DoDataSizeChanged; DoDataSizeChanged;
end; 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 begin
if Valid and Imaging.ResizeImage(FPData^, NewWidth, NewHeight, Filter) then if Valid and Imaging.ResizeImage(FPData^, NewWidth, NewHeight, Filter) then
DoDataSizeChanged; DoDataSizeChanged;
end; 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; procedure TBaseImage.Flip;
begin begin
if Valid and Imaging.FlipImage(FPData^) then if Valid and Imaging.FlipImage(FPData^) then
@ -453,12 +502,15 @@ end;
procedure TBaseImage.Rotate(Angle: Single); procedure TBaseImage.Rotate(Angle: Single);
begin begin
if Valid and Imaging.RotateImage(FPData^, Angle) then if Valid then
begin
Imaging.RotateImage(FPData^, Angle);
DoPixelsChanged; DoPixelsChanged;
end; end;
end;
procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: LongInt; procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: Integer;
DstImage: TBaseImage; DstX, DstY: LongInt); DstImage: TBaseImage; DstX, DstY: Integer);
begin begin
if Valid and Assigned(DstImage) and DstImage.Valid then if Valid and Assigned(DstImage) and DstImage.Valid then
begin begin
@ -467,8 +519,17 @@ begin
end; end;
end; end;
procedure TBaseImage.StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt; procedure TBaseImage.CopyTo(DstImage: TBaseImage; DstX, DstY: Integer);
DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter); 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 begin
if Valid and Assigned(DstImage) and DstImage.Valid then if Valid and Assigned(DstImage) and DstImage.Valid then
begin begin
@ -514,16 +575,20 @@ begin
DoDataSizeChanged; DoDataSizeChanged;
end; end;
procedure TBaseImage.SaveToFile(const FileName: string); function TBaseImage.SaveToFile(const FileName: string): Boolean;
begin begin
if Valid then if Valid then
Imaging.SaveImageToFile(FileName, FPData^); Result := Imaging.SaveImageToFile(FileName, FPData^)
else
Result := False;
end; end;
procedure TBaseImage.SaveToStream(const Ext: string; Stream: TStream); function TBaseImage.SaveToStream(const Ext: string; Stream: TStream): Boolean;
begin begin
if Valid then if Valid then
Imaging.SaveImageToStream(Ext, Stream, FPData^); Result := Imaging.SaveImageToStream(Ext, Stream, FPData^)
else
Result := False;
end; end;
@ -532,10 +597,10 @@ end;
constructor TSingleImage.Create; constructor TSingleImage.Create;
begin begin
inherited Create; inherited Create;
RecreateImageData(DefaultWidth, DefaultHeight, ifDefault); Clear;
end; end;
constructor TSingleImage.CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat); constructor TSingleImage.CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat);
begin begin
inherited Create; inherited Create;
RecreateImageData(AWidth, AHeight, AFormat); RecreateImageData(AWidth, AHeight, AFormat);
@ -544,13 +609,7 @@ end;
constructor TSingleImage.CreateFromData(const AData: TImageData); constructor TSingleImage.CreateFromData(const AData: TImageData);
begin begin
inherited Create; inherited Create;
if Imaging.TestImage(AData) then AssignFromImageData(AData);
begin
Imaging.CloneImage(AData, FImageData);
DoDataSizeChanged;
end
else
Create;
end; end;
constructor TSingleImage.CreateFromFile(const FileName: string); constructor TSingleImage.CreateFromFile(const FileName: string);
@ -580,59 +639,57 @@ procedure TSingleImage.Assign(Source: TPersistent);
begin begin
if Source = nil then if Source = nil then
begin begin
Create; Clear;
end end
else if Source is TSingleImage then else if Source is TSingleImage then
begin begin
CreateFromData(TSingleImage(Source).FImageData); AssignFromImageData(TSingleImage(Source).FImageData);
end end
else if Source is TMultiImage then else if Source is TMultiImage then
begin begin
if TMultiImage(Source).Valid then if TMultiImage(Source).Valid then
CreateFromData(TMultiImage(Source).FPData^) AssignFromImageData(TMultiImage(Source).FPData^)
else else
Assign(nil); Clear;
end end
else else
inherited Assign(Source); inherited Assign(Source);
end; 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 } { TMultiImage class implementation }
constructor TMultiImage.Create; constructor TMultiImage.Create;
begin begin
SetImageCount(DefaultImages); inherited Create;
SetActiveImage(0);
end; end;
constructor TMultiImage.CreateFromParams(AWidth, AHeight: LongInt; constructor TMultiImage.CreateFromParams(AWidth, AHeight: Integer;
AFormat: TImageFormat; Images: LongInt); AFormat: TImageFormat; ImageCount: Integer);
var var
I: LongInt; I: Integer;
begin begin
Imaging.FreeImagesInArray(FDataArray); Imaging.FreeImagesInArray(FDataArray);
SetLength(FDataArray, Images); SetLength(FDataArray, ImageCount);
for I := 0 to GetImageCount - 1 do for I := 0 to GetImageCount - 1 do
Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[I]); Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[I]);
if GetImageCount > 0 then
SetActiveImage(0); SetActiveImage(0);
end; end;
constructor TMultiImage.CreateFromArray(ADataArray: TDynImageDataArray); constructor TMultiImage.CreateFromArray(const ADataArray: TDynImageDataArray);
var
I: LongInt;
begin begin
Imaging.FreeImagesInArray(FDataArray); AssignFromArray(ADataArray);
SetLength(FDataArray, Length(ADataArray));
for I := 0 to GetImageCount - 1 do
begin
// Clone only valid images
if Imaging.TestImage(ADataArray[I]) then
Imaging.CloneImage(ADataArray[I], FDataArray[I])
else
Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
end;
SetActiveImage(0);
end; end;
constructor TMultiImage.CreateFromFile(const FileName: string); constructor TMultiImage.CreateFromFile(const FileName: string);
@ -651,20 +708,20 @@ begin
inherited Destroy; inherited Destroy;
end; end;
procedure TMultiImage.SetActiveImage(Value: LongInt); procedure TMultiImage.SetActiveImage(Value: Integer);
begin begin
FActiveImage := Value; FActiveImage := Value;
SetPointer; SetPointer;
end; end;
function TMultiImage.GetImageCount: LongInt; function TMultiImage.GetImageCount: Integer;
begin begin
Result := Length(FDataArray); Result := Length(FDataArray);
end; end;
procedure TMultiImage.SetImageCount(Value: LongInt); procedure TMultiImage.SetImageCount(Value: Integer);
var var
I, OldCount: LongInt; I, OldCount: Integer;
begin begin
if Value > GetImageCount then if Value > GetImageCount then
begin begin
@ -689,13 +746,13 @@ begin
Result := (GetImageCount > 0) and TestImagesInArray(FDataArray); Result := (GetImageCount > 0) and TestImagesInArray(FDataArray);
end; end;
function TMultiImage.GetImage(Index: LongInt): TImageData; function TMultiImage.GetImage(Index: Integer): TImageData;
begin begin
if (Index >= 0) and (Index < GetImageCount) then if (Index >= 0) and (Index < GetImageCount) then
Result := FDataArray[Index]; Result := FDataArray[Index];
end; end;
procedure TMultiImage.SetImage(Index: LongInt; Value: TImageData); procedure TMultiImage.SetImage(Index: Integer; Value: TImageData);
begin begin
if (Index >= 0) and (Index < GetImageCount) then if (Index >= 0) and (Index < GetImageCount) then
Imaging.CloneImage(Value, FDataArray[Index]); Imaging.CloneImage(Value, FDataArray[Index]);
@ -715,24 +772,27 @@ begin
end; end;
end; end;
function TMultiImage.PrepareInsert(Index, Count: LongInt): Boolean; function TMultiImage.PrepareInsert(Index, InsertCount: Integer): Boolean;
var var
I: LongInt; I: Integer;
OldImageCount, MoveCount: Integer;
begin begin
OldImageCount := GetImageCount;
// Inserting to empty image will add image at index 0 // Inserting to empty image will add image at index 0
if GetImageCount = 0 then if OldImageCount = 0 then
Index := 0; Index := 0;
if (Index >= 0) and (Index <= GetImageCount) and (Count > 0) then if (Index >= 0) and (Index <= OldImageCount) and (InsertCount > 0) then
begin begin
SetLength(FDataArray, GetImageCount + Count); SetLength(FDataArray, OldImageCount + InsertCount);
if Index < GetImageCount - 1 then if Index < OldImageCount then
begin begin
// Move imges to new position // Move images to new position
System.Move(FDataArray[Index], FDataArray[Index + Count], MoveCount := OldImageCount - Index;
(GetImageCount - Count - Index) * SizeOf(TImageData)); System.Move(FDataArray[Index], FDataArray[Index + InsertCount], MoveCount * SizeOf(TImageData));
// Null old images, not free them! // 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]); InitImage(FDataArray[I]);
end; end;
Result := True; Result := True;
@ -741,9 +801,9 @@ begin
Result := False; Result := False;
end; end;
procedure TMultiImage.DoInsertImages(Index: LongInt; const Images: TDynImageDataArray); procedure TMultiImage.DoInsertImages(Index: Integer; const Images: TDynImageDataArray);
var var
I, Len: LongInt; I, Len: Integer;
begin begin
Len := Length(Images); Len := Length(Images);
if PrepareInsert(Index, Len) then if PrepareInsert(Index, Len) then
@ -753,7 +813,7 @@ begin
end; end;
end; end;
procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: LongInt; procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: Integer;
AFormat: TImageFormat); AFormat: TImageFormat);
begin begin
if PrepareInsert(Index, 1) then if PrepareInsert(Index, 1) then
@ -766,38 +826,62 @@ var
begin begin
if Source = nil then if Source = nil then
begin begin
Create; ClearAll;
end end
else if Source is TMultiImage then else if Source is TMultiImage then
begin begin
CreateFromArray(TMultiImage(Source).FDataArray); AssignFromArray(TMultiImage(Source).FDataArray);
SetActiveImage(TMultiImage(Source).ActiveImage); SetActiveImage(TMultiImage(Source).ActiveImage);
end end
else if Source is TSingleImage then else if Source is TSingleImage then
begin begin
SetLength(Arr, 1); SetLength(Arr, 1);
Arr[0] := TSingleImage(Source).FImageData; Arr[0] := TSingleImage(Source).FImageData;
CreateFromArray(Arr); AssignFromArray(Arr);
Arr := nil;
end end
else else
inherited Assign(Source); inherited Assign(Source);
end; end;
procedure TMultiImage.AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat); procedure TMultiImage.AssignFromArray(const ADataArray: TDynImageDataArray);
var
I: Integer;
begin 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; end;
procedure TMultiImage.AddImage(const Image: TImageData); function TMultiImage.AddImage(AWidth, AHeight: Integer; AFormat: TImageFormat): Integer;
begin begin
DoInsertImages(GetImageCount, GetArrayFromImageData(Image)); Result := GetImageCount;
DoInsertNew(Result, AWidth, AHeight, AFormat);
end; 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 begin
if Assigned(Image) and Image.Valid then 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; end;
procedure TMultiImage.AddImages(const Images: TDynImageDataArray); procedure TMultiImage.AddImages(const Images: TDynImageDataArray);
@ -810,35 +894,35 @@ begin
DoInsertImages(GetImageCount, Images.FDataArray); DoInsertImages(GetImageCount, Images.FDataArray);
end; end;
procedure TMultiImage.InsertImage(Index, AWidth, AHeight: LongInt; procedure TMultiImage.InsertImage(Index, AWidth, AHeight: Integer;
AFormat: TImageFormat); AFormat: TImageFormat);
begin begin
DoInsertNew(Index, AWidth, AHeight, AFormat); DoInsertNew(Index, AWidth, AHeight, AFormat);
end; end;
procedure TMultiImage.InsertImage(Index: LongInt; const Image: TImageData); procedure TMultiImage.InsertImage(Index: Integer; const Image: TImageData);
begin begin
DoInsertImages(Index, GetArrayFromImageData(Image)); DoInsertImages(Index, GetArrayFromImageData(Image));
end; end;
procedure TMultiImage.InsertImage(Index: LongInt; Image: TBaseImage); procedure TMultiImage.InsertImage(Index: Integer; Image: TBaseImage);
begin begin
if Assigned(Image) and Image.Valid then if Assigned(Image) and Image.Valid then
DoInsertImages(Index, GetArrayFromImageData(Image.FPData^)); DoInsertImages(Index, GetArrayFromImageData(Image.FPData^));
end; end;
procedure TMultiImage.InsertImages(Index: LongInt; procedure TMultiImage.InsertImages(Index: Integer;
const Images: TDynImageDataArray); const Images: TDynImageDataArray);
begin begin
DoInsertImages(Index, FDataArray); DoInsertImages(Index, Images);
end; end;
procedure TMultiImage.InsertImages(Index: LongInt; Images: TMultiImage); procedure TMultiImage.InsertImages(Index: Integer; Images: TMultiImage);
begin begin
DoInsertImages(Index, Images.FDataArray); DoInsertImages(Index, Images.FDataArray);
end; end;
procedure TMultiImage.ExchangeImages(Index1, Index2: LongInt); procedure TMultiImage.ExchangeImages(Index1, Index2: Integer);
var var
TempData: TImageData; TempData: TImageData;
begin begin
@ -851,9 +935,9 @@ begin
end; end;
end; end;
procedure TMultiImage.DeleteImage(Index: LongInt); procedure TMultiImage.DeleteImage(Index: Integer);
var var
I: LongInt; I: Integer;
begin begin
if (Index >= 0) and (Index < GetImageCount) then if (Index >= 0) and (Index < GetImageCount) then
begin begin
@ -871,20 +955,25 @@ begin
end; end;
end; end;
procedure TMultiImage.ClearAll;
begin
ImageCount := 0;
end;
procedure TMultiImage.ConvertImages(Format: TImageFormat); procedure TMultiImage.ConvertImages(Format: TImageFormat);
var var
I: LongInt; I: Integer;
begin begin
for I := 0 to GetImageCount - 1 do for I := 0 to GetImageCount - 1 do
Imaging.ConvertImage(FDataArray[I], Format); Imaging.ConvertImage(FDataArray[I], Format);
end; end;
procedure TMultiImage.ResizeImages(NewWidth, NewHeight: LongInt; procedure TMultiImage.ResizeImages(NewWidth, NewHeight: Integer;
Filter: TResizeFilter); Filter: TResizeFilter);
var var
I: LongInt; I: Integer;
begin begin
for I := 0 to GetImageCount do for I := 0 to GetImageCount - 1 do
Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter); Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter);
end; end;
@ -922,24 +1011,33 @@ begin
SetActiveImage(0); SetActiveImage(0);
end; end;
procedure TMultiImage.SaveMultiToFile(const FileName: string); function TMultiImage.SaveMultiToFile(const FileName: string): Boolean;
begin begin
Imaging.SaveMultiImageToFile(FileName, FDataArray); Result := Imaging.SaveMultiImageToFile(FileName, FDataArray);
end; end;
procedure TMultiImage.SaveMultiToStream(const Ext: string; Stream: TStream); function TMultiImage.SaveMultiToStream(const Ext: string; Stream: TStream): Boolean;
begin begin
Imaging.SaveMultiImageToStream(Ext, Stream, FDataArray); Result := Imaging.SaveMultiImageToStream(Ext, Stream, FDataArray);
end; end;
{ {
File Notes: File Notes (obsolete):
-- TODOS ---------------------------------------------------- -- 0.77.1 ---------------------------------------------------
- nothing now - Added TSingleImage.AssignFromData and TMultiImage.AssignFromArray
- add SetPalette, create some pal wrapper first as a replacement for constructors used as methods (that is
- put all low level stuff here like ReplaceColor etc, change compiler error in Delphi XE3).
CopyTo to Copy, and add overload Copy(SrcRect, DstX, DstY) ... - 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 --------------------------------- -- 0.24.3 Changes/Bug Fixes ---------------------------------
- Added TMultiImage.ReverseImages method. - Added TMultiImage.ReverseImages method.
@ -978,7 +1076,7 @@ end;
-- 0.17 Changes/Bug Fixes ----------------------------------- -- 0.17 Changes/Bug Fixes -----------------------------------
- added props PaletteEntries and ScanLine to TBaseImage - 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 - TMultiImage levels adding and inserting rewritten internally
- added some new functions to TMultiImage: AddLevels, InsertLevels - added some new functions to TMultiImage: AddLevels, InsertLevels
- added some new functions to TBaseImage: Flip, Mirror, Rotate, - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains functions for manipulating and converting color values.} { 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.} { Converts YCoCg to RGB color.}
procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte); 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 implementation
@ -231,7 +216,7 @@ end;
- Fixed RGB>>CMYK conversions. - Fixed RGB>>CMYK conversions.
-- 0.23 Changes/Bug Fixes ----------------------------------- -- 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). (needed by PSD loading code).
-- 0.21 Changes/Bug Fixes ----------------------------------- -- 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains VCL/LCL TGraphic descendant which uses Imaging library { This unit contains VCL/LCL TGraphic descendant which uses Imaging library
@ -34,27 +17,26 @@ unit ImagingComponents;
interface interface
{$IFDEF LCL} {$IF Defined(FPC) and Defined(LCL)}
{$DEFINE COMPONENT_SET_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 not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
// If no component sets should be used just include empty unit. // If no component sets should be used just include empty unit.
//DOC-IGNORE-BEGIN
implementation implementation
//DOC-IGNORE-END
{$ELSE} {$ELSE}
uses uses
SysUtils, Types, Classes,
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
Windows, Windows,
{$ENDIF} {$ENDIF}
SysUtils, Types, Classes,
{$IFDEF COMPONENT_SET_VCL} {$IFDEF COMPONENT_SET_VCL}
Graphics, Graphics,
{$ENDIF} {$ENDIF}
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
InterfaceBase,
GraphType, GraphType,
Graphics, Graphics,
LCLType, LCLType,
@ -65,18 +47,27 @@ uses
type type
{ Graphic class which uses Imaging to load images. { Graphic class which uses Imaging to load images.
It has standard TBitmap class as ancestor and it can It has standard TBitmap class as ancestor and it can
Assign also to/from TImageData structres and TBaseImage Assign also to/from TImageData structures and TBaseImage
classes. For saving is uses inherited TBitmap methods. 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 This class is automatically registered to TPicture for all
file extensions supported by Imaging (useful only for loading). file extensions supported by Imaging (useful only for loading).
If you just want to load images in various formats you can use this 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 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.} at TImagingGraphicForSave class.}
TImagingGraphic = class(TBitmap) TImagingGraphic = class(TBitmap)
protected protected
procedure ReadDataFromStream(Stream: TStream); virtual;
procedure AssignTo(Dest: TPersistent); override; 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 public
constructor Create; override; constructor Create; override;
@ -85,6 +76,8 @@ type
even though it is called by descendant class capable of even though it is called by descendant class capable of
saving only one file format.} saving only one file format.}
procedure LoadFromStream(Stream: TStream); override; procedure LoadFromStream(Stream: TStream); override;
{ Always saves as PNG.}
procedure SaveToStream(Stream: TStream); override;
{ Copies the image contained in Source to this graphic object. { Copies the image contained in Source to this graphic object.
Supports also TBaseImage descendants from ImagingClasses unit. } Supports also TBaseImage descendants from ImagingClasses unit. }
procedure Assign(Source: TPersistent); override; procedure Assign(Source: TPersistent); override;
@ -96,21 +89,32 @@ type
procedure AssignFromImageData(const ImageData: TImageData); procedure AssignFromImageData(const ImageData: TImageData);
{ Copies the current image to TImageData structure.} { Copies the current image to TImageData structure.}
procedure AssignToImageData(var ImageData: TImageData); 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; end;
TImagingGraphicClass = class of TImagingGraphic; 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 Imaging for saving. Each descendant class can load all file formats
supported by Imaging but save only one format (TImagingBitmap supported by Imaging but save only one format (TImagingBitmap
for *.bmp, TImagingJpeg for *.jpg). Format specific classes also for *.bmp, TImagingJpeg for *.jpg). The image is saved in this one file
allow easy access to Imaging options that affect saving of files format regardless of the extension you request).
(they are properties here).}
Format specific classes also allow easy access to Imaging options that
affect saving of files (they are properties here).}
TImagingGraphicForSave = class(TImagingGraphic) TImagingGraphicForSave = class(TImagingGraphic)
protected protected
FDefaultFileExt: string; FDefaultFileExt: string;
FSavingFormat: TImageFormat; FSavingFormat: TImageFormat;
procedure WriteDataToStream(Stream: TStream); virtual; procedure WriteData(Stream: TStream); override;
public public
constructor Create; override; constructor Create; override;
{ Saves the current image to the stream. It is saved in the { Saves the current image to the stream. It is saved in the
@ -133,7 +137,7 @@ type
{$IFNDEF DONT_LINK_BITMAP} {$IFNDEF DONT_LINK_BITMAP}
{ TImagingGraphic descendant for loading/saving Windows bitmaps. { 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 want to disable this class (although you can save bitmaps with
RLE compression with this class).} RLE compression with this class).}
TImagingBitmap = class(TImagingGraphicForSave) TImagingBitmap = class(TImagingGraphicForSave)
@ -208,20 +212,20 @@ type
{$ENDIF} {$ENDIF}
{$IFNDEF DONT_LINK_DDS} {$IFNDEF DONT_LINK_DDS}
{ Compresssion type used when saving DDS files by TImagingDds.} { Compression type used when saving DDS files by TImagingDds.}
TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5); TDDSCompression = (dcNone, dcDXT1, dcDXT3, dcDXT5);
{ TImagingGraphic descendant for loading/saving DDS images.} { TImagingGraphic descendant for loading/saving DDS images.}
TImagingDDS = class(TImagingGraphicForSave) TImagingDDS = class(TImagingGraphicForSave)
protected protected
FCompression: TDDSCompresion; FCompression: TDDSCompression;
public public
constructor Create; override; constructor Create; override;
procedure SaveToStream(Stream: TStream); override; procedure SaveToStream(Stream: TStream); override;
class function GetFileFormat: TImageFileFormat; override; class function GetFileFormat: TImageFileFormat; override;
{ You can choose compression type used when saving DDS file. { You can choose compression type used when saving DDS file.
dcNone means that file will be saved in the current bitmaps pixel format.} 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; end;
{$ENDIF} {$ENDIF}
@ -299,13 +303,19 @@ procedure ConvertImageToBitmap(Image: TBaseImage; Bitmap: TBitmap);
When Image is TMultiImage only the current image level is overwritten.} When Image is TMultiImage only the current image level is overwritten.}
procedure ConvertBitmapToImage(Bitmap: TBitmap; Image: TBaseImage); 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 { Displays image stored in TImageData structure onto TCanvas. This procedure
draws image without converting from Imaging format to TBitmap. draws image without converting from Imaging format to TBitmap.
Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this
when you want displaying images that change frequently (because converting to when you want displaying images that change frequently (because converting to
TBitmap by ConvertImageDataToBitmap is generally slow). Dest and Src TBitmap by ConvertImageDataToBitmap is generally slow). Dest and Src
rectangles represent coordinates in the form (X1, Y1, X2, Y2).} 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 { Displays image onto TCanvas at position [DstX, DstY]. This procedure
draws image without converting from Imaging format to TBitmap. draws image without converting from Imaging format to TBitmap.
Only [ifA8R8G8B8, ifX8R8G8B8] image formats are supported. Use this 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); procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
{$ENDIF} {$ENDIF}
procedure RegisterTypes;
implementation implementation
uses uses
{$IF Defined(LCL)} {$IF Defined(LCL)}
InterfaceBase,
{$IF Defined(LCLGTK2)} {$IF Defined(LCLGTK2)}
GLib2, GDK2, GTK2, Gtk2Def, Gtk2Proc, GLib2, GDK2, GTK2, GTK2Def, GTK2Proc,
{$ELSEIF Defined(LCLGTK)} {$ELSEIF Defined(LCLqt5)}
GDK, GTK, GTKDef, GTKProc, Qt5, qtobjects,
{$ELSEIF Defined(LCLcocoa)}
CocoaGDIObjects, CocoaUtils,
{$IFEND} {$IFEND}
{$IFEND} {$IFEND}
{$IFNDEF DONT_LINK_BITMAP} {$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)} {$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
ImagingNetworkGraphics, ImagingNetworkGraphics,
{$IFEND} {$IFEND}
ImagingUtility; ImagingFormats, ImagingUtility;
resourcestring resourcestring
SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s'; 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'; SUnsupportedLCLWidgetSet = 'This function is not implemented for current LCL widget set';
SImagingGraphicName = 'Imaging Graphic AllInOne'; 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; procedure RegisterTypes;
var var
I: LongInt; I: LongInt;
@ -377,10 +398,16 @@ var
var var
I: LongInt; I: LongInt;
begin begin
if RegisteredFormats.IndexOf(Format) >= 0 then
Exit;
for I := 0 to Format.Extensions.Count - 1 do for I := 0 to Format.Extensions.Count - 1 do
begin
TPicture.RegisterFileFormat(Format.Extensions[I], SImagingGraphicName, TPicture.RegisterFileFormat(Format.Extensions[I], SImagingGraphicName,
TImagingGraphic); TImagingGraphic);
end; end;
RegisteredFormats.Add(Format);
end;
procedure RegisterFileFormat(AClass: TImagingGraphicForSaveClass); procedure RegisterFileFormat(AClass: TImagingGraphicForSaveClass);
var var
@ -396,6 +423,9 @@ begin
RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I)); RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I));
Classes.RegisterClass(TImagingGraphic); Classes.RegisterClass(TImagingGraphic);
if RegisteredGraphicsClasses then
Exit;
{$IFNDEF DONT_LINK_TARGA} {$IFNDEF DONT_LINK_TARGA}
RegisterFileFormat(TImagingTarga); RegisterFileFormat(TImagingTarga);
Classes.RegisterClass(TImagingTarga); Classes.RegisterClass(TImagingTarga);
@ -418,7 +448,7 @@ begin
{$ENDIF} {$ENDIF}
{$IFNDEF DONT_LINK_PNG} {$IFNDEF DONT_LINK_PNG}
{$IFDEF COMPONENT_SET_LCL} {$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); TPicture.UnregisterGraphicClass(TPortableNetworkGraphic);
{$ENDIF} {$ENDIF}
RegisterFileFormat(TImagingPNG); RegisterFileFormat(TImagingPNG);
@ -432,6 +462,8 @@ begin
RegisterFileFormat(TImagingBitmap); RegisterFileFormat(TImagingBitmap);
Classes.RegisterClass(TImagingBitmap); Classes.RegisterClass(TImagingBitmap);
{$ENDIF} {$ENDIF}
RegisteredGraphicsClasses := True;
end; end;
{ Unregisters types from VCL/LCL.} { Unregisters types from VCL/LCL.}
@ -495,11 +527,11 @@ end;
procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap); procedure ConvertDataToBitmap(const Data: TImageData; Bitmap: TBitmap);
var var
I, LineBytes: LongInt;
PF: TPixelFormat; PF: TPixelFormat;
Info: TImageFormatInfo; Info: TImageFormatInfo;
WorkData: TImageData; WorkData: TImageData;
{$IFDEF COMPONENT_SET_VCL} {$IFDEF COMPONENT_SET_VCL}
I, LineBytes: LongInt;
LogPalette: TMaxLogPalette; LogPalette: TMaxLogPalette;
{$ENDIF} {$ENDIF}
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
@ -509,6 +541,14 @@ var
begin begin
PF := DataFormatToPixelFormat(Data.Format); PF := DataFormatToPixelFormat(Data.Format);
GetImageFormatInfo(Data.Format, Info); 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 if PF = pfCustom then
begin begin
// Convert from formats not supported by Graphics unit // Convert from formats not supported by Graphics unit
@ -517,6 +557,7 @@ begin
if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then
Imaging.ConvertImage(WorkData, ifA8R8G8B8) Imaging.ConvertImage(WorkData, ifA8R8G8B8)
else else
begin
{$IFDEF COMPONENT_SET_VCL} {$IFDEF COMPONENT_SET_VCL}
if Info.IsIndexed or Info.HasGrayChannel then if Info.IsIndexed or Info.HasGrayChannel then
Imaging.ConvertImage(WorkData, ifIndex8) Imaging.ConvertImage(WorkData, ifIndex8)
@ -527,6 +568,7 @@ begin
{$ELSE} {$ELSE}
Imaging.ConvertImage(WorkData, ifA8R8G8B8); Imaging.ConvertImage(WorkData, ifA8R8G8B8);
{$ENDIF} {$ENDIF}
end;
PF := DataFormatToPixelFormat(WorkData.Format); PF := DataFormatToPixelFormat(WorkData.Format);
GetImageFormatInfo(WorkData.Format, Info); GetImageFormatInfo(WorkData.Format, Info);
@ -537,8 +579,6 @@ begin
if PF = pfCustom then if PF = pfCustom then
RaiseImaging(SBadFormatDataToBitmap, [ImageToStr(WorkData)]); RaiseImaging(SBadFormatDataToBitmap, [ImageToStr(WorkData)]);
LineBytes := WorkData.Width * Info.BytesPerPixel;
{$IFDEF COMPONENT_SET_VCL} {$IFDEF COMPONENT_SET_VCL}
Bitmap.Width := WorkData.Width; Bitmap.Width := WorkData.Width;
Bitmap.Height := WorkData.Height; Bitmap.Height := WorkData.Height;
@ -559,17 +599,19 @@ begin
end; end;
Bitmap.Palette := CreatePalette(PLogPalette(@LogPalette)^); Bitmap.Palette := CreatePalette(PLogPalette(@LogPalette)^);
end; end;
// Copy scanlines // Copy scanlines
LineBytes := WorkData.Width * Info.BytesPerPixel;
for I := 0 to WorkData.Height - 1 do for I := 0 to WorkData.Height - 1 do
Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes); 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 Defined(DELPHI) and (CompilerVersion >= 20.0)}
if Bitmap.PixelFormat = pf32bit then if Bitmap.PixelFormat = pf32bit then
Bitmap.AlphaFormat := afDefined; Bitmap.AlphaFormat := afDefined;
{$IFEND} {$IFEND}
{$ENDIF} {$ENDIF}
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
// Create 32bit raw image from image data // Create 32bit raw image from image data
FillChar(RawImage, SizeOf(RawImage), 0); FillChar(RawImage, SizeOf(RawImage), 0);
@ -621,13 +663,14 @@ var
LineLazBytes: LongInt; LineLazBytes: LongInt;
{$ENDIF} {$ENDIF}
begin begin
Format := ifUnknown;
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
// In the current Lazarus 0.9.10 Bitmap.PixelFormat property is useless. // 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 // 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 // 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 // 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 // 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 if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then
case RawImage.Description.BitsPerPixel of case RawImage.Description.BitsPerPixel of
@ -641,8 +684,6 @@ begin
32: Format := ifA8R8G8B8; 32: Format := ifA8R8G8B8;
48: Format := ifR16G16B16; 48: Format := ifR16G16B16;
64: Format := ifA16R16G16B16; 64: Format := ifA16R16G16B16;
else
Format := ifUnknown;
end; end;
{$ELSE} {$ELSE}
Format := PixelFormatToDataFormat(Bitmap.PixelFormat); Format := PixelFormatToDataFormat(Bitmap.PixelFormat);
@ -693,9 +734,14 @@ begin
RawImage.Description.LineEnd); RawImage.Description.LineEnd);
// Copy scanlines // Copy scanlines
for I := 0 to Data.Height - 1 do for I := 0 to Data.Height - 1 do
begin
Move(PByteArray(RawImage.Data)[I * LineLazBytes], Move(PByteArray(RawImage.Data)[I * LineLazBytes],
PByteArray(Data.Bits)[I * LineBytes], LineBytes); 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; RawImage.FreeData;
end; end;
{$ENDIF} {$ENDIF}
@ -745,7 +791,7 @@ begin
DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left,
Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY) <> Height then Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY) <> Height then
begin 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. // This fallback is slow but works every time. Thanks to Sergey Galezdinov for the fix.
Bmp := TBitmap.Create; Bmp := TBitmap.Create;
try try
@ -763,13 +809,17 @@ begin
end; end;
{$ENDIF} {$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); procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
{$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32 {$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32
begin begin
DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect); DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect);
end; end;
{$ELSEIF Defined(LCLGTK) or Defined(LCLGTK2)} {$ELSEIF Defined(LCLGTK2)}
procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
SrcWidth, SrcHeight: Integer; ImageData: TImageData); SrcWidth, SrcHeight: Integer; ImageData: TImageData);
var var
@ -778,9 +828,19 @@ end;
P := TGtkDeviceContext(Dest).Offset; P := TGtkDeviceContext(Dest).Offset;
Inc(DstX, P.X); Inc(DstX, P.X);
Inc(DstY, P.Y); 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, gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC,
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE, 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; end;
var var
@ -790,9 +850,10 @@ var
begin begin
if TestImage(ImageData) then if TestImage(ImageData) then
begin begin
Assert(ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8], SBadFormatDisplay); if not (ImageData.Format in [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8]) then
InitImage(DisplayImage); raise EImagingError.Create(SBadFormatDisplay);
InitImage(DisplayImage);
SrcBounds := RectToBounds(SrcRect); SrcBounds := RectToBounds(SrcRect);
DstBounds := RectToBounds(DstRect); DstBounds := RectToBounds(DstRect);
WidgetSet.GetClipBox(DstCanvas.Handle, @DstClip); WidgetSet.GetClipBox(DstCanvas.Handle, @DstClip);
@ -809,7 +870,7 @@ begin
if (SrcBounds.Right = NewWidth) and (SrcBounds.Bottom = NewHeight) then if (SrcBounds.Right = NewWidth) and (SrcBounds.Bottom = NewHeight) then
try try
CloneImage(ImageData, DisplayImage); CloneImage(ImageData, DisplayImage);
// Swap R-B channels for GTK display compatability! // Swap R-B channels for GTK display compatibility!
SwapChannels(DisplayImage, ChannelRed, ChannelBlue); SwapChannels(DisplayImage, ChannelRed, ChannelBlue);
GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top,
SrcBounds.Left, SrcBounds.Top, NewWidth, NewHeight, DisplayImage); SrcBounds.Left, SrcBounds.Top, NewWidth, NewHeight, DisplayImage);
@ -823,7 +884,7 @@ begin
// Stretch pixels from old image to new one TResizeFilter = (rfNearest, rfBilinear, rfBicubic); // Stretch pixels from old image to new one TResizeFilter = (rfNearest, rfBilinear, rfBicubic);
StretchRect(ImageData, SrcBounds.Left, SrcBounds.Top, SrcBounds.Right, StretchRect(ImageData, SrcBounds.Left, SrcBounds.Top, SrcBounds.Right,
SrcBounds.Bottom, DisplayImage, 0, 0, NewWidth, NewHeight, rfNearest); 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); SwapChannels(DisplayImage, ChannelRed, ChannelBlue);
GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, 0, 0, GDKDrawBitmap(DstCanvas.Handle, DstBounds.Left, DstBounds.Top, 0, 0,
NewWidth, NewHeight, DisplayImage); NewWidth, NewHeight, DisplayImage);
@ -833,9 +894,53 @@ begin
end; end;
end; end;
end; end;
{$ELSEIF Defined(LCLqt5)}
var
QImage: TQtImage;
Context: TQtDeviceContext;
begin
if TestImage(ImageData) then
begin
if not (ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8]) then
raise EImagingError.Create(SBadFormatDisplay);
Context := TQtDeviceContext(DstCanvas.Handle);
// QImage directly uses the image memory, there is no copy done
QImage := TQtImage.Create(ImageData.Bits, ImageData.Width, ImageData.Height,
ImageData.Width * 4, QImageFormat_ARGB32, False);
try
QPainter_drawImage(Context.Widget, PRect(@DstRect), QImage.Handle, @SrcRect, QtAutoColor);
finally
QImage.Free;
end;
end;
end;
{$ELSEIF Defined(LCLcocoa)}
var
CocoaBmp: TCocoaBitmap;
Context: TCocoaContext;
begin
if TestImage(ImageData) then
begin
if not (ImageData.Format in [ifA8R8G8B8, ifX8R8G8B8]) then
raise EImagingError.Create(SBadFormatDisplay);
Context := CheckDC(DstCanvas.Handle);
// We copy the data since it needs R/B swap and potentially alpha pre-multiply
CocoaBmp := TCocoaBitmap.Create(ImageData.Width, ImageData.Height, 32, 32,
cbaDWord, cbtBGRA, ImageData.Bits, True);
try
Context.DrawImageRep(RectToNSRect(DstRect), RectToNSRect(SrcRect), CocoaBmp.ImageRep);
finally
CocoaBmp.Free;
end;
end;
end;
{$ELSE} {$ELSE}
begin begin
raise Exception.Create(SUnsupportedLCLWidgetSet); raise EImagingError.Create(SUnsupportedLCLWidgetSet);
end; end;
{$IFEND} {$IFEND}
@ -864,12 +969,27 @@ begin
PixelFormat := pf24Bit; PixelFormat := pf24Bit;
end; end;
procedure TImagingGraphic.LoadFromStream(Stream: TStream); procedure TImagingGraphic.ReadData(Stream: TStream);
begin 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; 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 var
Image: TSingleImage; Image: TSingleImage;
begin begin
@ -882,6 +1002,19 @@ begin
end; end;
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); procedure TImagingGraphic.AssignTo(Dest: TPersistent);
var var
Arr: TDynImageDataArray; Arr: TDynImageDataArray;
@ -901,6 +1034,18 @@ begin
inherited AssignTo(Dest); inherited AssignTo(Dest);
end; 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); procedure TImagingGraphic.Assign(Source: TPersistent);
begin begin
if Source is TBaseImage then if Source is TBaseImage then
@ -933,7 +1078,6 @@ begin
ConvertBitmapToData(Self, ImageData); ConvertBitmapToData(Self, ImageData);
end; end;
{ TImagingGraphicForSave class implementation } { TImagingGraphicForSave class implementation }
constructor TImagingGraphicForSave.Create; constructor TImagingGraphicForSave.Create;
@ -944,7 +1088,12 @@ begin
GetFileFormat.CheckOptionsValidity; GetFileFormat.CheckOptionsValidity;
end; end;
procedure TImagingGraphicForSave.WriteDataToStream(Stream: TStream); procedure TImagingGraphicForSave.WriteData(Stream: TStream);
begin
SaveToStream(Stream);
end;
procedure TImagingGraphicForSave.SaveToStream(Stream: TStream);
var var
Image: TSingleImage; Image: TSingleImage;
begin begin
@ -962,11 +1111,6 @@ begin
end; end;
end; end;
procedure TImagingGraphicForSave.SaveToStream(Stream: TStream);
begin
WriteDataToStream(Stream);
end;
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
class function TImagingGraphicForSave.GetFileExtensions: string; class function TImagingGraphicForSave.GetFileExtensions: string;
begin begin
@ -980,9 +1124,6 @@ end;
{$ENDIF} {$ENDIF}
{$IFNDEF DONT_LINK_BITMAP} {$IFNDEF DONT_LINK_BITMAP}
{ TImagingBitmap class implementation }
constructor TImagingBitmap.Create; constructor TImagingBitmap.Create;
begin begin
inherited Create; inherited Create;
@ -1004,9 +1145,6 @@ end;
{$ENDIF} {$ENDIF}
{$IFNDEF DONT_LINK_JPEG} {$IFNDEF DONT_LINK_JPEG}
{ TImagingJpeg class implementation }
constructor TImagingJpeg.Create; constructor TImagingJpeg.Create;
begin begin
inherited Create; inherited Create;
@ -1038,9 +1176,6 @@ end;
{$ENDIF} {$ENDIF}
{$IFNDEF DONT_LINK_PNG} {$IFNDEF DONT_LINK_PNG}
{ TImagingPNG class implementation }
constructor TImagingPNG.Create; constructor TImagingPNG.Create;
begin begin
inherited Create; inherited Create;
@ -1064,20 +1199,13 @@ end;
{$ENDIF} {$ENDIF}
{$IFNDEF DONT_LINK_GIF} {$IFNDEF DONT_LINK_GIF}
{ TImagingGIF class implementation}
class function TImagingGIF.GetFileFormat: TImageFileFormat; class function TImagingGIF.GetFileFormat: TImageFileFormat;
begin begin
Result := FindImageFileFormatByClass(TGIFFileFormat); Result := FindImageFileFormatByClass(TGIFFileFormat);
end; end;
{$ENDIF} {$ENDIF}
{$IFNDEF DONT_LINK_TARGA} {$IFNDEF DONT_LINK_TARGA}
{ TImagingTarga class implementation }
constructor TImagingTarga.Create; constructor TImagingTarga.Create;
begin begin
inherited Create; inherited Create;
@ -1099,9 +1227,6 @@ end;
{$ENDIF} {$ENDIF}
{$IFNDEF DONT_LINK_DDS} {$IFNDEF DONT_LINK_DDS}
{ TImagingDDS class implementation }
constructor TImagingDDS.Create; constructor TImagingDDS.Create;
begin begin
inherited Create; inherited Create;
@ -1132,9 +1257,6 @@ end;
{$ENDIF} {$ENDIF}
{$IFNDEF DONT_LINK_MNG} {$IFNDEF DONT_LINK_MNG}
{ TImagingMNG class implementation }
constructor TImagingMNG.Create; constructor TImagingMNG.Create;
begin begin
inherited Create; inherited Create;
@ -1173,9 +1295,6 @@ end;
{$ENDIF} {$ENDIF}
{$IFNDEF DONT_LINK_JNG} {$IFNDEF DONT_LINK_JNG}
{ TImagingJNG class implementation }
constructor TImagingJNG.Create; constructor TImagingJNG.Create;
begin begin
inherited Create; inherited Create;
@ -1205,17 +1324,26 @@ end;
{$ENDIF} {$ENDIF}
initialization initialization
RegisteredFormats := TList.Create;
RegisterTypes; RegisterTypes;
finalization finalization
UnRegisterTypes; UnRegisterTypes;
RegisteredFormats.Free;
{$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)} {$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
{ {
File Notes: File Notes:
-- TODOS ---------------------------------------------------- -- 0.77.1 ---------------------------------------------------
- nothing now - 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 --------------------------------- -- 0.26.3 Changes/Bug Fixes ---------------------------------
- Setting AlphaFormat property of TBitmap in ConvertDataToBitmap - Setting AlphaFormat property of TBitmap in ConvertDataToBitmap
@ -1236,7 +1364,7 @@ finalization
-- 0.24.1 Changes/Bug Fixes --------------------------------- -- 0.24.1 Changes/Bug Fixes ---------------------------------
- Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus - Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus
with GTK2 target. 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 RawImage interface. Replace current code with that in comments
if you use Lazarus from SVN. New RawImage interface will be used by if you use Lazarus from SVN. New RawImage interface will be used by
default after next Lazarus release. default after next Lazarus release.
@ -1258,7 +1386,7 @@ finalization
- added procedures: ConvertImageToBitmap and ConvertBitmapToImage - added procedures: ConvertImageToBitmap and ConvertBitmapToImage
-- 0.17 Changes/Bug Fixes ----------------------------------- -- 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 MNG file format
- added JNG 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains image format loader/saver for DirectDraw Surface images.} { This unit contains image format loader/saver for DirectDraw Surface images.}
@ -38,11 +21,11 @@ uses
type type
{ Class for loading and saving Microsoft DirectDraw surfaces. { 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 TImageFormat. It supports plain textures, cube textures and
volume textures, all of these can have mipmaps. It can also volume textures, all of these can have mipmaps. It can also
load some formats which have no exact TImageFormat, but can be easily 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 You can get some information about last loaded DDS file by calling
GetOption with ImagingDDSLoadedXXX options and you can set some GetOption with ImagingDDSLoadedXXX options and you can set some
saving options by calling SetOption with ImagingDDSSaveXXX or you can 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 at least number of images to build cube/volume based on current
Depth and MipMapCount settings.} Depth and MipMapCount settings.}
TDDSFileFormat = class(TImageFileFormat) TDDSFileFormat = class(TImageFileFormat)
protected private
FLoadedCubeMap: LongBool; FLoadedCubeMap: LongBool;
FLoadedVolume: LongBool; FLoadedVolume: LongBool;
FLoadedMipMapCount: LongInt; FLoadedMipMapCount: LongInt;
@ -62,6 +45,8 @@ type
FSaveDepth: LongInt; FSaveDepth: LongInt;
procedure ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt; procedure ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt;
IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt); IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt);
protected
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override; OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
@ -69,7 +54,6 @@ type
procedure ConvertToSupported(var Image: TImageData; procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override; const Info: TImageFormatInfo); override;
public public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override; function TestFormat(Handle: TImagingHandle): Boolean; override;
procedure CheckOptionsValidity; override; procedure CheckOptionsValidity; override;
published published
@ -94,6 +78,17 @@ type
property SaveDepth: LongInt read FSaveDepth write FSaveDepth; property SaveDepth: LongInt read FSaveDepth write FSaveDepth;
end; 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 implementation
const const
@ -106,18 +101,20 @@ const
const const
{ Four character codes.} { 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)); (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)); (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)); (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)); (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)); (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)); (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.} { Some D3DFORMAT values used in DDS files as FourCC value.}
D3DFMT_A16B16G16R16 = 36; D3DFMT_A16B16G16R16 = 36;
@ -126,7 +123,7 @@ const
D3DFMT_R16F = 111; D3DFMT_R16F = 111;
D3DFMT_A16B16G16R16F = 113; D3DFMT_A16B16G16R16F = 113;
{ Constans used by TDDSurfaceDesc2.Flags.} { Constants used by TDDSurfaceDesc2.Flags.}
DDSD_CAPS = $00000001; DDSD_CAPS = $00000001;
DDSD_HEIGHT = $00000002; DDSD_HEIGHT = $00000002;
DDSD_WIDTH = $00000004; DDSD_WIDTH = $00000004;
@ -136,7 +133,7 @@ const
DDSD_LINEARSIZE = $00080000; DDSD_LINEARSIZE = $00080000;
DDSD_DEPTH = $00800000; DDSD_DEPTH = $00800000;
{ Constans used by TDDSPixelFormat.Flags.} { Constants used by TDDSPixelFormat.Flags.}
DDPF_ALPHAPIXELS = $00000001; // used by formats which contain alpha DDPF_ALPHAPIXELS = $00000001; // used by formats which contain alpha
DDPF_FOURCC = $00000004; // used by DXT and large ARGB formats DDPF_FOURCC = $00000004; // used by DXT and large ARGB formats
DDPF_RGB = $00000040; // used by RGB formats DDPF_RGB = $00000040; // used by RGB formats
@ -144,12 +141,12 @@ const
DDPF_BUMPLUMINANCE = $00040000; // used by mixed signed-unsigned formats DDPF_BUMPLUMINANCE = $00040000; // used by mixed signed-unsigned formats
DDPF_BUMPDUDV = $00080000; // used by signed formats DDPF_BUMPDUDV = $00080000; // used by signed formats
{ Constans used by TDDSCaps.Caps1.} { Constants used by TDDSCaps.Caps1.}
DDSCAPS_COMPLEX = $00000008; DDSCAPS_COMPLEX = $00000008;
DDSCAPS_TEXTURE = $00001000; DDSCAPS_TEXTURE = $00001000;
DDSCAPS_MIPMAP = $00400000; DDSCAPS_MIPMAP = $00400000;
{ Constans used by TDDSCaps.Caps2.} { Constants used by TDDSCaps.Caps2.}
DDSCAPS2_CUBEMAP = $00000200; DDSCAPS2_CUBEMAP = $00000200;
DDSCAPS2_POSITIVEX = $00000400; DDSCAPS2_POSITIVEX = $00000400;
DDSCAPS2_NEGATIVEX = $00000800; DDSCAPS2_NEGATIVEX = $00000800;
@ -166,56 +163,191 @@ const
type type
{ Stores the pixel format information.} { Stores the pixel format information.}
TDDPixelFormat = packed record TDDPixelFormat = packed record
Size: LongWord; // Size of the structure = 32 bytes Size: UInt32; // Size of the structure = 32 bytes
Flags: LongWord; // Flags to indicate valid fields Flags: UInt32; // Flags to indicate valid fields
FourCC: LongWord; // Four-char code for compressed textures (DXT) FourCC: UInt32; // Four-char code for compressed textures (DXT)
BitCount: LongWord; // Bits per pixel if uncomp. usually 16,24 or 32 BitCount: UInt32; // Bits per pixel if uncomp. usually 16,24 or 32
RedMask: LongWord; // Bit mask for the Red component RedMask: UInt32; // Bit mask for the Red component
GreenMask: LongWord; // Bit mask for the Green component GreenMask: UInt32; // Bit mask for the Green component
BlueMask: LongWord; // Bit mask for the Blue component BlueMask: UInt32; // Bit mask for the Blue component
AlphaMask: LongWord; // Bit mask for the Alpha component AlphaMask: UInt32; // Bit mask for the Alpha component
end; end;
{ Specifies capabilities of surface.} { Specifies capabilities of surface.}
TDDSCaps = packed record TDDSCaps = packed record
Caps1: LongWord; // Should always include DDSCAPS_TEXTURE Caps1: UInt32; // Should always include DDSCAPS_TEXTURE
Caps2: LongWord; // For cubic environment maps Caps2: UInt32; // For cubic environment maps
Reserved: array[0..1] of LongWord; // Reserved Reserved: array[0..1] of UInt32; // Reserved
end; end;
{ Record describing DDS file contents.} { Record describing DDS file contents.}
TDDSurfaceDesc2 = packed record TDDSurfaceDesc2 = packed record
Size: LongWord; // Size of the structure = 124 Bytes Size: UInt32; // Size of the structure = 124 Bytes
Flags: LongWord; // Flags to indicate valid fields Flags: UInt32; // Flags to indicate valid fields
Height: LongWord; // Height of the main image in pixels Height: UInt32; // Height of the main image in pixels
Width: LongWord; // Width of the main image in pixels Width: UInt32; // Width of the main image in pixels
PitchOrLinearSize: LongWord; // For uncomp formats number of bytes per PitchOrLinearSize: UInt32; // For uncomp formats number of bytes per
// scanline. For comp it is the size in // scanline. For comp it is the size in
// bytes of the main image // bytes of the main image
Depth: LongWord; // Only for volume text depth of the volume Depth: UInt32; // Only for volume text depth of the volume
MipMaps: LongInt; // Total number of levels in the mipmap chain MipMaps: Int32; // Total number of levels in the mipmap chain
Reserved1: array[0..10] of LongWord; // Reserved Reserved1: array[0..10] of UInt32; // Reserved
PixelFormat: TDDPixelFormat; // Format of the pixel data PixelFormat: TDDPixelFormat; // Format of the pixel data
Caps: TDDSCaps; // Capabilities Caps: TDDSCaps; // Capabilities
Reserved2: LongWord; // Reserved Reserved2: UInt32; // Reserved
end; end;
{ DDS file header.} { DDS file header.}
TDDSFileHeader = packed record TDDSFileHeader = packed record
Magic: LongWord; // File format magic Magic: UInt32; // File format magic
Desc: TDDSurfaceDesc2; // Surface description Desc: TDDSurfaceDesc2; // Surface description
end; 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 } { TDDSFileFormat class implementation }
constructor TDDSFileFormat.Create; procedure TDDSFileFormat.Define;
begin begin
inherited Create; inherited;
FName := SDDSFormatName; FName := SDDSFormatName;
FCanLoad := True; FFeatures := [ffLoad, ffSave, ffMultiImage];
FCanSave := True;
FIsMultiImageFormat := True;
FSupportedFormats := DDSSupportedFormats; FSupportedFormats := DDSSupportedFormats;
FSaveCubeMap := False; FSaveCubeMap := False;
@ -261,7 +393,7 @@ begin
if IsCubeMap then if IsCubeMap then
begin begin
// Cube maps are stored like this // Cube maps are stored like this
// Face 0 mimap 0 // Face 0 mipmap 0
// Face 0 mipmap 1 // Face 0 mipmap 1
// ... // ...
// Face 1 mipmap 0 // Face 1 mipmap 0
@ -307,10 +439,12 @@ function TDDSFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var var
Hdr: TDDSFileHeader; Hdr: TDDSFileHeader;
HdrDX10: TDX10Header;
SrcFormat: TImageFormat; SrcFormat: TImageFormat;
FmtInfo: TImageFormatInfo; FmtInfo: TImageFormatInfo;
NeedsSwapChannels: Boolean; NeedsSwapChannels: Boolean;
CurrentWidth, CurrentHeight, ImageCount, LoadSize, I, PitchOrLinear: LongInt; CurrentWidth, CurrentHeight, ImageCount, LoadSize, I,
PitchOrLinear, MainImageLinearSize: LongInt;
Data: PByte; Data: PByte;
UseAsPitch: Boolean; UseAsPitch: Boolean;
UseAsLinear: Boolean; UseAsLinear: Boolean;
@ -322,6 +456,128 @@ var
(DDPF.BlueMask = PF.BBitMask); (DDPF.BlueMask = PF.BBitMask);
end; 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 begin
Result := False; Result := False;
ImageCount := 1; ImageCount := 1;
@ -329,34 +585,27 @@ begin
FLoadedDepth := 1; FLoadedDepth := 1;
FLoadedVolume := False; FLoadedVolume := False;
FLoadedCubeMap := False; FLoadedCubeMap := False;
ZeroMemory(@HdrDX10, SizeOf(HdrDX10));
with GetIO, Hdr, Hdr.Desc.PixelFormat do with GetIO, Hdr, Hdr.Desc.PixelFormat do
begin begin
Read(Handle, @Hdr, SizeOF(Hdr)); Read(Handle, @Hdr, SizeOf(Hdr));
{
// Set position to the end of the header (for possible future versions
// ith larger header)
Seek(Handle, Hdr.Desc.Size + SizeOf(Hdr.Magic) - SizeOf(Hdr),
smFromCurrent);
}
SrcFormat := ifUnknown; SrcFormat := ifUnknown;
NeedsSwapChannels := False; NeedsSwapChannels := False;
// Get image data format // Get image data format
if (Flags and DDPF_FOURCC) = DDPF_FOURCC then if (Flags and DDPF_FOURCC) = DDPF_FOURCC then
begin begin
// Handle FourCC and large ARGB formats if FourCC = FOURCC_DX10 then
case FourCC of begin
D3DFMT_A16B16G16R16: SrcFormat := ifA16B16G16R16; Read(Handle, @HdrDX10, SizeOf(HdrDX10));
D3DFMT_R32F: SrcFormat := ifR32F; SrcFormat := FindDX10Format(HdrDX10.DXGIFormat, NeedsSwapChannels);
D3DFMT_A32B32G32R32F: SrcFormat := ifA32B32G32R32F; FMetadata.SetMetaItem(SMetaDdsDxgiFormat, HdrDX10.DXGIFormat);
D3DFMT_R16F: SrcFormat := ifR16F; FMetadata.SetMetaItem(SMetaDdsArraySize, HdrDX10.ArraySize);
D3DFMT_A16B16G16R16F: SrcFormat := ifA16B16G16R16F; end
FOURCC_DXT1: SrcFormat := ifDXT1; else
FOURCC_DXT3: SrcFormat := ifDXT3; SrcFormat := FindFourCCFormat(FourCC);
FOURCC_DXT5: SrcFormat := ifDXT5;
FOURCC_ATI1: SrcFormat := ifATI1N;
FOURCC_ATI2: SrcFormat := ifATI2N;
end;
end end
else if (Flags and DDPF_RGB) = DDPF_RGB then else if (Flags and DDPF_RGB) = DDPF_RGB then
begin begin
@ -367,11 +616,9 @@ begin
case BitCount of case BitCount of
16: 16:
begin begin
if MasksEqual(Desc.PixelFormat, if MasksEqual(Desc.PixelFormat, GetFormatInfo(ifA4R4G4B4).PixelFormat) then
GetFormatInfo(ifA4R4G4B4).PixelFormat) then
SrcFormat := ifA4R4G4B4; SrcFormat := ifA4R4G4B4;
if MasksEqual(Desc.PixelFormat, if MasksEqual(Desc.PixelFormat, GetFormatInfo(ifA1R5G5B5).PixelFormat) then
GetFormatInfo(ifA1R5G5B5).PixelFormat) then
SrcFormat := ifA1R5G5B5; SrcFormat := ifA1R5G5B5;
end; end;
32: 32:
@ -458,7 +705,8 @@ begin
end; end;
// If DDS format is not supported we will exit // 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. // File contains mipmaps for each subimage.
{ Some DDS writers ignore setting proper Caps and Flags so { Some DDS writers ignore setting proper Caps and Flags so
@ -468,6 +716,7 @@ begin
if Desc.MipMaps > 1 then if Desc.MipMaps > 1 then
begin begin
FLoadedMipMapCount := Desc.MipMaps; FLoadedMipMapCount := Desc.MipMaps;
FMetadata.SetMetaItem(SMetaDdsMipMapCount, Desc.MipMaps);
ImageCount := Desc.MipMaps; ImageCount := Desc.MipMaps;
end; end;
@ -508,12 +757,21 @@ begin
// Main image pitch or linear size // Main image pitch or linear size
PitchOrLinear := Desc.PitchOrLinearSize; 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 for I := 0 to ImageCount - 1 do
begin begin
// Compute dimensions of surrent subimage based on texture type and // Compute dimensions of surrent subimage based on texture type and
// number of mipmaps // number of mipmaps
ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth, ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth,
FloadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight); FLoadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight);
NewImage(CurrentWidth, CurrentHeight, SrcFormat, Images[I]); NewImage(CurrentWidth, CurrentHeight, SrcFormat, Images[I]);
if (I > 0) or (PitchOrLinear = 0) then if (I > 0) or (PitchOrLinear = 0) then
@ -563,7 +821,7 @@ var
Hdr: TDDSFileHeader; Hdr: TDDSFileHeader;
MainImage, ImageToSave: TImageData; MainImage, ImageToSave: TImageData;
I, MainIdx, Len, ImageCount: LongInt; I, MainIdx, Len, ImageCount: LongInt;
J: LongWord; J: UInt32;
FmtInfo: TImageFormatInfo; FmtInfo: TImageFormatInfo;
MustBeFreed: Boolean; MustBeFreed: Boolean;
Is2DTexture, IsCubeMap, IsVolume: Boolean; Is2DTexture, IsCubeMap, IsVolume: Boolean;
@ -823,6 +1081,13 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 --------------------------------- -- 0.25.0 Changes/Bug Fixes ---------------------------------
- Added support for 3Dc ATI1/2 formats. - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains image format loader/saver for GIF images.} { This unit contains image format loader/saver for GIF images.}
@ -55,6 +38,7 @@ type
procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer); Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
protected protected
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override; OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
@ -62,7 +46,6 @@ type
procedure ConvertToSupported(var Image: TImageData; procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override; const Info: TImageFormatInfo); override;
public public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override; function TestFormat(Handle: TImagingHandle): Boolean; override;
published published
property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated; property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
@ -84,6 +67,7 @@ type
const const
GIFSignature: TChar3 = 'GIF'; GIFSignature: TChar3 = 'GIF';
GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a'); GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a');
GIFDefaultDelay = 65;
// Masks for accessing fields in PackedFields of TGIFHeader // Masks for accessing fields in PackedFields of TGIFHeader
GIFGlobalColorTable = $80; GIFGlobalColorTable = $80;
@ -111,6 +95,11 @@ const
GIFUserInput = $02; GIFUserInput = $02;
GIFDisposalMethod = $1C; GIFDisposalMethod = $1C;
const
// Netscape sub block types
GIFAppLoopExtension = 1;
GIFAppBufferExtension = 2;
type type
TGIFHeader = packed record TGIFHeader = packed record
// File header part // File header part
@ -149,11 +138,6 @@ type
Terminator: Byte; Terminator: Byte;
end; end;
const
// Netscape sub block types
GIFAppLoopExtension = 1;
GIFAppBufferExtension = 2;
type type
TGIFIdentifierCode = array[0..7] of AnsiChar; TGIFIdentifierCode = array[0..7] of AnsiChar;
TGIFAuthenticationCode = array[0..2] of AnsiChar; TGIFAuthenticationCode = array[0..2] of AnsiChar;
@ -216,13 +200,11 @@ resourcestring
TGIFFileFormat implementation TGIFFileFormat implementation
} }
constructor TGIFFileFormat.Create; procedure TGIFFileFormat.Define;
begin begin
inherited Create; inherited;
FName := SGIFFormatName; FName := SGIFFormatName;
FCanLoad := True; FFeatures := [ffLoad, ffSave, ffMultiImage];
FCanSave := True;
FIsMultiImageFormat := True;
FSupportedFormats := GIFSupportedFormats; FSupportedFormats := GIFSupportedFormats;
FLoadAnimated := GIFDefaultLoadAnimated; FLoadAnimated := GIFDefaultLoadAnimated;
@ -265,7 +247,7 @@ begin
end; end;
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; procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer;
Interlaced: Boolean; Data: Pointer); Interlaced: Boolean; Data: Pointer);
var var
@ -304,7 +286,7 @@ var
RawCode := Context.Buf[Word(ByteIndex)] + RawCode := Context.Buf[Word(ByteIndex)] +
(Word(Context.Buf[Word(ByteIndex + 1)]) shl 8); (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
if Context.CodeSize > 8 then 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); RawCode := RawCode shr (Context.Inx and 7);
Context.Inx := Context.Inx + Byte(Context.CodeSize); Context.Inx := Context.Inx + Byte(Context.CodeSize);
Result := RawCode and Context.ReadMask; Result := RawCode and Context.ReadMask;
@ -374,7 +356,7 @@ begin
ReadCtxt.Size := 0; ReadCtxt.Size := 0;
ReadCtxt.CodeSize := MinCodeSize + 1; ReadCtxt.CodeSize := MinCodeSize + 1;
ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1; ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
// Initialise pixel-output context // Initialize pixel-output context
OutCtxt.X := 0; OutCtxt.X := 0;
OutCtxt.Y := 0; OutCtxt.Y := 0;
OutCtxt.Pass := 0; OutCtxt.Pass := 0;
@ -470,7 +452,7 @@ begin
end; end;
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; procedure TGIFFileFormat.LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer;
Interlaced: Boolean; Data: Pointer); Interlaced: Boolean; Data: Pointer);
var var
@ -541,7 +523,7 @@ begin
for I := 0 to HashTableSize - 1 do for I := 0 to HashTableSize - 1 do
HashTable.Add(nil); HashTable.Add(nil);
// Initialise encoder variables // Initialize encoder variables
InitCodeSize := BitCount + 1; InitCodeSize := BitCount + 1;
if InitCodeSize = 2 then if InitCodeSize = 2 then
Inc(InitCodeSize); Inc(InitCodeSize);
@ -735,7 +717,8 @@ var
if BlockSize >= SizeOf(AppRec) then if BlockSize >= SizeOf(AppRec) then
begin begin
Read(Handle, @AppRec, SizeOf(AppRec)); 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 begin
Read(Handle, @BlockSize, SizeOf(BlockSize)); Read(Handle, @BlockSize, SizeOf(BlockSize));
while BlockSize <> 0 do while BlockSize <> 0 do
@ -750,6 +733,9 @@ var
// Read loop count // Read loop count
Read(Handle, @LoopCount, SizeOf(LoopCount)); Read(Handle, @LoopCount, SizeOf(LoopCount));
Dec(BlockSize, SizeOf(LoopCount)); Dec(BlockSize, SizeOf(LoopCount));
if LoopCount > 0 then
Inc(LoopCount); // Netscape extension is really "repeats" not "loops"
FMetadata.SetMetaItem(SMetaAnimationLoops, LoopCount);
end; end;
GIFAppBufferExtension: GIFAppBufferExtension:
begin begin
@ -886,7 +872,7 @@ var
Exit; Exit;
end; end;
// If Grahic Control Extension is present make use of it // If Graphic Control Extension is present make use of it
if HasGraphicExt then if HasGraphicExt then
begin begin
FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent; FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
@ -896,6 +882,7 @@ var
FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex; FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0; Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
end; end;
FMetadata.SetMetaItem(SMetaFrameDelay, Integer(GraphicExt.DelayTime * 10), Idx);
end end
else else
FrameInfos[Idx].HasTransparency := False; FrameInfos[Idx].HasTransparency := False;
@ -972,7 +959,7 @@ var
if FrameInfos[Index].HasTransparency then if FrameInfos[Index].HasTransparency then
BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color; BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color;
// Clear whole screen // 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 // Try to maximize First so we don't have to use all 0 to n raw frames
while First > 0 do while First > 0 do
@ -1101,7 +1088,7 @@ begin
end; end;
function TGIFFileFormat.SaveData(Handle: TImagingHandle; function TGIFFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean; const Images: TDynImageDataArray; Index: LongInt): Boolean;
var var
Header: TGIFHeader; Header: TGIFHeader;
ImageDesc: TImageDescriptor; ImageDesc: TImageDescriptor;
@ -1124,6 +1111,44 @@ var
end; end;
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 begin
// Fill header with data, select size of largest image in array as // Fill header with data, select size of largest image in array as
// logical screen size // logical screen size
@ -1136,9 +1161,11 @@ begin
// Prepare default GC extension with delay // Prepare default GC extension with delay
FillChar(GraphicExt, Sizeof(GraphicExt), 0); FillChar(GraphicExt, Sizeof(GraphicExt), 0);
GraphicExt.DelayTime := 65; GraphicExt.DelayTime := GIFDefaultDelay;
GraphicExt.BlockSize := 4; GraphicExt.BlockSize := 4;
SaveGlobalMetadata;
for I := FFirstIdx to FLastIdx do for I := FFirstIdx to FLastIdx do
begin begin
if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
@ -1147,13 +1174,14 @@ begin
// Write Graphic Control Extension with default delay // Write Graphic Control Extension with default delay
Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer)); Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension)); Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension));
SetFrameDelay(I, GraphicExt);
Write(Handle, @GraphicExt, SizeOf(GraphicExt)); Write(Handle, @GraphicExt, SizeOf(GraphicExt));
// Write frame marker and fill and write image descriptor for this frame // Write frame marker and fill and write image descriptor for this frame
Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor)); Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor));
FillChar(ImageDesc, Sizeof(ImageDesc), 0); FillChar(ImageDesc, Sizeof(ImageDesc), 0);
ImageDesc.Width := Width; ImageDesc.Width := Width;
ImageDesc.Height := Height; 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(Handle, @ImageDesc, SizeOf(ImageDesc));
// Write local color table for each frame // Write local color table for each frame
@ -1164,7 +1192,7 @@ begin
Write(Handle, @Palette[J].B, SizeOf(Palette[J].B)); Write(Handle, @Palette[J].B, SizeOf(Palette[J].B));
end; end;
// Fonally compress image data // Finally compress image data
LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits); LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits);
finally finally
@ -1186,7 +1214,7 @@ end;
function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean; function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var var
Header: TGIFHeader; Header: TGIFHeader;
ReadCount: LongInt; ReadCount: Integer;
begin begin
Result := False; Result := False;
if Handle <> nil then if Handle <> nil then
@ -1208,6 +1236,14 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 --------------------------------- -- 0.26.3 Changes/Bug Fixes ---------------------------------
- Fixed bug - loading of GIF with NETSCAPE app extensions - Fixed bug - loading of GIF with NETSCAPE app extensions
failed with Delphi 2009. failed with Delphi 2009.
@ -1225,12 +1261,12 @@ initialization
transparent by default. transparent by default.
-- 0.24.1 Changes/Bug Fixes --------------------------------- -- 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 ----------------------------------- -- 0.23 Changes/Bug Fixes -----------------------------------
- Fixed other loading bugs (local pal size, transparency). - Fixed other loading bugs (local pal size, transparency).
- Added GIF saving. - 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, ...). features (disposal methods, ...).
- Loading of GIFs working. - Loading of GIFs working.
- Unit created with initial stuff! - Unit created with initial stuff!

239
Imaging/ImagingIO.pas
View File

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

260
Imaging/ImagingJpeg.pas
View File

@ -1,29 +1,12 @@
{ {
$Id: ImagingJpeg.pas 168 2009-08-22 18:50:21Z galfar $
Vampyre Imaging Library Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains image format loader/saver for Jpeg images.} { This unit contains image format loader/saver for Jpeg images.}
@ -43,13 +26,22 @@ unit ImagingJpeg;
{$DEFINE IMJPEGLIB} {$DEFINE IMJPEGLIB}
{ $DEFINE PASJPEG} { $DEFINE PASJPEG}
{ Automatically use FPC's PasJpeg when compiling with Lazarus. But not when { Automatically use FPC's PasJpeg when compiling with Lazarus. }
WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html} {$IF Defined(LCL)}
{$IF Defined(LCL) and not Defined(WINDOWS)}
{$UNDEF IMJPEGLIB} {$UNDEF IMJPEGLIB}
{$DEFINE PASJPEG} {$DEFINE PASJPEG}
{$IFEND} {$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 interface
uses uses
@ -64,7 +56,8 @@ uses
ImagingUtility; ImagingUtility;
{$IF Defined(FPC) and Defined(PASJPEG)} {$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} {$DEFINE RGBSWAPPED}
{$IFEND} {$IFEND}
@ -81,6 +74,7 @@ type
FQuality: LongInt; FQuality: LongInt;
FProgressive: LongBool; FProgressive: LongBool;
procedure SetJpegIO(const JpegIO: TIOFunctions); virtual; procedure SetJpegIO(const JpegIO: TIOFunctions); virtual;
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override; OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
@ -88,7 +82,6 @@ type
procedure ConvertToSupported(var Image: TImageData; procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override; const Info: TImageFormatInfo); override;
public public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override; function TestFormat(Handle: TImagingHandle): Boolean; override;
procedure CheckOptionsValidity; override; procedure CheckOptionsValidity; override;
published published
@ -145,15 +138,105 @@ var
JIO: TIOFunctions; JIO: TIOFunctions;
JpegErrorMgr: jpeg_error_mgr; 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); procedure JpegError(CInfo: j_common_ptr);
procedure RaiseError;
var var
Buffer: string; Buffer: AnsiString;
begin begin
{ Create the message and raise exception } // Create the message and raise exception
CInfo^.err^.format_message(CInfo, buffer); CInfo.err.format_message(CInfo, Buffer);
raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]); // Warning: you can get "Invalid argument index in format" exception when
// using FPC (see http://bugs.freepascal.org/view.php?id=21229).
// Fixed in FPC 2.7.1
{$IF Defined(FPC) and (FPC_FULLVERSION <= 20701)}
raise EImagingError.CreateFmt(SJPEGError + ' %d', [CInfo.err.msg_code]);
{$ELSE}
raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + string(Buffer), [CInfo.err.msg_code]);
{$IFEND}
end;
begin
{$IFDEF ErrorJmpRecovery}
// Only recovers on loads and when header is successfully loaded
// (error occurs when reading scanlines)
if (CInfo.client_data <> nil) and
PErrorClientData(CInfo.client_data).ScanlineReadReached then
begin
// Non-local jump to error handler in TJpegFileFormat.LoadData
longjmp(PErrorClientData(CInfo.client_data).JmpBuf, 1)
end
else
RaiseError;
{$ELSE}
RaiseError;
{$ENDIF}
end; end;
procedure OutputMessage(CurInfo: j_common_ptr); procedure OutputMessage(CurInfo: j_common_ptr);
@ -185,8 +268,8 @@ begin
if NBytes <= 0 then if NBytes <= 0 then
begin begin
PChar(Src.Buffer)[0] := #$FF; PByteArray(Src.Buffer)[0] := $FF;
PChar(Src.Buffer)[1] := Char(JPEG_EOI); PByteArray(Src.Buffer)[1] := JPEG_EOI;
NBytes := 2; NBytes := 2;
end; end;
Src.Pub.next_input_byte := Src.Buffer; Src.Pub.next_input_byte := Src.Buffer;
@ -295,14 +378,16 @@ begin
Dest.Output := Handle; Dest.Output := Handle;
end; end;
procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext); procedure SetupErrorMgr(var jc: TJpegContext);
begin begin
FillChar(jc, sizeof(jc), 0);
// Set standard error handlers and then override some // Set standard error handlers and then override some
jc.common.err := jpeg_std_error(JpegErrorMgr); jc.common.err := jpeg_std_error(JpegErrorMgr);
jc.common.err.error_exit := JpegError; jc.common.err.error_exit := JpegError;
jc.common.err.output_message := OutputMessage; 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)); jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
JpegStdioSrc(jc.d, Handle); JpegStdioSrc(jc.d, Handle);
jpeg_read_header(@jc.d, True); jpeg_read_header(@jc.d, True);
@ -319,18 +404,12 @@ end;
procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext; procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
Saver: TJpegFileFormat); Saver: TJpegFileFormat);
begin 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)); jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
JpegStdioDest(jc.c, Handle); JpegStdioDest(jc.c, Handle);
if Saver.FGrayScale then if Saver.FGrayScale then
jc.c.in_color_space := JCS_GRAYSCALE jc.c.in_color_space := JCS_GRAYSCALE
else else
jc.c.in_color_space := JCS_YCbCr; jc.c.in_color_space := JCS_RGB;
jpeg_set_defaults(@jc.c); jpeg_set_defaults(@jc.c);
jpeg_set_quality(@jc.c, Saver.FQuality, True); jpeg_set_quality(@jc.c, Saver.FQuality, True);
if Saver.FProgressive then if Saver.FProgressive then
@ -339,13 +418,10 @@ end;
{ TJpegFileFormat class implementation } { TJpegFileFormat class implementation }
constructor TJpegFileFormat.Create; procedure TJpegFileFormat.Define;
begin begin
inherited Create;
FName := SJpegFormatName; FName := SJpegFormatName;
FCanLoad := True; FFeatures := [ffLoad, ffSave];
FCanSave := True;
FIsMultiImageFormat := False;
FSupportedFormats := JpegSupportedFormats; FSupportedFormats := JpegSupportedFormats;
FQuality := JpegDefaultQuality; FQuality := JpegDefaultQuality;
@ -371,9 +447,27 @@ var
jc: TJpegContext; jc: TJpegContext;
Info: TImageFormatInfo; Info: TImageFormatInfo;
Col32: PColor32Rec; Col32: PColor32Rec;
{$IFDEF RGBSWAPPED} NeedsRedBlueSwap: Boolean;
Pix: PColor24Rec; Pix: PColor24Rec;
{$IFDEF ErrorJmpRecovery}
ErrorClient: TErrorClientData;
{$ENDIF} {$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 begin
// Copy IO functions to global var used in JpegLib callbacks // Copy IO functions to global var used in JpegLib callbacks
Result := False; Result := False;
@ -382,7 +476,19 @@ begin
with JIO, Images[0] do with JIO, Images[0] do
try 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); InitDecompressor(Handle, jc);
case jc.d.out_color_space of case jc.d.out_color_space of
JCS_GRAYSCALE: Format := ifGray8; JCS_GRAYSCALE: Format := ifGray8;
JCS_RGB: Format := ifR8G8B8; JCS_RGB: Format := ifR8G8B8;
@ -390,6 +496,7 @@ begin
else else
Exit; Exit;
end; end;
NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]); NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
jpeg_start_decompress(@jc.d); jpeg_start_decompress(@jc.d);
GetImageFormatInfo(Format, Info); GetImageFormatInfo(Format, Info);
@ -397,11 +504,22 @@ begin
LinesPerCall := 1; LinesPerCall := 1;
Dest := Bits; 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 while jc.d.output_scanline < jc.d.output_height do
begin begin
LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall); LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
{$IFDEF RGBSWAPPED} if NeedsRedBlueSwap and (Format = ifR8G8B8) then
if Format = ifR8G8B8 then
begin begin
Pix := PColor24Rec(Dest); Pix := PColor24Rec(Dest);
for I := 0 to Width - 1 do for I := 0 to Width - 1 do
@ -410,7 +528,6 @@ begin
Inc(Pix); Inc(Pix);
end; end;
end; end;
{$ENDIF}
Inc(Dest, PtrInc * LinesRead); Inc(Dest, PtrInc * LinesRead);
end; end;
@ -427,6 +544,9 @@ begin
end; end;
end; end;
// Store supported metadata
LoadMetaData;
jpeg_finish_output(@jc.d); jpeg_finish_output(@jc.d);
jpeg_finish_decompress(@jc.d); jpeg_finish_decompress(@jc.d);
Result := True; Result := True;
@ -448,14 +568,31 @@ var
I: LongInt; I: LongInt;
Pix: PColor24Rec; Pix: PColor24Rec;
{$ENDIF} {$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 begin
Result := False; Result := False;
// Copy IO functions to global var used in JpegLib callbacks // Copy IO functions to global var used in JpegLib callbacks
SetJpegIO(GetIO); SetJpegIO(GetIO);
// Makes image to save compatible with Jpeg saving capabilities // Makes image to save compatible with Jpeg saving capabilities
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
with JIO, ImageToSave do with JIO, ImageToSave do
try try
ZeroMemory(@jc, SizeOf(jc));
SetupErrorMgr(jc);
GetImageFormatInfo(Format, Info); GetImageFormatInfo(Format, Info);
FGrayScale := Format = ifGray8; FGrayScale := Format = ifGray8;
InitCompressor(Handle, jc, Self); InitCompressor(Handle, jc, Self);
@ -479,6 +616,9 @@ begin
GetMem(Line, PtrInc); GetMem(Line, PtrInc);
{$ENDIF} {$ENDIF}
// Save supported metadata
SaveMetaData;
jpeg_start_compress(@jc.c, True); jpeg_start_compress(@jc.c, True);
while (jc.c.next_scanline < jc.c.image_height) do while (jc.c.next_scanline < jc.c.image_height) do
begin begin
@ -553,8 +693,20 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 --------------------------------- -- 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 --------------------------------- -- 0.26.1 Changes/Bug Fixes ---------------------------------
- Fixed wrong color space setting in InitCompressor. - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains functions for loading and saving OpenGL textures { This unit contains functions for loading and saving OpenGL textures
@ -33,17 +16,18 @@ unit ImagingOpenGL;
{$I ImagingOptions.inc} {$I ImagingOptions.inc}
{ Define this symbol if you want to use dglOpenGL header.} { Define this symbol if you want to use dglOpenGL header.}
{ $DEFINE USE_DGL_HEADERS} {$DEFINE OPENGL_USE_DGL_HEADERS}
{ $DEFINE USE_GLSCENE_HEADERS}
{$IFDEF OPENGL_NO_EXT_HEADERS}
{$UNDEF OPENGL_USE_DGL_HEADERS}
{$ENDIF}
interface interface
uses uses
SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats, SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats,
{$IF Defined(USE_DGL_HEADERS)} {$IF Defined(OPENGL_USE_DGL_HEADERS)}
dglOpenGL, dglOpenGL,
{$ELSEIF Defined(USE_GLSCENE_HEADERS)}
OpenGL1x,
{$ELSE} {$ELSE}
gl, glext, gl, glext,
{$IFEND} {$IFEND}
@ -144,7 +128,7 @@ function SaveGLTextureToStream(const Ext: string; Stream: TStream; const Texture
Saves all present mipmap levels.} Saves all present mipmap levels.}
function SaveGLTextureToMemory(const Ext: string; Data: Pointer; var Size: LongInt; const Texture: GLuint): Boolean; 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 can be used to convert output image to the specified format rather
than use the format taken from GL texture, ifUnknown means no conversion.} than use the format taken from GL texture, ifUnknown means no conversion.}
function CreateImageFromGLTexture(const Texture: GLuint; function CreateImageFromGLTexture(const Texture: GLuint;
@ -168,23 +152,23 @@ var
pow2 texture is created and nonpow2 input image is pasted into it pow2 texture is created and nonpow2 input image is pasted into it
keeping its original size. This could be useful for some 2D stuff keeping its original size. This could be useful for some 2D stuff
(and its faster than rescaling of course). Note that this is applied (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 image->texture process (usually only pow2/nonpow2 stuff and when you
set custom Width & Height in CreateGLTextureFrom(Multi)Image).} set custom Width & Height in CreateGLTextureFrom(Multi)Image).}
PasteNonPow2ImagesIntoPow2: Boolean = False; 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 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 when HW has full support for NPOT textures but some cards
(ATI Radeons, some other maybe) have partial NPOT support. Namely Radeons (pre-DX10 ATI Radeons, some other maybe) have partial NPOT support.
can use NPOT textures but not mipmapped. If you know what you are doing 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 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; DisableNPOTSupportCheck: Boolean = False;
implementation implementation
const const
// cube map consts // Cube map constants
GL_TEXTURE_BINDING_CUBE_MAP = $8514; GL_TEXTURE_BINDING_CUBE_MAP = $8514;
GL_TEXTURE_CUBE_MAP_POSITIVE_X = $8515; GL_TEXTURE_CUBE_MAP_POSITIVE_X = $8515;
GL_TEXTURE_CUBE_MAP_NEGATIVE_X = $8516; GL_TEXTURE_CUBE_MAP_NEGATIVE_X = $8516;
@ -193,7 +177,7 @@ const
GL_TEXTURE_CUBE_MAP_POSITIVE_Z = $8519; GL_TEXTURE_CUBE_MAP_POSITIVE_Z = $8519;
GL_TEXTURE_CUBE_MAP_NEGATIVE_Z = $851A; GL_TEXTURE_CUBE_MAP_NEGATIVE_Z = $851A;
// texture formats // Texture formats
GL_COLOR_INDEX = $1900; GL_COLOR_INDEX = $1900;
GL_STENCIL_INDEX = $1901; GL_STENCIL_INDEX = $1901;
GL_DEPTH_COMPONENT = $1902; GL_DEPTH_COMPONENT = $1902;
@ -208,7 +192,7 @@ const
GL_BGR_EXT = $80E0; GL_BGR_EXT = $80E0;
GL_BGRA_EXT = $80E1; GL_BGRA_EXT = $80E1;
// texture internal formats // Texture internal formats
GL_ALPHA4 = $803B; GL_ALPHA4 = $803B;
GL_ALPHA8 = $803C; GL_ALPHA8 = $803C;
GL_ALPHA12 = $803D; GL_ALPHA12 = $803D;
@ -242,8 +226,9 @@ const
GL_RGB10_A2 = $8059; GL_RGB10_A2 = $8059;
GL_RGBA12 = $805A; GL_RGBA12 = $805A;
GL_RGBA16 = $805B; GL_RGBA16 = $805B;
GL_RGB565 = $8D62;
// floating point texture formats // Floating point texture formats
GL_RGBA32F_ARB = $8814; GL_RGBA32F_ARB = $8814;
GL_INTENSITY32F_ARB = $8817; GL_INTENSITY32F_ARB = $8817;
GL_LUMINANCE32F_ARB = $8818; GL_LUMINANCE32F_ARB = $8818;
@ -251,22 +236,46 @@ const
GL_INTENSITY16F_ARB = $881D; GL_INTENSITY16F_ARB = $881D;
GL_LUMINANCE16F_ARB = $881E; 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_DXT1_EXT = $83F1;
GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2; GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2;
GL_COMPRESSED_RGBA_S3TC_DXT5_EXT = $83F3; GL_COMPRESSED_RGBA_S3TC_DXT5_EXT = $83F3;
// 3Dc LATC
GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI = $8837; GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI = $8837;
GL_COMPRESSED_LUMINANCE_LATC1_EXT = $8C70; GL_COMPRESSED_LUMINANCE_LATC1_EXT = $8C70;
GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT = $8C71; GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT = $8C71;
GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT = $8C72; GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT = $8C72;
GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT = $8C73; 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_MAX_TEXTURE_UNITS = $84E2;
GL_TEXTURE_MAX_ANISOTROPY_EXT = $84FE; GL_TEXTURE_MAX_ANISOTROPY_EXT = $84FE;
GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT = $84FF; GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT = $84FF;
// texture source data formats // Texture source data formats
GL_UNSIGNED_BYTE_3_3_2 = $8032; GL_UNSIGNED_BYTE_3_3_2 = $8032;
GL_UNSIGNED_SHORT_4_4_4_4 = $8033; GL_UNSIGNED_SHORT_4_4_4_4 = $8033;
GL_UNSIGNED_SHORT_5_5_5_1 = $8034; GL_UNSIGNED_SHORT_5_5_5_1 = $8034;
@ -302,10 +311,10 @@ var
ExtensionBuffer: string = ''; ExtensionBuffer: string = '';
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
function wglGetProcAddress(ProcName: PChar): Pointer; stdcall; external GLLibName; function wglGetProcAddress(ProcName: PAnsiChar): Pointer; stdcall; external GLLibName;
{$ENDIF} {$ENDIF}
{$IFDEF UNIX} {$IFDEF UNIX}
function glXGetProcAddress(ProcName: PChar): Pointer; cdecl; external GLLibName; function glXGetProcAddress(ProcName: PAnsiChar): Pointer; cdecl; external GLLibName;
{$ENDIF} {$ENDIF}
function IsGLExtensionSupported(const Extension: string): Boolean; function IsGLExtensionSupported(const Extension: string): Boolean;
@ -327,16 +336,16 @@ end;
function GetGLProcAddress(const ProcName: string): Pointer; function GetGLProcAddress(const ProcName: string): Pointer;
begin begin
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
Result := wglGetProcAddress(PChar(ProcName)); Result := wglGetProcAddress(PAnsiChar(AnsiString(ProcName)));
{$ENDIF} {$ENDIF}
{$IFDEF UNIX} {$IFDEF UNIX}
Result := glXGetProcAddress(PChar(ProcName)); Result := glXGetProcAddress(PAnsiChar(AnsiString(ProcName)));
{$ENDIF} {$ENDIF}
end; end;
function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean; function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean;
begin 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 Caps.DXTCompression := IsGLExtensionSupported('GL_ARB_texture_compression') and
IsGLExtensionSupported('GL_EXT_texture_compression_s3tc'); IsGLExtensionSupported('GL_EXT_texture_compression_s3tc');
if Caps.DXTCompression then if Caps.DXTCompression then
@ -408,7 +417,7 @@ begin
begin begin
GLFormat := GL_RGB; GLFormat := GL_RGB;
GLType := GL_UNSIGNED_SHORT_5_6_5; GLType := GL_UNSIGNED_SHORT_5_6_5;
GLInternal := GL_RGB5; GLInternal := GL_RGB5; //GL_RGB565 ot working on Radeons
end; end;
ifA1R5G5B5, ifX1R5G5B5: ifA1R5G5B5, ifX1R5G5B5:
begin begin
@ -656,7 +665,7 @@ begin
// Generate new texture, bind it and set // Generate new texture, bind it and set
glGenTextures(1, @Result); glGenTextures(1, @Result);
glBindTexture(GL_TEXTURE_2D, Result); glBindTexture(GL_TEXTURE_2D, Result);
if Byte(glIsTexture(Result)) <> GL_TRUE then if glIsTexture(Result) <> GL_TRUE then
Exit; Exit;
for I := MainLevelIndex to MipLevels - 1 + MainLevelIndex do for I := MainLevelIndex to MipLevels - 1 + MainLevelIndex do
@ -843,12 +852,16 @@ begin
FreeImagesInArray(Images); FreeImagesInArray(Images);
SetLength(Images, 0); SetLength(Images, 0);
Result := False; Result := False;
if Byte(glIsTexture(Texture)) = GL_TRUE then if glIsTexture(Texture) = GL_TRUE then
begin begin
// Check if desired mipmap level count is valid // Check if desired mipmap level count is valid
glBindTexture(GL_TEXTURE_2D, Texture); glBindTexture(GL_TEXTURE_2D, Texture);
if MipLevels <= 0 then 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); MipLevels := GetNumMipMapLevels(Width, Height);
end;
SetLength(Images, MipLevels); SetLength(Images, MipLevels);
ExistingLevels := 0; ExistingLevels := 0;
@ -883,9 +896,13 @@ initialization
File Notes: File Notes:
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- use internal format of texture in CreateMultiImageFromGLTexture
not only A8R8G8B8 -- 0.77.1 ---------------------------------------------------
- support for cube and 3D maps - 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 --------------------------------- -- 0.26.1 Changes/Bug Fixes ---------------------------------
- Added support for GLScene's OpenGL header. - 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 User Options
Following defines and options can be changed by user. Following defines and options can be changed by user.
@ -9,21 +7,24 @@
{$DEFINE USE_INLINE} // Use function inlining for some functions {$DEFINE USE_INLINE} // Use function inlining for some functions
// works in Free Pascal and Delphi 9+. // 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). // functions will be used (only for x86).
// Debug options: If none of these two are defined // Debug options: If none of these two are defined
// your project settings are used. // 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 // checking, stack frames, assertions, and
// other debugging options will be turned on. // other debugging options will be turned on.
{$DEFINE IMAGING_RELEASE} // If defined, all debug info is off. {$DEFINE IMAGING_RELEASE} // If defined, all debug info is off.
{$DEFINE OPENGL_NO_EXT_HEADERS}
(* File format support linking options. (* File format support linking options.
Define formats which you don't want to be registred automatically. Define formats which you don't want to be registered automatically (by adding
Default: all formats are registered = no symbols defined. 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 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_MNG} // link support for MNG images
{$DEFINE DONT_LINK_JNG} // link support for JNG 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_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 {$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 // registered depends on settings in
// ImagingExtras.pas unit. // ImagingExtFileFormats.pas unit.
{ Component set used in ImagignComponents.pas unit. You usually don't need {.$DEFINE DONT_LINK_FILE_FORMATS} // no auto link support of any file format
to be concerned with this - proper component library is selected automatically
according to your compiler. }
{ $DEFINE COMPONENT_SET_VCL} // use Delphi VCL
{$DEFINE COMPONENT_SET_LCL} // use Lazarus LCL (set automatically when compiling with FPC)
{ {
Auto Options Auto Options
@ -62,26 +59,29 @@
{$BOOLEVAL OFF} // Boolean eval: off {$BOOLEVAL OFF} // Boolean eval: off
{$EXTENDEDSYNTAX ON} // Extended syntax: on {$EXTENDEDSYNTAX ON} // Extended syntax: on
{$LONGSTRINGS ON} // string = AnsiString: 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 {$TYPEDADDRESS OFF} // Typed pointers: off
{$WRITEABLECONST OFF} // Writeable constants: off {$WRITEABLECONST OFF} // Writeable constants: off
{$IFNDEF FPC} {$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 // others are not supported
{$ENDIF} {$ENDIF}
{$IFDEF DCC} {$IFDEF DCC}
{$IFDEF LINUX} {$DEFINE DELPHI}
{$DEFINE KYLIX} // using Kylix {$IF (Defined(DCC) and (CompilerVersion >= 25.0))}
{$ENDIF} {$LEGACYIFEND ON}
{$IFEND}
{$ENDIF} {$ENDIF}
{$IFDEF DCC} {$IF (Defined(DCC) and (CompilerVersion >= 18.5))}
{$IFNDEF KYLIX} {$IFDEF RELEASE}
{$DEFINE DELPHI} // using Delphi {$UNDEF DEBUG} // If we are using Delphi 2007+ where you can set
{$ENDIF} // DEBUG/RELEASE mode in project options and RELEASE
// is currently set we undef DEBUG mode
{$ENDIF} {$ENDIF}
{$IFEND}
{$IF Defined(IMAGING_DEBUG)} {$IF Defined(IMAGING_DEBUG)}
{$ASSERTIONS ON} {$ASSERTIONS ON}
@ -115,32 +115,87 @@
{$ENDIF} {$ENDIF}
{$IFEND} {$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 } { Compiler capabilities }
// Define if compiler supports inlining of functions and procedures // Define if compiler supports inlining of functions and procedures
// Note that FPC inline support crashed in older versions (1.9.8) {$IF (Defined(DCC) and (CompilerVersion >= 17)) or Defined(FPC)}
{$IF (Defined(FPC) and Defined(CPU86))}
{$DEFINE HAS_INLINE} {$DEFINE HAS_INLINE}
{$IFEND} {$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 // Define if compiler supports operator overloading
// (unfortunately Delphi and FPC operator overloaing is not compatible) // (unfortunately Delphi and FPC operator overloading is not compatible).
{$IF Defined(FPC)} // 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} {$DEFINE HAS_OPERATOR_OVERLOADING}
{$IFEND} {$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} { Imaging options check}
{$IFNDEF HAS_INLINE} {$IFNDEF HAS_INLINE}
{$UNDEF USE_INLINE} {$UNDEF USE_INLINE}
{$ENDIF} {$ENDIF}
{$IFDEF FPC} {$IF not Defined(CPUX86)}
{$IFNDEF CPU86}
{$UNDEF USE_ASM} {$UNDEF USE_ASM}
{$ENDIF} {$IFEND}
{$ENDIF}
{$IFDEF FPC} {$IFDEF FPC}
{$DEFINE COMPONENT_SET_LCL} {$DEFINE COMPONENT_SET_LCL}
@ -152,20 +207,6 @@
{$DEFINE COMPONENT_SET_VCL} {$DEFINE COMPONENT_SET_VCL}
{$ENDIF} {$ENDIF}
{ Platform options }
{$IFDEF WIN32}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$IFDEF DPMI}
{$DEFINE MSDOS}
{$ENDIF}
{$IFDEF LINUX}
{$DEFINE UNIX}
{$ENDIF}
{ More compiler options } { More compiler options }
{$IFDEF FPC} // Free Pascal options - some options set above (like min enum size) {$IFDEF FPC} // Free Pascal options - some options set above (like min enum size)
@ -175,7 +216,6 @@
{$GOTO ON} // alow goto {$GOTO ON} // alow goto
{$PACKRECORDS 8} // same as ALING 8 for Delphi {$PACKRECORDS 8} // same as ALING 8 for Delphi
{$PACKENUM 4} // Min enum size: 4 B {$PACKENUM 4} // Min enum size: 4 B
{$CALLING REGISTER} // default calling convention is register
{$IFDEF CPU86} {$IFDEF CPU86}
{$ASMMODE INTEL} // intel assembler mode {$ASMMODE INTEL} // intel assembler mode
{$ENDIF} {$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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains loader/saver for Portable Maps file format family (or PNM). { This unit contains loader/saver for Portable Maps file format family (or PNM).
@ -65,12 +48,13 @@ type
protected protected
FIdNumbers: TChar2; FIdNumbers: TChar2;
FSaveBinary: LongBool; FSaveBinary: LongBool;
FUSFormat: TFormatSettings;
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override; OnlyFirstLevel: Boolean): Boolean; override;
function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt; var MapInfo: TPortableMapInfo): Boolean; Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
public public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override; function TestFormat(Handle: TImagingHandle): Boolean; override;
published published
{ If set to True images will be saved in binary format. If it is False { 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 PBM images can be loaded but not saved. Loaded images are returned in
ifGray8 format (witch pixel values scaled from 1bit to 8bit).} ifGray8 format (witch pixel values scaled from 1bit to 8bit).}
TPBMFileFormat = class(TPortableMapFileFormat) TPBMFileFormat = class(TPortableMapFileFormat)
public protected
constructor Create; override; procedure Define; override;
end; end;
{ Portable Gray Map is used to store grayscale 8bit or 16bit images. { Portable Gray Map is used to store grayscale 8bit or 16bit images.
Raster data can be saved as text or binary data.} Raster data can be saved as text or binary data.}
TPGMFileFormat = class(TPortableMapFileFormat) TPGMFileFormat = class(TPortableMapFileFormat)
protected protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override; Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData; procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override; const Info: TImageFormatInfo); override;
public
constructor Create; override;
end; end;
{ Portable Pixel Map is used to store RGB images with 8bit or 16bit channels. { Portable Pixel Map is used to store RGB images with 8bit or 16bit channels.
Raster data can be saved as text or binary data.} Raster data can be saved as text or binary data.}
TPPMFileFormat = class(TPortableMapFileFormat) TPPMFileFormat = class(TPortableMapFileFormat)
protected protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override; Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData; procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override; const Info: TImageFormatInfo); override;
public
constructor Create; override;
end; end;
{ Portable Arbitrary Map is format that can store image data formats { Portable Arbitrary Map is format that can store image data formats
@ -120,12 +102,11 @@ type
ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.} ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.}
TPAMFileFormat = class(TPortableMapFileFormat) TPAMFileFormat = class(TPortableMapFileFormat)
protected protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override; Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData; procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override; const Info: TImageFormatInfo); override;
public
constructor Create; override;
end; end;
{ Portable Float Map is unofficial extension of PNM format family which { 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).} or RGB images are supported by PFM format (so no alpha).}
TPFMFileFormat = class(TPortableMapFileFormat) TPFMFileFormat = class(TPortableMapFileFormat)
protected protected
procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override; Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData; procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override; const Info: TImageFormatInfo); override;
public
constructor Create; override;
end; end;
implementation implementation
@ -161,7 +141,7 @@ const
ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16]; ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16];
SPFMFormatName = 'Portable Float Map'; SPFMFormatName = 'Portable Float Map';
SPFMMasks = '*.pfm'; SPFMMasks = '*.pfm';
PFMSupportedFormats = [ifR32F, ifA32B32G32R32F]; PFMSupportedFormats = [ifR32F, ifB32G32R32F];
const const
{ TAB, CR, LF, and Space are used as seperators in Portable map headers and data.} { TAB, CR, LF, and Space are used as seperators in Portable map headers and data.}
@ -183,13 +163,12 @@ const
{ TPortableMapFileFormat } { TPortableMapFileFormat }
constructor TPortableMapFileFormat.Create; procedure TPortableMapFileFormat.Define;
begin begin
inherited Create; inherited;
FCanLoad := True; FFeatures := [ffLoad, ffSave];
FCanSave := True;
FIsMultiImageFormat := False;
FSaveBinary := PortableMapDefaultBinary; FSaveBinary := PortableMapDefaultBinary;
FUSFormat := GetFormatSettingsForFloats;
end; end;
function TPortableMapFileFormat.LoadData(Handle: TImagingHandle; function TPortableMapFileFormat.LoadData(Handle: TImagingHandle;
@ -199,7 +178,6 @@ var
Dest: PByte; Dest: PByte;
MonoData: Pointer; MonoData: Pointer;
Info: TImageFormatInfo; Info: TImageFormatInfo;
PixelFP: TColorFPRec;
LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar; LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar;
LineEnd, LinePos: LongInt; LineEnd, LinePos: LongInt;
MapInfo: TPortableMapInfo; MapInfo: TPortableMapInfo;
@ -263,7 +241,7 @@ var
C := LineBuffer[LinePos]; C := LineBuffer[LinePos];
Inc(LinePos); Inc(LinePos);
until not (C in WhiteSpaces) or (LineEnd = 0); 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); Dec(LinePos);
Result := string(S); Result := string(S);
@ -296,7 +274,6 @@ var
I: TTupleType; I: TTupleType;
TupleTypeName: string; TupleTypeName: string;
Scale: Single; Scale: Single;
OldSeparator: Char;
begin begin
Result := False; Result := False;
with GetIO do with GetIO do
@ -368,10 +345,7 @@ var
// Read header of PFM file // Read header of PFM file
MapInfo.Width := ReadIntValue; MapInfo.Width := ReadIntValue;
MapInfo.Height := ReadIntValue; MapInfo.Height := ReadIntValue;
OldSeparator := DecimalSeparator; Scale := StrToFloatDef(ReadString, 0, FUSFormat);
DecimalSeparator := '.';
Scale := StrToFloatDef(ReadString, 0);
DecimalSeparator := OldSeparator;
MapInfo.IsBigEndian := Scale > 0.0; MapInfo.IsBigEndian := Scale > 0.0;
if Id[1] = 'F' then if Id[1] = 'F' then
MapInfo.TupleType := ttRGBFP MapInfo.TupleType := ttRGBFP
@ -387,7 +361,7 @@ var
if MapInfo.Binary and not (Id[1] in ['F', 'f']) then if MapInfo.Binary and not (Id[1] in ['F', 'f']) then
begin begin
// Mimic the behaviour of Photoshop and other editors/viewers: // 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. // little endian, Unix LF only linebreak indicates big endian.
MapInfo.IsBigEndian := LineBreak = #10; MapInfo.IsBigEndian := LineBreak = #10;
end; end;
@ -411,6 +385,7 @@ begin
LineEnd := 0; LineEnd := 0;
LinePos := 0; LinePos := 0;
SetLength(Images, 1); SetLength(Images, 1);
with GetIO, Images[0] do with GetIO, Images[0] do
begin begin
Format := ifUnknown; Format := ifUnknown;
@ -425,7 +400,7 @@ begin
ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16); ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16); ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
ttGrayScaleFP: Format := ifR32F; ttGrayScaleFP: Format := ifR32F;
ttRGBFP: Format := ifA32B32G32R32F; ttRGBFP: Format := ifB32G32R32F;
end; end;
// Exit if no matching data format was found // Exit if no matching data format was found
if Format = ifUnknown then Exit; if Format = ifUnknown then Exit;
@ -482,27 +457,9 @@ begin
// FP images are in BGR order and endian swap maybe needed. // FP images are in BGR order and endian swap maybe needed.
// Some programs store scanlines in bottom-up order but // Some programs store scanlines in bottom-up order but
// I will stick with Photoshops behaviour here // I will stick with Photoshops behaviour here
for I := 0 to Width * Height - 1 do Read(Handle, Bits, Size);
begin
Read(Handle, @PixelFP, MapInfo.BitCount div 8);
if MapInfo.TupleType = ttRGBFP then
with PColorFPRec(Dest)^ do
begin
A := 1.0;
R := PixelFP.R;
G := PixelFP.G;
B := PixelFP.B;
if MapInfo.IsBigEndian then if MapInfo.IsBigEndian then
SwapEndianLongWord(PLongWord(Dest), 3); SwapEndianUInt32(PUInt32(Dest), Size div SizeOf(UInt32));
end
else
begin
PSingle(Dest)^ := PixelFP.B;
if MapInfo.IsBigEndian then
SwapEndianLongWord(PLongWord(Dest), 1);
end;
Inc(Dest, Info.BytesPerPixel);
end;
end; end;
if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
@ -532,8 +489,8 @@ begin
GetMem(MonoData, MonoSize); GetMem(MonoData, MonoSize);
try try
Read(Handle, MonoData, MonoSize); Read(Handle, MonoData, MonoSize);
Convert1To8(MonoData, Bits, Width, Height, ScanLineSize); Convert1To8(MonoData, Bits, Width, Height, ScanLineSize, False);
// 1bit mono images must be scaled to 8bit (where 0=white, 1=black) // 1bit mono images must be scaled to 8bit, but inverted (where 0=white, 1=black)
for I := 0 to Width * Height - 1 do for I := 0 to Width * Height - 1 do
PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255; PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255;
finally finally
@ -565,7 +522,7 @@ begin
end; end;
function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle; function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer; var MapInfo: TPortableMapInfo): Boolean; const Images: TDynImageDataArray; Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
const const
// Use Unix linebreak, for many viewers/editors it means that // Use Unix linebreak, for many viewers/editors it means that
// 16bit samples are stored as big endian - so we need to swap byte order // 16bit samples are stored as big endian - so we need to swap byte order
@ -595,8 +552,6 @@ var
end; end;
procedure WriteHeader; procedure WriteHeader;
var
OldSeparator: Char;
begin begin
WriteString('P' + MapInfo.FormatId); WriteString('P' + MapInfo.FormatId);
if not MapInfo.HasPAMHeader then if not MapInfo.HasPAMHeader then
@ -608,11 +563,8 @@ var
ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1)); ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1));
ttGrayScaleFP, ttRGBFP: ttGrayScaleFP, ttRGBFP:
begin begin
OldSeparator := DecimalSeparator;
DecimalSeparator := '.';
// Negative value indicates that raster data is saved in little endian // Negative value indicates that raster data is saved in little endian
WriteString(FloatToStr(-1.0)); WriteString(FloatToStr(-1.0, FUSFormat));
DecimalSeparator := OldSeparator;
end; end;
end; end;
end end
@ -699,7 +651,7 @@ begin
end end
else else
begin 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 // 3 or 4 bytes must be written
Src := Bits; Src := Bits;
for I := 0 to Width * Height - 1 do for I := 0 to Width * Height - 1 do
@ -750,23 +702,7 @@ begin
begin begin
// Floating point images (no need to swap endian here - little // Floating point images (no need to swap endian here - little
// endian is specified in file header) // 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); 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;
end; end;
Result := True; Result := True;
@ -794,20 +730,20 @@ end;
{ TPBMFileFormat } { TPBMFileFormat }
constructor TPBMFileFormat.Create; procedure TPBMFileFormat.Define;
begin begin
inherited Create; inherited;
FName := SPBMFormatName; FName := SPBMFormatName;
FCanSave := False; FFeatures := [ffLoad];
AddMasks(SPBMMasks); AddMasks(SPBMMasks);
FIdNumbers := '14'; FIdNumbers := '14';
end; end;
{ TPGMFileFormat } { TPGMFileFormat }
constructor TPGMFileFormat.Create; procedure TPGMFileFormat.Define;
begin begin
inherited Create; inherited;
FName := SPGMFormatName; FName := SPGMFormatName;
FSupportedFormats := PGMSupportedFormats; FSupportedFormats := PGMSupportedFormats;
AddMasks(SPGMMasks); AddMasks(SPGMMasks);
@ -816,7 +752,7 @@ begin
end; end;
function TPGMFileFormat.SaveData(Handle: TImagingHandle; function TPGMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean; const Images: TDynImageDataArray; Index: LongInt): Boolean;
var var
MapInfo: TPortableMapInfo; MapInfo: TPortableMapInfo;
begin begin
@ -853,9 +789,9 @@ end;
{ TPPMFileFormat } { TPPMFileFormat }
constructor TPPMFileFormat.Create; procedure TPPMFileFormat.Define;
begin begin
inherited Create; inherited;
FName := SPPMFormatName; FName := SPPMFormatName;
FSupportedFormats := PPMSupportedFormats; FSupportedFormats := PPMSupportedFormats;
AddMasks(SPPMMasks); AddMasks(SPPMMasks);
@ -864,7 +800,7 @@ begin
end; end;
function TPPMFileFormat.SaveData(Handle: TImagingHandle; function TPPMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean; const Images: TDynImageDataArray; Index: LongInt): Boolean;
var var
MapInfo: TPortableMapInfo; MapInfo: TPortableMapInfo;
begin begin
@ -901,9 +837,9 @@ end;
{ TPAMFileFormat } { TPAMFileFormat }
constructor TPAMFileFormat.Create; procedure TPAMFileFormat.Define;
begin begin
inherited Create; inherited;
FName := SPAMFormatName; FName := SPAMFormatName;
FSupportedFormats := PAMSupportedFormats; FSupportedFormats := PAMSupportedFormats;
AddMasks(SPAMMasks); AddMasks(SPAMMasks);
@ -911,7 +847,7 @@ begin
end; end;
function TPAMFileFormat.SaveData(Handle: TImagingHandle; function TPAMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean; const Images: TDynImageDataArray; Index: LongInt): Boolean;
var var
MapInfo: TPortableMapInfo; MapInfo: TPortableMapInfo;
begin begin
@ -943,9 +879,9 @@ end;
{ TPFMFileFormat } { TPFMFileFormat }
constructor TPFMFileFormat.Create; procedure TPFMFileFormat.Define;
begin begin
inherited Create; inherited;
FName := SPFMFormatName; FName := SPFMFormatName;
AddMasks(SPFMMasks); AddMasks(SPFMMasks);
FIdNumbers := 'Ff'; FIdNumbers := 'Ff';
@ -953,7 +889,7 @@ begin
end; end;
function TPFMFileFormat.SaveData(Handle: TImagingHandle; function TPFMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean; const Images: TDynImageDataArray; Index: LongInt): Boolean;
var var
Info: TImageFormatInfo; Info: TImageFormatInfo;
MapInfo: TPortableMapInfo; MapInfo: TPortableMapInfo;
@ -979,7 +915,7 @@ procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); const Info: TImageFormatInfo);
begin begin
if (Info.ChannelCount > 1) or Info.IsIndexed then if (Info.ChannelCount > 1) or Info.IsIndexed then
ConvertImage(Image, ifA32B32G32R32F) ConvertImage(Image, ifB32G32R32F)
else else
ConvertImage(Image, ifR32F); ConvertImage(Image, ifR32F);
end; end;
@ -997,6 +933,11 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 ----------------------------------- -- 0.26.3 Changes/Bug Fixes -----------------------------------
- Fixed D2009 Unicode related bug in PNM saving. - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains image format loader/saver for Targa images.} { This unit contains image format loader/saver for Targa images.}
@ -43,6 +26,7 @@ type
TTargaFileFormat = class(TImageFileFormat) TTargaFileFormat = class(TImageFileFormat)
protected protected
FUseRLE: LongBool; FUseRLE: LongBool;
procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override; OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
@ -50,7 +34,6 @@ type
procedure ConvertToSupported(var Image: TImageData; procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override; const Info: TImageFormatInfo); override;
public public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override; function TestFormat(Handle: TImagingHandle): Boolean; override;
published published
{ Controls that RLE compression is used during saving. Accessible trough { Controls that RLE compression is used during saving. Accessible trough
@ -89,8 +72,8 @@ type
{ Footer at the end of TGA file.} { Footer at the end of TGA file.}
TTargaFooter = packed record TTargaFooter = packed record
ExtOff: LongWord; // Extension Area Offset ExtOff: UInt32; // Extension Area Offset
DevDirOff: LongWord; // Developer Directory Offset DevDirOff: UInt32; // Developer Directory Offset
Signature: TChar16; // TRUEVISION-XFILE Signature: TChar16; // TRUEVISION-XFILE
Reserved: Byte; // ASCII period '.' Reserved: Byte; // ASCII period '.'
NullChar: Byte; // 0 NullChar: Byte; // 0
@ -99,13 +82,11 @@ type
{ TTargaFileFormat class implementation } { TTargaFileFormat class implementation }
constructor TTargaFileFormat.Create; procedure TTargaFileFormat.Define;
begin begin
inherited Create; inherited;
FName := STargaFormatName; FName := STargaFormatName;
FCanLoad := True; FFeatures := [ffLoad, ffSave];
FCanSave := True;
FIsMultiImageFormat := False;
FSupportedFormats := TargaSupportedFormats; FSupportedFormats := TargaSupportedFormats;
FUseRLE := TargaDefaultRLE; FUseRLE := TargaDefaultRLE;
@ -120,7 +101,7 @@ var
Hdr: TTargaHeader; Hdr: TTargaHeader;
Foo: TTargaFooter; Foo: TTargaFooter;
FooterFound, ExtFound: Boolean; FooterFound, ExtFound: Boolean;
I, PSize, PalSize: LongWord; I, PSize, PalSize: Integer;
Pal: Pointer; Pal: Pointer;
FmtInfo: TImageFormatInfo; FmtInfo: TImageFormatInfo;
WordValue: Word; WordValue: Word;
@ -134,7 +115,7 @@ var
begin begin
with GetIO, Images[0] do with GetIO, Images[0] do
begin 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 // RLE compressed data and reads then from input
BufSize := Width * Height * FmtInfo.BytesPerPixel; BufSize := Width * Height * FmtInfo.BytesPerPixel;
BufSize := BufSize + BufSize div 2 + 1; BufSize := BufSize + BufSize div 2 + 1;
@ -162,7 +143,7 @@ var
1: Dest^ := Src^; 1: Dest^ := Src^;
2: PWord(Dest)^ := PWord(Src)^; 2: PWord(Dest)^ := PWord(Src)^;
3: PColor24Rec(Dest)^ := PColor24Rec(Src)^; 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
4: PLongWord(Dest)^ := PLongWord(Src)^; 4: PUInt32(Dest)^ := PUInt32(Src)^;
end; end;
Inc(Src, Bpp); Inc(Src, Bpp);
Inc(Dest, Bpp); Inc(Dest, Bpp);
@ -180,7 +161,7 @@ var
1: Dest^ := Src^; 1: Dest^ := Src^;
2: PWord(Dest)^ := PWord(Src)^; 2: PWord(Dest)^ := PWord(Src)^;
3: PColor24Rec(Dest)^ := PColor24Rec(Src)^; 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
4: PLongWord(Dest)^ := PLongWord(Src)^; 4: PUInt32(Dest)^ := PUInt32(Src)^;
end; end;
Inc(Dest, Bpp); Inc(Dest, Bpp);
end; end;
@ -188,7 +169,7 @@ var
end; end;
end; end;
// set position in source to real end of compressed data // 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); smFromCurrent);
FreeMem(Buffer); FreeMem(Buffer);
end; end;
@ -340,8 +321,8 @@ var
function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt; function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt;
var var
Pixel: LongWord; Pixel: UInt32;
NextPixel: LongWord; NextPixel: UInt32;
N: LongInt; N: LongInt;
begin begin
N := 0; N := 0;
@ -356,7 +337,7 @@ var
1: Pixel := Data^; 1: Pixel := Data^;
2: Pixel := PWord(Data)^; 2: Pixel := PWord(Data)^;
3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^; 3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
4: Pixel := PLongWord(Data)^; 4: Pixel := PUInt32(Data)^;
end; end;
while PixelCount > 1 do while PixelCount > 1 do
begin begin
@ -365,7 +346,7 @@ var
1: NextPixel := Data^; 1: NextPixel := Data^;
2: NextPixel := PWord(Data)^; 2: NextPixel := PWord(Data)^;
3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^; 3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
4: NextPixel := PLongWord(Data)^; 4: NextPixel := PUInt32(Data)^;
end; end;
if NextPixel = Pixel then if NextPixel = Pixel then
Break; Break;
@ -381,8 +362,8 @@ var
function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt; function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt;
var var
Pixel: LongWord; Pixel: UInt32;
NextPixel: LongWord; NextPixel: UInt32;
N: LongInt; N: LongInt;
begin begin
N := 1; N := 1;
@ -392,7 +373,7 @@ var
1: Pixel := Data^; 1: Pixel := Data^;
2: Pixel := PWord(Data)^; 2: Pixel := PWord(Data)^;
3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^; 3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
4: Pixel := PLongWord(Data)^; 4: Pixel := PUInt32(Data)^;
end; end;
PixelCount := PixelCount - 1; PixelCount := PixelCount - 1;
while PixelCount > 0 do while PixelCount > 0 do
@ -402,7 +383,7 @@ var
1: NextPixel := Data^; 1: NextPixel := Data^;
2: NextPixel := PWord(Data)^; 2: NextPixel := PWord(Data)^;
3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^; 3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
4: NextPixel := PLongWord(Data)^; 4: NextPixel := PUInt32(Data)^;
end; end;
if NextPixel <> Pixel then if NextPixel <> Pixel then
Break; Break;
@ -413,7 +394,7 @@ var
end; end;
procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest: procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest:
PByte; var Written: LongInt); PByte; out Written: LongInt);
const const
MaxRun = 128; MaxRun = 128;
var var
@ -451,7 +432,7 @@ var
1: Dest^ := Data^; 1: Dest^ := Data^;
2: PWord(Dest)^ := PWord(Data)^; 2: PWord(Dest)^ := PWord(Data)^;
3: PColor24Rec(Dest)^ := PColor24Rec(Data)^; 3: PColor24Rec(Dest)^ := PColor24Rec(Data)^;
4: PLongWord(Dest)^ := PLongWord(Data)^; 4: PUInt32(Dest)^ := PUInt32(Data)^;
end; end;
Inc(Data, Bpp); Inc(Data, Bpp);
Inc(Dest, 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains basic types and constants used by Imaging library.} { This unit contains basic types and constants used by Imaging library.}
@ -37,9 +20,7 @@ const
{ Current Major version of Imaging.} { Current Major version of Imaging.}
ImagingVersionMajor = 0; ImagingVersionMajor = 0;
{ Current Minor version of Imaging.} { Current Minor version of Imaging.}
ImagingVersionMinor = 26; ImagingVersionMinor = 82;
{ Current patch of Imaging.}
ImagingVersionPatch = 4;
{ Imaging Option Ids whose values can be set/get by SetOption/ { Imaging Option Ids whose values can be set/get by SetOption/
GetOption functions.} GetOption functions.}
@ -88,7 +69,7 @@ const
Default value is 5.} Default value is 5.}
ImagingPNGPreFilter = 25; ImagingPNGPreFilter = 25;
{ Sets ZLib compression level used when saving PNG images. { 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.} Default value is 5.}
ImagingPNGCompressLevel = 26; ImagingPNGCompressLevel = 26;
{ Boolean option that specifies whether PNG images with more frames (APNG format) { 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). raw frames are loaded and sent to user (if you want to animate APNG yourself).
Default value is 1.} Default value is 1.}
ImagingPNGLoadAnimated = 27; 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 { Specifies whether MNG animation frames are saved with lossy or lossless
compression. Lossless frames are saved as PNG images and lossy frames are compression. Lossless frames are saved as PNG images and lossy frames are
saved as JNG images. Allowed values are 0 (False) and 1 (True). saved as JNG images. Allowed values are 0 (False) and 1 (True).
Default value is 0.} Default value is 0.}
ImagingMNGLossyCompression = 28; ImagingMNGLossyCompression = 32;
{ Defines whether alpha channel of lossy compressed MNG frames { Defines whether alpha channel of lossy compressed MNG frames
(when ImagingMNGLossyCompression is 1) is lossy compressed too. (when ImagingMNGLossyCompression is 1) is lossy compressed too.
Allowed values are 0 (False) and 1 (True). Default value is 0.} 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. { Sets precompression filter used when saving MNG frames as PNG images.
For details look at ImagingPNGPreFilter.} For details look at ImagingPNGPreFilter.}
ImagingMNGPreFilter = 30; ImagingMNGPreFilter = 34;
{ Sets ZLib compression level used when saving MNG frames as PNG images. { Sets ZLib compression level used when saving MNG frames as PNG images.
For details look at ImagingPNGCompressLevel.} For details look at ImagingPNGCompressLevel.}
ImagingMNGCompressLevel = 31; ImagingMNGCompressLevel = 35;
{ Specifies compression quality used when saving MNG frames as JNG images. { Specifies compression quality used when saving MNG frames as JNG images.
For details look at ImagingJpegQuality.} For details look at ImagingJpegQuality.}
ImagingMNGQuality = 32; ImagingMNGQuality = 36;
{ Specifies whether images are saved in progressive format when saving MNG { Specifies whether images are saved in progressive format when saving MNG
frames as JNG images. For details look at ImagingJpegProgressive.} frames as JNG images. For details look at ImagingJpegProgressive.}
ImagingMNGProgressive = 33; ImagingMNGProgressive = 37;
{ Specifies whether alpha channels of JNG images are lossy compressed. { Specifies whether alpha channels of JNG images are lossy compressed.
Allowed values are 0 (False) and 1 (True). Default value is 0.} 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. { Specifies whether JNG images are saved in progressive format.
For details look at ImagingJpegProgressive.} For details look at ImagingJpegProgressive.}
ImagingJNGProgressive = 44; ImagingJNGProgressive = 44;
{ Specifies whether PGM files are stored in text or in binary format. { 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). Allowed values are 0 (store as text - very! large files) and 1 (save binary).
Default value is 1.} Default value is 1.}
ImagingPGMSaveBinary = 50; ImagingPGMSaveBinary = 50;
{ Specifies whether PPM files are stored in text or in binary format. { 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). Allowed values are 0 (store as text - very! large files) and 1 (save binary).
Default value is 1.} Default value is 1.}
ImagingPPMSaveBinary = 51; ImagingPPMSaveBinary = 51;
{ Boolean option that specifies whether GIF images with more frames { Boolean option that specifies whether GIF images with more frames
are animated by Imaging (according to frame disposal methods) or just 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). 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 format). Mask is 'anded' (bitwise AND) with every pixel's
channel value when creating color histogram. If $FF is used channel value when creating color histogram. If $FF is used
all 8bits of color channels are used which can result in very 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 use lower masks to speed it up (FC, F8 and F0 are good
choices). Allowed values are in range <0, $FF> and default is choices). Allowed values are in range <0, $FF> and default is
$FE. } $FE. }
ImagingColorReductionMask = 128; ImagingColorReductionMask = 128;
{ This option can be used to override image data format during image { This option can be used to override image data format during image
loading. If set to format different from ifUnknown all loaded images 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 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 range <Ord(Low(TImageFormat)), Ord(High(TImageFormat))> and
default value is ifUnknown.} default value is ifUnknown.}
ImagingLoadOverrideFormat = 129; ImagingLoadOverrideFormat = 129;
{ This option can be used to override image data format during image { This option can be used to override image data format during image
saving. If set to format different from ifUnknown all images 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 Note that image file formats support only a subset of Imaging data formats
so final saved file may in different format than this override. so final saved file may in different format than this override.
Allowed values are in range <Ord(Low(TImageFormat)), Ord(High(TImageFormat))> Allowed values are in range <Ord(Low(TImageFormat)), Ord(High(TImageFormat))>
@ -182,6 +170,10 @@ const
<Ord(Low(ImagingFormats.TSamplingFilter)), Ord(High(ImagingFormats.TSamplingFilter))> <Ord(Low(ImagingFormats.TSamplingFilter)), Ord(High(ImagingFormats.TSamplingFilter))>
and default value is 1 (linear filter).} and default value is 1 (linear filter).}
ImagingMipMapFilter = 131; 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.} { Returned by GetOption if given Option Id is invalid.}
InvalidOption = -$7FFFFFFF; InvalidOption = -$7FFFFFFF;
@ -195,22 +187,42 @@ const
ChannelAlpha = 3; ChannelAlpha = 3;
type 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, { Enum defining image data format. In formats with more channels,
first channel after "if" is stored in the most significant bits and channel first channel after "if" is stored in the most significant bits and channel
before end is stored in the least significant.} before end is stored in the least significant.}
TImageFormat = ( TImageFormat = (
ifUnknown = 0, ifUnknown = 0,
ifDefault = 1, ifDefault = 1,
{ Indexed formats using palette.} { Indexed formats using palette }
ifIndex8 = 10, ifIndex8 = 10,
{ Grayscale/Luminance formats.} { Grayscale/Luminance formats }
ifGray8 = 40, ifGray8 = 40,
ifA8Gray8 = 41, ifA8Gray8 = 41,
ifGray16 = 42, ifGray16 = 42,
ifGray32 = 43, ifGray32 = 43,
ifGray64 = 44, ifGray64 = 44,
ifA16Gray16 = 45, ifA16Gray16 = 45,
{ ARGB formats.} { ARGB formats }
ifX5R1G1B1 = 80, ifX5R1G1B1 = 80,
ifR3G3B2 = 81, ifR3G3B2 = 81,
ifR5G6B5 = 82, ifR5G6B5 = 82,
@ -225,23 +237,35 @@ type
ifA16R16G16B16 = 91, ifA16R16G16B16 = 91,
ifB16G16R16 = 92, ifB16G16R16 = 92,
ifA16B16G16R16 = 93, ifA16B16G16R16 = 93,
{ Floating point formats.} { Floating point formats }
ifR32F = 170, ifR32F = 160,
ifA32R32G32B32F = 171, ifA32R32G32B32F = 161,
ifA32B32G32R32F = 172, ifA32B32G32R32F = 162,
ifR16F = 173, ifR16F = 163,
ifA16R16G16B16F = 174, ifA16R16G16B16F = 164,
ifA16B16G16R16F = 175, ifA16B16G16R16F = 165,
{ Special formats.} ifR32G32B32F = 166,
ifDXT1 = 220, ifB32G32R32F = 167,
ifDXT3 = 221, { Special formats }
ifDXT5 = 222, ifDXT1 = 200,
ifBTC = 223, ifDXT3 = 201,
ifATI1N = 224, ifDXT5 = 202,
ifATI2N = 225); 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.} { Color value for 32 bit images.}
TColor32 = LongWord; TColor32 = UInt32;
PColor32 = ^TColor32; PColor32 = ^TColor32;
{ Color value for 64 bit images.} { Color value for 64 bit images.}
@ -296,12 +320,24 @@ type
TColor64RecArray = array[0..MaxInt div SizeOf(TColor64Rec) - 1] of TColor64Rec; TColor64RecArray = array[0..MaxInt div SizeOf(TColor64Rec) - 1] of TColor64Rec;
PColor64RecArray = ^TColor64RecArray; 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 { Color record for 128 bit floating point images, which allows access to
individual color channels.} individual color channels.}
TColorFPRec = packed record TColorFPRec = packed record
case LongInt of case LongInt of
0: (B, G, R, A: Single); 0: (B, G, R, A: Single);
1: (Channels: array[0..3] of Single); 1: (Channels: array[0..3] of Single);
2: (Color96Rec: TColor96FPRec);
end; end;
PColorFPRec = ^TColorFPRec; PColorFPRec = ^TColorFPRec;
TColorFPRecArray = array[0..MaxInt div SizeOf(TColorFPRec) - 1] of TColorFPRec; TColorFPRecArray = array[0..MaxInt div SizeOf(TColorFPRec) - 1] of TColorFPRec;
@ -341,6 +377,7 @@ type
Size: LongInt; // Size of image bits in Bytes Size: LongInt; // Size of image bits in Bytes
Bits: Pointer; // Pointer to memory containing image bits Bits: Pointer; // Pointer to memory containing image bits
Palette: PPalette32; // Image palette for indexed images Palette: PPalette32; // Image palette for indexed images
Tag: Pointer; // User data
end; end;
PImageData = ^TImageData; PImageData = ^TImageData;
@ -348,7 +385,7 @@ type
image formats.} image formats.}
TPixelFormatInfo = packed record TPixelFormatInfo = packed record
ABitCount, RBitCount, GBitCount, BBitCount: Byte; ABitCount, RBitCount, GBitCount, BBitCount: Byte;
ABitMask, RBitMask, GBitMask, BBitMask: LongWord; ABitMask, RBitMask, GBitMask, BBitMask: UInt32;
AShift, RShift, GShift, BShift: Byte; AShift, RShift, GShift, BShift: Byte;
ARecDiv, RRecDiv, GRecDiv, BRecDiv: Byte; ARecDiv, RRecDiv, GRecDiv, BRecDiv: Byte;
end; end;
@ -400,6 +437,9 @@ type
// format does not exist // format does not exist
IsIndexed: Boolean; // True if image uses palette IsIndexed: Boolean; // True if image uses palette
IsSpecial: Boolean; // True if image is in special format 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 PixelFormat: PPixelFormatInfo; // Pixel format structure
GetPixelsSize: TFormatGetPixelsSizeFunc; // Returns size in bytes of GetPixelsSize: TFormatGetPixelsSizeFunc; // Returns size in bytes of
// Width * Height pixels of image // Width * Height pixels of image
@ -427,7 +467,8 @@ type
TResizeFilter = ( TResizeFilter = (
rfNearest = 0, rfNearest = 0,
rfBilinear = 1, rfBilinear = 1,
rfBicubic = 2); rfBicubic = 2,
rfLanczos = 3);
{ Seek origin mode for IO function Seek.} { Seek origin mode for IO function Seek.}
TSeekMode = ( TSeekMode = (
@ -435,16 +476,22 @@ type
smFromCurrent = 1, smFromCurrent = 1,
smFromEnd = 2); 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.} { IO functions used for reading and writing images from/to input/output.}
TOpenReadProc = function(Source: PChar): TImagingHandle; cdecl; TOpenProc = function(Source: PChar; Mode: TOpenMode): TImagingHandle; cdecl;
TOpenWriteProc = function(Source: PChar): TImagingHandle; cdecl;
TCloseProc = procedure(Handle: TImagingHandle); cdecl; TCloseProc = procedure(Handle: TImagingHandle); cdecl;
TEofProc = function(Handle: TImagingHandle): Boolean; cdecl; TEofProc = function(Handle: TImagingHandle): Boolean; cdecl;
TSeekProc = function(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode): LongInt; cdecl; TSeekProc = function(Handle: TImagingHandle; Offset: Int64; Mode: TSeekMode): Int64; cdecl;
TTellProc = function(Handle: TImagingHandle): LongInt; cdecl; TTellProc = function(Handle: TImagingHandle): Int64; cdecl;
TReadProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl; TReadProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
TWriteProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl; TWriteProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
implementation implementation
{ {
@ -453,6 +500,24 @@ implementation
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- add lookup tables to pixel formats for fast conversions - 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 --------------------------------- -- 0.24.3 Changes/Bug Fixes ---------------------------------
- Added ifATI1N and ifATI2N image data formats. - Added ifATI1N and ifATI2N image data formats.

602
Imaging/ImagingUtility.pas
View File

@ -1,29 +1,12 @@
{ {
$Id: ImagingUtility.pas 175 2009-10-06 11:55:15Z galfar $
Vampyre Imaging Library Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net https://github.com/galfar/imaginglib
https://imaginglib.sourceforge.io
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 This Source Code Form is subject to the terms of the Mozilla Public
in compliance with the License. You may obtain a copy of the License at License, v. 2.0. If a copy of the MPL was not distributed with this
http://www.mozilla.org/MPL/MPL-1.1.html file, You can obtain one at https://mozilla.org/MPL/2.0.
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
Alternatively, the contents of this file may be used under the terms of the
GNU Lesser General Public License (the "LGPL License"), in which case the
provisions of the LGPL License are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the LGPL License and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the LGPL
License. If you do not delete the provisions above, a recipient may use
your version of this file under either the MPL or the LGPL License.
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
} }
{ This unit contains utility functions and types for Imaging library.} { This unit contains utility functions and types for Imaging library.}
@ -41,14 +24,21 @@ const
SFalse = 'False'; SFalse = 'False';
type 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; TByteArray = array[0..MaxInt - 1] of Byte;
PByteArray = ^TByteArray; PByteArray = ^TByteArray;
TWordArray = array[0..MaxInt div 2 - 1] of Word; TWordArray = array[0..MaxInt div 2 - 1] of Word;
PWordArray = ^TWordArray; PWordArray = ^TWordArray;
TLongIntArray = array[0..MaxInt div 4 - 1] of LongInt; TUInt32Array = array[0..MaxInt div 4 - 1] of UInt32;
PLongIntArray = ^TLongIntArray; PUInt32Array = ^TUInt32Array;
TLongWordArray = array[0..MaxInt div 4 - 1] of LongWord;
PLongWordArray = ^TLongWordArray;
TInt64Array = array[0..MaxInt div 8 - 1] of Int64; TInt64Array = array[0..MaxInt div 8 - 1] of Int64;
PInt64Array = ^TInt64Array; PInt64Array = ^TInt64Array;
TSingleArray = array[0..MaxInt div 4 - 1] of Single; TSingleArray = array[0..MaxInt div 4 - 1] of Single;
@ -59,6 +49,7 @@ type
TDynByteArray = array of Byte; TDynByteArray = array of Byte;
TDynIntegerArray = array of Integer; TDynIntegerArray = array of Integer;
TDynBooleanArray = array of Boolean; TDynBooleanArray = array of Boolean;
TDynStringArray = array of string;
TWordRec = packed record TWordRec = packed record
case Integer of case Integer of
@ -69,22 +60,22 @@ type
TWordRecArray = array[0..MaxInt div 2 - 1] of TWordRec; TWordRecArray = array[0..MaxInt div 2 - 1] of TWordRec;
PWordRecArray = ^TWordRecArray; PWordRecArray = ^TWordRecArray;
TLongWordRec = packed record TUInt32Rec = packed record
case Integer of case Integer of
0: (LongWordValue: LongWord); 0: (UInt32Value: UInt32);
1: (Low, High: Word); 1: (Low, High: Word);
{ Array variants - Index 0 means lowest significant byte (word, ...).} { Array variants - Index 0 means lowest significant byte (word, ...).}
2: (Words: array[0..1] of Word); 2: (Words: array[0..1] of Word);
3: (Bytes: array[0..3] of Byte); 3: (Bytes: array[0..3] of Byte);
end; end;
PLongWordRec = ^TLongWordRec; PUInt32Rec = ^TUInt32Rec;
TLongWordRecArray = array[0..MaxInt div 4 - 1] of TLongWordRec; TUInt32RecArray = array[0..MaxInt div 4 - 1] of TUInt32Rec;
PLongWordRecArray = ^TLongWordRecArray; PUInt32RecArray = ^TUInt32RecArray;
TInt64Rec = packed record TInt64Rec = packed record
case Integer of case Integer of
0: (Int64Value: Int64); 0: (Int64Value: Int64);
1: (Low, High: LongWord); 1: (Low, High: UInt32);
{ Array variants - Index 0 means lowest significant byte (word, ...).} { Array variants - Index 0 means lowest significant byte (word, ...).}
2: (Words: array[0..3] of Word); 2: (Words: array[0..3] of Word);
3: (Bytes: array[0..7] of Byte); 3: (Bytes: array[0..7] of Byte);
@ -94,16 +85,32 @@ type
PInt64RecArray = ^TInt64RecArray; PInt64RecArray = ^TInt64RecArray;
TFloatHelper = record TFloatHelper = record
Data1: Int64; Data: Int64;
Data2: Int64; case Integer of
0: (Data64: Int64);
1: (Data32: UInt32);
end; end;
PFloatHelper = ^TFloatHelper; PFloatHelper = ^TFloatHelper;
TFloatPoint = record
X, Y: Single;
end;
TFloatRect = record
Left, Top, Right, Bottom: Single;
end;
TChar2 = array[0..1] of AnsiChar; TChar2 = array[0..1] of AnsiChar;
TChar3 = array[0..2] of AnsiChar; TChar3 = array[0..2] of AnsiChar;
TChar4 = array[0..3] of AnsiChar; TChar4 = array[0..3] of AnsiChar;
TChar8 = array[0..7] of AnsiChar; TChar8 = array[0..7] of AnsiChar;
TChar16 = array[0..15] of AnsiChar; TChar16 = array[0..15] of AnsiChar;
TAnsiCharSet = set of AnsiChar;
ENotImplemented = class(Exception)
public
constructor Create;
end;
{ Options for BuildFileList function: { Options for BuildFileList function:
flFullNames - file names in result will have full path names 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} function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns time value with microsecond resolution.} { Returns time value with microsecond resolution.}
function GetTimeMicroseconds: Int64; function GetTimeMicroseconds: Int64;
{ Returns time value with milisecond resolution.} { Returns time value with millisecond resolution.}
function GetTimeMilliseconds: Int64; function GetTimeMilliseconds: Int64;
{ Returns file extension (without "." dot)} { Returns file extension (without "." dot)}
function GetFileExt(const FileName: string): string; function GetFileExt(const FileName: string): string;
{ Returns file name of application's executable.} { Returns file name of application's executable.}
function GetAppExe: string; 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.} path delimiter at the end.}
function GetAppDir: string; 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 Mask can contain ? and * special characters: ? matches
one character, * matches zero or more characters.} 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 { This function fills Files string list with names of files found
with FindFirst/FindNext functions (See details on Path/Atrr here). with FindFirst/FindNext functions (See details on Path/Atrr here).
- BuildFileList('c:\*.*', faAnyFile, List, [flRecursive]) returns - 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; function BuildFileList(Path: string; Attr: LongInt; Files: TStrings;
Options: TFileListOptions = []): Boolean; Options: TFileListOptions = []): Boolean;
{ Similar to RTL's Pos function but with optional Offset where search will start. { 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; function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
{ Same as PosEx but without case sensitivity.} { Same as PosEx but without case sensitivity.}
function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} 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 { Fills instance of TStrings with tokens from string S where tokens are separated by
one of Seps characters.} one of Seps characters.}
procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings); 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} 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} 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>} { Clamps integer value to range <Min, Max>}
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} 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.} { Returns True if Num is power of 2.}
function IsPow2(Num: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} function IsPow2(Num: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns next power of 2 greater than or equal to Num { 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} function NextPow2(Num: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Raises 2 to the given integer power (in range [0, 30]).} { Raises 2 to the given integer power (in range [0, 30]).}
function Pow2Int(Exponent: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} 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} function Log2Int(X: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns log base 2 of X.} { Returns log base 2 of X.}
function Log2(X: Single): Single; 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).} { Returns largest integer <= Val (for 5.9 returns 5).}
function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns smallest integer >= Val (for 5.1 returns 6).} { 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.} { Returns greater of two integer numbers.}
function Max(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} function Max(A, B: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns greater of two float numbers.} { 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. { Returns result from multiplying Number by Numerator and then dividing by Denominator.
Denominator must be greater than 0.} Denominator must be greater than 0.}
function MulDiv(Number, Numerator, Denominator: Word): Word; {$IFDEF USE_INLINE}inline;{$ENDIF} 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.} { Switches Boolean value.}
procedure Switch(var Value: Boolean); {$IFDEF USE_INLINE}inline;{$ENDIF} 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.} FalsePart is returned.}
function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} function Iff(Condition: Boolean; TruePart, FalsePart: Integer): Integer; 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.} FalsePart is returned.}
function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} function IffUnsigned(Condition: Boolean; TruePart, FalsePart: Cardinal): Cardinal; 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.} FalsePart is returned.}
function Iff(Condition, TruePart, FalsePart: Boolean): Boolean; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} 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.} FalsePart is returned.}
function Iff(Condition: Boolean; const TruePart, FalsePart: string): string; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} 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.} FalsePart is returned.}
function Iff(Condition: Boolean; TruePart, FalsePart: Char): Char; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} 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.} FalsePart is returned.}
function Iff(Condition: Boolean; TruePart, FalsePart: Pointer): Pointer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} 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.} FalsePart is returned.}
function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} 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.} FalsePart is returned.}
function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} 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} { Swaps two Byte values}
procedure SwapValues(var A, B: Byte); overload; procedure SwapValues(var A, B: Byte); overload;
{ Swaps two Word values} { Swaps two Word values}
procedure SwapValues(var A, B: Word); overload; 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} { Swaps two LongInt values}
procedure SwapValues(var A, B: LongInt); overload; procedure SwapValues(var A, B: LongInt); overload;
{$ENDIF}
{ Swaps two Single values} { Swaps two Single values}
procedure SwapValues(var A, B: Single); overload; 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} procedure SwapMin(var Min, Max: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
{ This function returns True if running on little endian machine.} { This function returns True if running on little endian machine.}
function IsLittleEndian: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} 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} function SwapEndianWord(Value: Word): Word; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Swaps byte order of multiple Word values.} { Swaps byte order of multiple Word values.}
procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload; procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload;
{ Swaps byte order of LongWord value.} { Swaps byte order of UInt32 value.}
function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF} function SwapEndianUInt32(Value: UInt32): UInt32; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Swaps byte order of multiple LongWord values.} { Swaps byte order of multiple UInt32 values.}
procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload; procedure SwapEndianUInt32(P: PUInt32; Count: LongInt); overload;
{ Calculates CRC32 for the given data.} { 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.} { Fills given memory with given Byte value. Size is size of buffer in bytes.}
procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte); procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte);
{ Fills given memory with given Word value. Size is size of buffer in bytes.} { Fills given memory with given Word value. Size is size of buffer in bytes.}
procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word); procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
{ Fills given memory with given LongWord value. Size is size of buffer in bytes.} { Fills given memory with given UInt32 value. Size is size of buffer in bytes.}
procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord); 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.} { Returns how many mipmap levels can be created for image of given size.}
function GetNumMipMapLevels(Width, Height: LongInt): LongInt; 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 { Scales one rectangle to fit into another. Proportions are preserved so
it could be used for 'Stretch To Fit Window' image drawing for instance.} it could be used for 'Stretch To Fit Window' image drawing for instance.}
function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect; 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.} { Returns True if R1 fits into R2.}
function RectInRect(const R1, R2: TRect): Boolean; function RectInRect(const R1, R2: TRect): Boolean;
{ Returns True if R1 and R2 intersects.} { Returns True if R1 and R2 intersects.}
function RectIntersects(const R1, R2: TRect): Boolean; 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 { Formats given message for usage in Exception.Create(..). Use only
in except block - returned message contains message of last raised exception.} 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 implementation
uses uses
{$IFDEF MSWINDOWS} {$IF Defined(MSWINDOWS)}
Windows; Windows;
{$ENDIF} {$ELSEIF Defined(FPC)}
{$IFDEF UNIX}
{$IFDEF KYLIX}
Libc;
{$ELSE}
Dos, BaseUnix, Unix; Dos, BaseUnix, Unix;
{$ENDIF} {$ELSEIF Defined(DELPHI)}
{$ENDIF} Posix.SysTime;
{$IFEND}
var
FloatFormatSettings: TFormatSettings;
constructor ENotImplemented.Create;
begin
inherited Create('Not implemented');
end;
procedure FreeAndNil(var Obj); procedure FreeAndNil(var Obj);
var var
@ -337,10 +410,10 @@ begin
Result := Exception(ExceptObject); Result := Exception(ExceptObject);
end; end;
{$IFDEF MSWINDOWS} {$IF Defined(MSWINDOWS)}
var var
PerfFrequency: Int64; PerfFrequency: Int64;
InvPerfFrequency: Single; InvPerfFrequency: Extended;
function GetTimeMicroseconds: Int64; function GetTimeMicroseconds: Int64;
var var
@ -349,56 +422,23 @@ begin
QueryPerformanceCounter(Time); QueryPerformanceCounter(Time);
Result := Round(1000000 * InvPerfFrequency * Time); Result := Round(1000000 * InvPerfFrequency * Time);
end; end;
{$ENDIF} {$ELSEIF Defined(DELPHI)}
function GetTimeMicroseconds: Int64;
{$IFDEF UNIX} 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; function GetTimeMicroseconds: Int64;
var var
TimeVal: TTimeVal; TimeVal: TTimeVal;
begin begin
{$IFDEF KYLIX}
GetTimeOfDay(TimeVal, nil);
{$ELSE}
fpGetTimeOfDay(@TimeVal, nil); fpGetTimeOfDay(@TimeVal, nil);
{$ENDIF}
Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec; Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec;
end; end;
{$ENDIF} {$IFEND}
{$IFDEF MSDOS}
function GetTimeMicroseconds: Int64;
asm
XOR EAX, EAX
CLI
OUT $43, AL
MOV EDX, FS:[$46C]
IN AL, $40
DB $EB, 0, $EB, 0, $EB, 0
MOV AH, AL
IN AL, $40
DB $EB, 0, $EB, 0, $EB, 0
XCHG AL, AH
NEG AX
MOVZX EDI, AX
STI
MOV EBX, $10000
MOV EAX, EDX
XOR EDX, EDX
MUL EBX
ADD EAX, EDI
ADC EDX, 0
PUSH EDX
PUSH EAX
MOV ECX, $82BF1000
MOVZX EAX, WORD PTR FS:[$470]
MUL ECX
MOV ECX, EAX
POP EAX
POP EDX
ADD EAX, ECX
ADC EDX, 0
end;
{$ENDIF}
function GetTimeMilliseconds: Int64; function GetTimeMilliseconds: Int64;
begin begin
@ -413,29 +453,22 @@ begin
end; end;
function GetAppExe: string; function GetAppExe: string;
{$IFDEF MSWINDOWS} {$IF Defined(MSWINDOWS)}
var var
FileName: array[0..MAX_PATH] of Char; FileName: array[0..MAX_PATH] of Char;
begin begin
SetString(Result, FileName, SetString(Result, FileName,
Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName))); Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
{$ENDIF} {$ELSEIF Defined(DELPHI)} // Delphi non Win targets
{$IFDEF UNIX}
{$IFDEF KYLIX}
var var
FileName: array[0..FILENAME_MAX] of Char; FileName: array[0..1024] of Char;
begin begin
SetString(Result, FileName, SetString(Result, FileName,
System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName))); System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
{$ELSE} {$ELSE}
begin begin
Result := FExpand(ParamStr(0)); Result := ExpandFileName(ParamStr(0));
{$ENDIF} {$IFEND}
{$ENDIF}
{$IFDEF MSDOS}
begin
Result := ParamStr(0);
{$ENDIF}
end; end;
function GetAppDir: string; function GetAppDir: string;
@ -443,7 +476,28 @@ begin
Result := ExtractFileDir(GetAppExe); Result := ExtractFileDir(GetAppExe);
end; 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 var
MaskLen, KeyLen : LongInt; MaskLen, KeyLen : LongInt;
@ -486,7 +540,7 @@ var
Exit; Exit;
end; end;
else else
if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then if not CharMatch(Mask[MaskPos], Subject[KeyPos]) then
begin begin
Result := False; Result := False;
Exit; Exit;
@ -499,7 +553,7 @@ var
end; end;
end; end;
while (MaskPos <= MaskLen) and (Mask[MaskPos] in ['?', '*']) do while (MaskPos <= MaskLen) and (AnsiChar(Mask[MaskPos]) in ['?', '*']) do
Inc(MaskPos); Inc(MaskPos);
if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then
begin begin
@ -512,7 +566,7 @@ var
begin begin
MaskLen := Length(Mask); MaskLen := Length(Mask);
KeyLen := Length(FileName); KeyLen := Length(Subject);
if MaskLen = 0 then if MaskLen = 0 then
begin begin
Result := True; Result := True;
@ -707,6 +761,58 @@ begin
Result := Format('%.' + IntToStr(Precision) + 'n', [F]); Result := Format('%.' + IntToStr(Precision) + 'n', [F]);
end; 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; function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
begin begin
Result := Number; Result := Number;
@ -810,23 +916,48 @@ begin
end; end;
function Log2(X: Single): Single; function Log2(X: Single): Single;
{$IFDEF USE_ASM}
asm
FLD1
FLD X
FYL2X
FWAIT
end;
{$ELSE}
const const
Ln2: Single = 0.6931471; Ln2: Single = 0.6931471;
begin begin
Result := Ln(X) / Ln2; Result := Ln(X) / Ln2;
end; 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; function Floor(Value: Single): LongInt;
begin begin
Result := Trunc(Value); Result := Trunc(Value);
if Frac(Value) < 0.0 then if Value < Result then
Dec(Result); Dec(Result);
end; end;
function Ceil(Value: Single): LongInt; function Ceil(Value: Single): LongInt;
begin begin
Result := Trunc(Value); Result := Trunc(Value);
if Frac(Value) > 0.0 then if Value > Result then
Inc(Result); Inc(Result);
end; end;
@ -835,7 +966,7 @@ begin
Value := not Value; Value := not Value;
end; end;
function Iff(Condition: Boolean; TruePart, FalsePart: LongInt): LongInt; function Iff(Condition: Boolean; TruePart, FalsePart: Integer): Integer;
begin begin
if Condition then if Condition then
Result := TruePart Result := TruePart
@ -843,7 +974,7 @@ begin
Result := FalsePart; Result := FalsePart;
end; end;
function IffUnsigned(Condition: Boolean; TruePart, FalsePart: LongWord): LongWord; function IffUnsigned(Condition: Boolean; TruePart, FalsePart: Cardinal): Cardinal;
begin begin
if Condition then if Condition then
Result := TruePart Result := TruePart
@ -899,6 +1030,15 @@ begin
Result := FalsePart; Result := FalsePart;
end; end;
procedure SwapValues(var A, B: Boolean);
var
Tmp: Boolean;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure SwapValues(var A, B: Byte); procedure SwapValues(var A, B: Byte);
var var
Tmp: Byte; Tmp: Byte;
@ -917,6 +1057,16 @@ begin
B := Tmp; B := Tmp;
end; 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); procedure SwapValues(var A, B: LongInt);
var var
Tmp: LongInt; Tmp: LongInt;
@ -925,6 +1075,7 @@ begin
A := B; A := B;
B := Tmp; B := Tmp;
end; end;
{$ENDIF}
procedure SwapValues(var A, B: Single); procedure SwapValues(var A, B: Single);
var var
@ -979,6 +1130,14 @@ begin
Result := B; Result := B;
end; 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; function MulDiv(Number, Numerator, Denominator: Word): Word;
{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))} {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
asm asm
@ -991,6 +1150,16 @@ begin
end; end;
{$IFEND} {$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; function IsLittleEndian: Boolean;
var var
W: Word; W: Word;
@ -1036,21 +1205,21 @@ begin
end; end;
{$ENDIF} {$ENDIF}
function SwapEndianLongWord(Value: LongWord): LongWord; function SwapEndianUInt32(Value: UInt32): UInt32;
{$IF Defined(USE_ASM) and (not Defined(USE_INLINE))} {$IF Defined(USE_ASM) and (not Defined(USE_INLINE))}
asm asm
BSWAP EAX BSWAP EAX
end; end;
{$ELSE} {$ELSE}
begin begin
TLongWordRec(Result).Bytes[0] := TLongWordRec(Value).Bytes[3]; TUInt32Rec(Result).Bytes[0] := TUInt32Rec(Value).Bytes[3];
TLongWordRec(Result).Bytes[1] := TLongWordRec(Value).Bytes[2]; TUInt32Rec(Result).Bytes[1] := TUInt32Rec(Value).Bytes[2];
TLongWordRec(Result).Bytes[2] := TLongWordRec(Value).Bytes[1]; TUInt32Rec(Result).Bytes[2] := TUInt32Rec(Value).Bytes[1];
TLongWordRec(Result).Bytes[3] := TLongWordRec(Value).Bytes[0]; TUInt32Rec(Result).Bytes[3] := TUInt32Rec(Value).Bytes[0];
end; end;
{$IFEND} {$IFEND}
procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); procedure SwapEndianUInt32(P: PUInt32; Count: LongInt);
{$IFDEF USE_ASM} {$IFDEF USE_ASM}
asm asm
@Loop: @Loop:
@ -1064,21 +1233,21 @@ end;
{$ELSE} {$ELSE}
var var
I: LongInt; I: LongInt;
Temp: LongWord; Temp: UInt32;
begin begin
for I := 0 to Count - 1 do for I := 0 to Count - 1 do
begin begin
Temp := PLongWordArray(P)[I]; Temp := PUInt32Array(P)[I];
TLongWordRec(PLongWordArray(P)[I]).Bytes[0] := TLongWordRec(Temp).Bytes[3]; TUInt32Rec(PUInt32Array(P)[I]).Bytes[0] := TUInt32Rec(Temp).Bytes[3];
TLongWordRec(PLongWordArray(P)[I]).Bytes[1] := TLongWordRec(Temp).Bytes[2]; TUInt32Rec(PUInt32Array(P)[I]).Bytes[1] := TUInt32Rec(Temp).Bytes[2];
TLongWordRec(PLongWordArray(P)[I]).Bytes[2] := TLongWordRec(Temp).Bytes[1]; TUInt32Rec(PUInt32Array(P)[I]).Bytes[2] := TUInt32Rec(Temp).Bytes[1];
TLongWordRec(PLongWordArray(P)[I]).Bytes[3] := TLongWordRec(Temp).Bytes[0]; TUInt32Rec(PUInt32Array(P)[I]).Bytes[3] := TUInt32Rec(Temp).Bytes[0];
end; end;
end; end;
{$ENDIF} {$ENDIF}
type type
TCrcTable = array[Byte] of LongWord; TCrcTable = array[Byte] of UInt32;
var var
CrcTable: TCrcTable; CrcTable: TCrcTable;
@ -1087,7 +1256,7 @@ const
Polynom = $EDB88320; Polynom = $EDB88320;
var var
I, J: LongInt; I, J: LongInt;
C: LongWord; C: UInt32;
begin begin
for I := 0 to 255 do for I := 0 to 255 do
begin begin
@ -1103,7 +1272,7 @@ begin
end; end;
end; end;
procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt); procedure CalcCrc32(var Crc: UInt32; Data: Pointer; Size: LongInt);
var var
I: LongInt; I: LongInt;
B: PByte; B: PByte;
@ -1174,11 +1343,11 @@ asm
end; end;
{$ELSE} {$ELSE}
var var
I, V: LongWord; I, V: UInt32;
begin begin
V := Value * $10000 + Value; V := Value * $10000 + Value;
for I := 0 to Size div 4 - 1 do for I := 0 to Size div 4 - 1 do
PLongWordArray(Data)[I] := V; PUInt32Array(Data)[I] := V;
case Size mod 4 of case Size mod 4 of
1: PByteArray(Data)[Size - 1] := Lo(Value); 1: PByteArray(Data)[Size - 1] := Lo(Value);
2: PWordArray(Data)[Size div 2] := Value; 2: PWordArray(Data)[Size div 2] := Value;
@ -1191,7 +1360,7 @@ begin
end; end;
{$ENDIF} {$ENDIF}
procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord); procedure FillMemoryUInt32(Data: Pointer; Size: LongInt; Value: UInt32);
{$IFDEF USE_ASM} {$IFDEF USE_ASM}
asm asm
PUSH EDI PUSH EDI
@ -1223,19 +1392,24 @@ var
I: LongInt; I: LongInt;
begin begin
for I := 0 to Size div 4 - 1 do for I := 0 to Size div 4 - 1 do
PLongWordArray(Data)[I] := Value; PUInt32Array(Data)[I] := Value;
case Size mod 4 of case Size mod 4 of
1: PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0]; 1: PByteArray(Data)[Size - 1] := TUInt32Rec(Value).Bytes[0];
2: PWordArray(Data)[Size div 2] := TLongWordRec(Value).Words[0]; 2: PWordArray(Data)[Size div 2] := TUInt32Rec(Value).Words[0];
3: 3:
begin begin
PWordArray(Data)[Size div 2 - 1] := TLongWordRec(Value).Words[0]; PWordArray(Data)[Size div 2 - 1] := TUInt32Rec(Value).Words[0];
PByteArray(Data)[Size - 1] := TLongWordRec(Value).Bytes[0]; PByteArray(Data)[Size - 1] := TUInt32Rec(Value).Bytes[0];
end; end;
end; end;
end; end;
{$ENDIF} {$ENDIF}
procedure ZeroMemory(Data: Pointer; Size: Integer);
begin
FillMemoryByte(Data, Size, 0);
end;
function GetNumMipMapLevels(Width, Height: LongInt): LongInt; function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
begin begin
Result := 0; Result := 0;
@ -1407,6 +1581,27 @@ begin
end; end;
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; function RectInRect(const R1, R2: TRect): Boolean;
begin begin
Result:= Result:=
@ -1425,6 +1620,56 @@ begin
not (R1.Bottom < R2.Top); not (R1.Bottom < R2.Top);
end; 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; function FormatExceptMsg(const Msg: string; const Args: array of const): string;
begin begin
Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args); Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args);
@ -1455,22 +1700,38 @@ initialization
QueryPerformanceFrequency(PerfFrequency); QueryPerformanceFrequency(PerfFrequency);
InvPerfFrequency := 1.0 / PerfFrequency; InvPerfFrequency := 1.0 / PerfFrequency;
{$ENDIF} {$ENDIF}
{$IFDEF MSDOS}
// reset PIT {$IF Defined(DELPHI)}
asm {$IF CompilerVersion >= 23}
MOV EAX, $34 FloatFormatSettings := TFormatSettings.Create('en-US');
OUT $43, AL {$ELSE}
XOR EAX, EAX GetLocaleFormatSettings(1033, FloatFormatSettings);
OUT $40, AL {$IFEND}
OUT $40, AL {$ELSE FPC}
end; FloatFormatSettings := DefaultFormatSettings;
{$ENDIF} FloatFormatSettings.DecimalSeparator := '.';
FloatFormatSettings.ThousandSeparator := ',';
{$IFEND}
{ {
File Notes: File Notes:
-- TODOS ---------------------------------------------------- -- 0.77.1 ----------------------------------------------------
- nothing now - 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 ----------------------------------- -- 0.26.1 Changes/Bug Fixes -----------------------------------
- Some formatting changes. - Some formatting changes.
@ -1521,3 +1782,4 @@ initialization
} }
end. end.

9
Imaging/JpegLib/imjcapimin.pas
View File

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

23
Imaging/JpegLib/imjccolor.pas
View File

@ -24,8 +24,7 @@ implementation
{ Private subobject } { Private subobject }
type type
jTInt32 = 0..Pred(MaxInt div SizeOf(INT32)); INT32_FIELD = array[0..MaxInt div SizeOf(INT32) - 1] of INT32;
INT32_FIELD = array[jTInt32] of INT32;
INT32_FIELD_PTR = ^INT32_FIELD; INT32_FIELD_PTR = ^INT32_FIELD;
type type
@ -232,26 +231,24 @@ begin
while (num_rows > 0) do while (num_rows > 0) do
begin begin
Dec(num_rows); Dec(num_rows);
inptr := input_buf^[0]; inptr := input_buf[0];
Inc(JSAMPROW_PTR(input_buf)); Inc(JSAMPROW_PTR(input_buf));
outptr := output_buf^[0]^[output_row]; outptr := output_buf[0][output_row];
Inc(output_row); Inc(output_row);
for col := 0 to pred(num_cols) do for col := 0 to num_cols - 1 do
begin begin
r := GETJSAMPLE(inptr^[RGB_RED]); r := GETJSAMPLE(inptr[RGB_RED]);
g := GETJSAMPLE(inptr^[RGB_GREEN]); g := GETJSAMPLE(inptr[RGB_GREEN]);
b := GETJSAMPLE(inptr^[RGB_BLUE]); b := GETJSAMPLE(inptr[RGB_BLUE]);
Inc(JSAMPLE_PTR(inptr), RGB_PIXELSIZE); Inc(JSAMPLE_PTR(inptr), RGB_PIXELSIZE);
(* Y *) (* Y *)
// kylix 3 compiler crashes on this // kylix 3 compiler crashes on this
{$IF (not Defined(LINUX)) or Defined(FPC)} // it also crashes Delphi OSX compiler 9 years later :(
outptr^[col] := JSAMPLE ( {$IF not (Defined(DCC) and not Defined(MSWINDOWS))}
((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF]) outptr[col] := JSAMPLE(((ctab[r+R_Y_OFF] + ctab[g+G_Y_OFF] + ctab[b+B_Y_OFF]) shr SCALEBITS));
shr SCALEBITS) );
{$IFEND} {$IFEND}
end; end;
end; end;
end; end;

1
Imaging/JpegLib/imjcdctmgr.pas
View File

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

2
Imaging/JpegLib/imjconfig.inc
View File

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

2
Imaging/JpegLib/imjdapimin.pas
View File

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

1
Imaging/JpegLib/imjdhuff.pas
View File

@ -1172,6 +1172,7 @@ begin
end; end;
{ Account for restart interval (no-op if not using restarts) } { Account for restart interval (no-op if not using restarts) }
if entropy^.restarts_to_go > 0 then
Dec(entropy^.restarts_to_go); Dec(entropy^.restarts_to_go);
decode_mcu := TRUE; 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 } cinfo^.min_DCT_scaled_size; { height of a row group of component }
main^.buffer[ci] := cinfo^.mem^.alloc_sarray main^.buffer[ci] := cinfo^.mem^.alloc_sarray
(j_common_ptr(cinfo), JPOOL_IMAGE, (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)); JDIMENSION (rgroup * ngroups));
Inc(compptr); Inc(compptr);
end; end;

4
Imaging/JpegLib/imjdmarker.pas
View File

@ -1692,6 +1692,9 @@ begin
numtoread := uint(length) numtoread := uint(length)
else else
numtoread := 0; numtoread := 0;
if numtoread > 0 then
begin
for i := 0 to numtoread-1 do for i := 0 to numtoread-1 do
begin begin
{ Read a byte into b[i]. If must suspend, return FALSE. } { Read a byte into b[i]. If must suspend, return FALSE. }
@ -1714,6 +1717,7 @@ begin
b[i] := GETJOCTET(next_input_byte^); b[i] := GETJOCTET(next_input_byte^);
Inc(next_input_byte); Inc(next_input_byte);
end; end;
end;
Dec(length, numtoread); 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); p1 : int; p2 : int; p3 : int; p4 : int);
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE; 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) } { Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE); 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); p5 : int; p6 : int; p7 : int; p8 : int);
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int; procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string); code : J_MESSAGE_CODE; str : AnsiString);
implementation implementation
@ -179,7 +179,7 @@ begin
end; end;
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE; procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
str : string); str : AnsiString);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] } cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] }
@ -286,7 +286,7 @@ begin
end; end;
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int; procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
code : J_MESSAGE_CODE; str : string); code : J_MESSAGE_CODE; str : AnsiString);
begin begin
cinfo^.err^.msg_code := ord(code); cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX } cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX }
@ -296,7 +296,7 @@ end;
{METHODDEF} {METHODDEF}
procedure output_message (cinfo : j_common_ptr); procedure output_message (cinfo : j_common_ptr);
var var
buffer : string; {[JMSG_LENGTH_MAX];} buffer : AnsiString; {[JMSG_LENGTH_MAX];}
begin begin
{ Create the message } { Create the message }
cinfo^.err^.format_message (cinfo, buffer); cinfo^.err^.format_message (cinfo, buffer);
@ -350,11 +350,11 @@ end;
{METHODDEF} {METHODDEF}
procedure format_message (cinfo : j_common_ptr; var buffer : string); procedure format_message (cinfo : j_common_ptr; var buffer : AnsiString);
var var
err : jpeg_error_mgr_ptr; err : jpeg_error_mgr_ptr;
msg_code : J_MESSAGE_CODE; msg_code : J_MESSAGE_CODE;
msgtext : string; msgtext : AnsiString;
isstring : boolean; isstring : boolean;
begin begin
err := cinfo^.err; err := cinfo^.err;

1
Imaging/JpegLib/imjfdctflt.pas
View File

@ -1,6 +1,5 @@
unit imjfdctflt; unit imjfdctflt;
{$N+}
{ This file contains a floating-point implementation of the { This file contains a floating-point implementation of the
forward DCT (Discrete Cosine Transform). 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) } mov edi, DWORD PTR [ebx+eax*4] { 4 = SizeOf(pointer) }
{Inc(JSAMPLE_PTR(outptr), output_col);} {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. { 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 However, the column calculation has created many nonzero AC terms, so

1
Imaging/JpegLib/imjidctflt.pas
View File

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

40
Imaging/JpegLib/imjmorecfg.pas
View File

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

2
Imaging/JpegLib/imjpeglib.pas
View File

@ -722,7 +722,7 @@ type
{ Routine that actually outputs a trace or error message } { Routine that actually outputs a trace or error message }
output_message : procedure (cinfo : j_common_ptr); output_message : procedure (cinfo : j_common_ptr);
{ Format a message string for the most recent JPEG error or message } { 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 state variables at start of a new image }
reset_error_mgr : procedure (cinfo : j_common_ptr); reset_error_mgr : procedure (cinfo : j_common_ptr);

55
Imaging/ZLib/dzlib.pas
View File

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

12
Imaging/ZLib/imzutil.pas
View File

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

2
UOLib/ULight.pas
View File

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