unit Img32;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.3 *
* Date : 27 September 2022 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2022 *
* *
* Purpose : The core module of the Image32 library *
* *
* License : Use, modification & distribution is subject to *
* Boost Software License Ver 1 *
* http://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
uses
Types, SysUtils, Classes,
{$IFDEF MSWINDOWS} Windows,{$ENDIF}
{$IFDEF USING_VCL_LCL}
{$IFDEF USES_NAMESPACES} Vcl.Graphics, Vcl.Forms,
{$ELSE}Graphics, Forms,
{$ENDIF}
{$ENDIF}
{$IFDEF XPLAT_GENERICS}
Generics.Collections, Generics.Defaults, Character,
{$ENDIF}
Math;
type
TRect = Types.TRect;
TColor32 = type Cardinal;
TPointD = record
X, Y: double;
end;
const
clNone32 = TColor32($00000000);
clAqua32 = TColor32($FF00FFFF);
clBlack32 = TColor32($FF000000);
clBlue32 = TColor32($FF0000FF);
clFuchsia32 = TColor32($FFFF00FF);
clGray32 = TColor32($FF808080);
clGreen32 = TColor32($FF008000);
clGrey32 = TColor32($FF808080);
clLime32 = TColor32($FF00FF00);
clMaroon32 = TColor32($FF800000);
clNavy32 = TColor32($FF000080);
clOlive32 = TColor32($FF7F7F00);
clOrange32 = TColor32($FFFF7F00);
clPurple32 = TColor32($FF7F00FF);
clRed32 = TColor32($FFFF0000);
clSilver32 = TColor32($FFC0C0C0);
clTeal32 = TColor32($FF007F7F);
clWhite32 = TColor32($FFFFFFFF);
clYellow32 = TColor32($FFFFFF00);
//custom gray colors
clDarkGray32 = TColor32($FF505050);
clDarkGrey32 = TColor32($FF505050);
//clGray32 = TColor32($FF808080);
//clSilver32 = TColor32($FFC0C0C0);
clLiteGray32 = TColor32($FFD3D3D3);
clLiteGrey32 = TColor32($FFD3D3D3);
clPaleGray32 = TColor32($FFE0E0E0);
clPaleGrey32 = TColor32($FFE0E0E0);
clDarkBtn32 = TColor32($FFE8E8E8);
clBtnFace32 = TColor32($FFF0F0F0);
clLiteBtn32 = TColor32($FFF8F8F8);
{$IFDEF ZEROBASEDSTR}
{$ZEROBASEDSTRINGS OFF}
{$ENDIF}
{$IFNDEF MSWINDOWS}
RT_BITMAP = PChar(2);
{$ENDIF}
type
TClipboardPriority = (cpLow, cpMedium, cpHigh);
PColor32 = ^TColor32;
TArrayOfColor32 = array of TColor32;
TArrayOfArrayOfColor32 = array of TArrayOfColor32;
TArrayOfInteger = array of Integer;
TArrayOfWord = array of WORD;
TArrayOfByte = array of Byte;
TImg32Notification = (inStateChange, inDestroy);
//A INotifyRecipient receives change notifications though a property
//interface from a single NotifySender (eg a Font property).
//A NotifySender can send change notificatons to multiple NotifyRecipients
//(eg where multiple object use the same font property). NotifyRecipients can
//still receive change notificatons from mulitple NotifySenders, but it
//must use a separate property for each NotifySender. (Also there's little
//benefit in using INotifySender and INotifyRecipient interfaces where there
//will only be one receiver - eg scroll - scrolling window.)
INotifyRecipient = interface
['{95F50C62-D321-46A4-A42C-8E9D0E3149B5}']
procedure ReceiveNotification(Sender: TObject; notify: TImg32Notification);
end;
TRecipients = array of INotifyRecipient;
INotifySender = interface
['{52072382-8B2F-481D-BE0A-E1C0A216B03E}']
procedure AddRecipient(recipient: INotifyRecipient);
procedure DeleteRecipient(recipient: INotifyRecipient);
end;
TInterfacedObj = class(TObject, IInterface)
public
{$IFDEF FPC}
function _AddRef: Integer;
{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function _Release: Integer;
{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
function QueryInterface(
{$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;
out obj) : longint;
{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
{$ELSE}
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
{$ENDIF}
end;
TImage32 = class;
TImageFormatClass = class of TImageFormat;
//TImageFormat: Abstract base class for loading and saving images in TImage32.
//This class is overridden to provide support for separate
//file storage formats (eg BMP, PNG, GIF & JPG).
//Derived classes register with TImage32 using TImage32.RegisterImageFormatClass.
TImageFormat = class
class function IsValidImageStream(stream: TStream): Boolean; virtual; abstract;
procedure SaveToStream(stream: TStream; img32: TImage32); virtual; abstract;
function SaveToFile(const filename: string; img32: TImage32): Boolean; virtual;
function LoadFromStream(stream: TStream; img32: TImage32): Boolean; virtual; abstract;
function LoadFromFile(const filename: string; img32: TImage32): Boolean; virtual;
class function CanCopyToClipboard: Boolean; virtual;
class function CopyToClipboard(img32: TImage32): Boolean; virtual; abstract;
class function CanPasteFromClipboard: Boolean; virtual; abstract;
class function PasteFromClipboard(img32: TImage32): Boolean; virtual; abstract;
end;
TBlendFunction = function(bgColor, fgColor: TColor32): TColor32;
TCompareFunction = function(master, current: TColor32; data: integer): Boolean;
TCompareFunctionEx = function(master, current: TColor32): Byte;
TTileFillStyle = (tfsRepeat, tfsMirrorHorz, tfsMirrorVert, tfsRotate180);
TResamplerFunction = function(img: TImage32; x256, y256: integer): TColor32;
TImage32 = class(TObject)
private
fWidth: integer;
fHeight: Integer;
fResampler: integer;
fIsPremultiplied: Boolean;
fColorCount: integer;
fPixels: TArrayOfColor32;
fOnChange: TNotifyEvent;
fOnResize: TNotifyEvent;
fUpdateCnt: integer;
fAntiAliased: Boolean;
fNotifyBlocked: Boolean;
function GetPixel(x,y: Integer): TColor32;
procedure SetPixel(x,y: Integer; color: TColor32);
function GetIsBlank: Boolean;
function GetIsEmpty: Boolean;
function GetPixelBase: PColor32;
function GetPixelRow(row: Integer): PColor32;
procedure NearestNeighborResize(newWidth, newHeight: Integer);
procedure ResamplerResize(newWidth, newHeight: Integer);
procedure RotateLeft90;
procedure RotateRight90;
procedure Rotate180;
function GetColorCount: Integer;
function GetHasTransparency: Boolean;
function GetBounds: TRect;
function GetMidPoint: TPointD;
protected
function RectHasTransparency(rec: TRect): Boolean;
function CopyPixels(rec: TRect): TArrayOfColor32;
//CopyInternal: Internal routine (has no scaling or bounds checking)
procedure CopyInternal(src: TImage32;
const srcRec, dstRec: TRect; blendFunc: TBlendFunction);
procedure Changed; virtual;
procedure Resized; virtual;
property UpdateCount: integer read fUpdateCnt;
public
constructor Create(width: Integer = 0; height: Integer = 0); overload;
constructor Create(src: TImage32); overload;
constructor Create(src: TImage32; const srcRec: TRect); overload;
destructor Destroy; override;
procedure BeginUpdate;
procedure EndUpdate;
procedure BlockNotify;
procedure UnblockNotify;
procedure Assign(src: TImage32);
procedure AssignTo(dst: TImage32);
//SetSize: Erases any current image, and fills with the specified color.
procedure SetSize(newWidth, newHeight: Integer; color: TColor32 = 0);
//Resize: is similar to Scale() in that it won't eraze the existing
//image. Depending on the stretchImage parameter it will either stretch
//or crop the image. Don't confuse Resize() with SetSize(), as the latter
//does erase the image.
procedure Resize(newWidth, newHeight: Integer; stretchImage: Boolean = true);
//ScaleToFit: The new image will be scaled to fit within 'rec'
procedure ScaleToFit(width, height: integer);
//ScaleToFitCentered: The new image will be scaled and also centred
procedure ScaleToFitCentered(width, height: integer); overload;
procedure ScaleToFitCentered(const rect: TRect); overload;
procedure Scale(s: double); overload;
procedure Scale(sx, sy: double); overload;
function Copy(src: TImage32; srcRec, dstRec: TRect): Boolean;
//CopyBlend: Copies part or all of another image (src) on top of the
//existing image. If no blend function is provided, then the function
//will behave exactly as the Copy function above. However, when a blend
//function is specified, that function will determine how the images will
//be blended. If srcRec and dstRec have different widths or heights,
//then the image in srcRec will also be stretched to fit dstRec.
function CopyBlend(src: TImage32; srcRec, dstRec: TRect;
blendFunc: TBlendFunction = nil): Boolean;
{$IFDEF MSWINDOWS}
//CopyFromDC: Copies an image from a Windows device context, erasing
//any current image in TImage32. (eg copying from TBitmap.canvas.handle)
procedure CopyFromDC(srcDc: HDC; const srcRect: TRect);
//CopyToDc: Copies the image into a Windows device context
procedure CopyToDc(dstDc: HDC; x: Integer = 0; y: Integer = 0;
transparent: Boolean = true); overload;
procedure CopyToDc(const srcRect: TRect; dstDc: HDC;
x: Integer = 0; y: Integer = 0; transparent: Boolean = true); overload;
procedure CopyToDc(const srcRect, dstRect: TRect; dstDc: HDC;
transparent: Boolean = true); overload;
{$ENDIF}
{$IFDEF USING_VCL_LCL}
procedure CopyFromBitmap(bmp: TBitmap);
procedure CopyToBitmap(bmp: TBitmap);
{$ENDIF}
function CopyToClipBoard: Boolean;
class function CanPasteFromClipBoard: Boolean;
function PasteFromClipBoard: Boolean;
procedure Crop(const rec: TRect);
//SetBackgroundColor: Assumes the current image is semi-transparent.
procedure SetBackgroundColor(bgColor: TColor32);
procedure Clear(color: TColor32 = 0); overload;
procedure Clear(const rec: TRect; color: TColor32 = 0); overload;
procedure FillRect(rec: TRect; color: TColor32);
procedure ConvertToBoolMask(reference: TColor32;
tolerance: integer; colorFunc: TCompareFunction;
maskBg: TColor32 = clWhite32; maskFg: TColor32 = clBlack32);
procedure ConvertToAlphaMask(reference: TColor32;
colorFunc: TCompareFunctionEx);
procedure FlipVertical;
procedure FlipHorizontal;
procedure PreMultiply;
//SetAlpha: Sets 'alpha' to the alpha byte of every pixel in the image
procedure SetAlpha(alpha: Byte);
procedure ReduceOpacity(opacity: Byte); overload;
procedure ReduceOpacity(opacity: Byte; rec: TRect); overload;
//SetRGB: Sets the RGB channels leaving the alpha channel unchanged
procedure SetRGB(rgbColor: TColor32); overload;
procedure SetRGB(rgbColor: TColor32; rec: TRect); overload;
//Grayscale: Only changes color channels. The alpha channel is untouched.
procedure Grayscale;
procedure InvertColors;
procedure InvertAlphas;
procedure AdjustHue(percent: Integer); //ie +/- 100%
procedure AdjustLuminance(percent: Integer); //ie +/- 100%
procedure AdjustSaturation(percent: Integer); //ie +/- 100%
//CropTransparentPixels: Trims transparent edges until each edge contains
//at least one opaque or semi-opaque pixel.
function CropTransparentPixels: TRect;
procedure Rotate(angleRads: double);
//RotateRect: Rotates part of an image, but also clips those parts of the
//rotated image that fall outside rec. The eraseColor parameter indicates
//the color to fill those uncovered pixels in rec following rotation.
procedure RotateRect(const rec: TRect;
angleRads: double; eraseColor: TColor32 = 0);
procedure Skew(dx,dy: double);
//ScaleAlpha: Scales the alpha byte of every pixel by the specified amount.
procedure ScaleAlpha(scale: double);
class procedure RegisterImageFormatClass(ext: string;
bm32ExClass: TImageFormatClass; clipPriority: TClipboardPriority);
class function GetImageFormatClass(const ext: string): TImageFormatClass; overload;
class function GetImageFormatClass(stream: TStream): TImageFormatClass; overload;
class function IsRegisteredFormat(const ext: string): Boolean;
function SaveToFile(filename: string): Boolean;
function SaveToStream(stream: TStream; const FmtExt: string): Boolean;
function LoadFromFile(const filename: string): Boolean;
function LoadFromStream(stream: TStream): Boolean;
function LoadFromResource(const resName: string; resType: PChar): Boolean;
//properties ...
property AntiAliased: Boolean read fAntiAliased write fAntiAliased;
property Width: Integer read fWidth;
property Height: Integer read fHeight;
property Bounds: TRect read GetBounds;
property IsBlank: Boolean read GetIsBlank;
property IsEmpty: Boolean read GetIsEmpty;
property IsPreMultiplied: Boolean read fIsPremultiplied;
property MidPoint: TPointD read GetMidPoint;
property Pixel[x,y: Integer]: TColor32 read GetPixel write SetPixel;
property Pixels: TArrayOfColor32 read fPixels;
property PixelBase: PColor32 read GetPixelBase;
property PixelRow[row: Integer]: PColor32 read GetPixelRow;
property ColorCount: Integer read GetColorCount;
//HasTransparency: Returns true if any pixel's alpha byte < 255.
property HasTransparency: Boolean read GetHasTransparency;
//Resampler: is used in scaling and rotation transforms
property Resampler: integer read fResampler write fResampler;
property OnChange: TNotifyEvent read fOnChange write fOnChange;
property OnResize: TNotifyEvent read fOnResize write fOnResize;
end;
TImageList32 = class
private
{$IFDEF XPLAT_GENERICS}
fList: TList;
{$ELSE}
fList: TList;
{$ENDIF}
fIsImageOwner: Boolean;
function GetImage(index: integer): TImage32;
procedure SetImage(index: integer; img: TIMage32);
function GetLast: TImage32;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function Count: integer;
procedure Add(image: TImage32); overload;
function Add(width, height: integer): TImage32; overload;
procedure Insert(index: integer; image: TImage32);
procedure Move(currentIndex, newIndex: integer);
procedure Delete(index: integer);
property Image[index: integer]: TImage32 read GetImage write SetImage; default;
property IsImageOwner: Boolean read fIsImageOwner write fIsImageOwner;
property Last: TImage32 read GetLast;
end;
PARGB = ^TARGB;
TARGB = packed record
case boolean of
false: (B: Byte; G: Byte; R: Byte; A: Byte);
true : (Color: TColor32);
end;
TArrayOfARGB = array of TARGB;
PArgbArray = ^TArrayOfARGB;
THsl = packed record
hue : byte;
sat : byte;
lum : byte;
alpha: byte;
end;
PHsl = ^THsl;
TArrayofHSL = array of THsl;
TTriState = (tsUnknown = 0, tsYes = 1, tsChecked = 1, tsNo = 2, tsUnchecked = 2);
PPointD = ^TPointD;
TPathD = array of TPointD; //nb: watch for ambiguity with Clipper.pas
TPathsD = array of TPathD; //nb: watch for ambiguity with Clipper.pas
TArrayOfPathsD = array of TPathsD;
TArrayOfDouble = array of double;
TArrayOfString = array of string;
TRectD = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF}
{$IFNDEF RECORD_METHODS}
Left, Top, Right, Bottom: Double;
function TopLeft: TPointD;
function BottomRight: TPointD;
{$ENDIF}
function IsEmpty: Boolean;
function Width: double;
function Height: double;
//Normalize: Returns True if swapping top & bottom or left & right
function Normalize: Boolean;
function Contains(const Pt: TPoint): Boolean; overload;
function Contains(const Pt: TPointD): Boolean; overload;
function MidPoint: TPointD;
{$IFDEF RECORD_METHODS}
case Integer of
0: (Left, Top, Right, Bottom: Double);
1: (TopLeft, BottomRight: TPointD);
{$ENDIF}
end;
{$IFNDEF PBYTE}
PByte = type PChar;
{$ENDIF}
//BLEND FUNCTIONS ( see TImage32.CopyBlend() )
//BlendToOpaque: Blends a semi-transparent image onto an opaque background
function BlendToOpaque(bgColor, fgColor: TColor32): TColor32;
//BlendToAlpha: Blends two semi-transparent images (slower than BlendToOpaque)
function BlendToAlpha(bgColor, fgColor: TColor32): TColor32;
//BlendMask: Whereever the mask is, preserves the background
function BlendMask(bgColor, alphaMask: TColor32): TColor32;
function BlendAltMask(bgColor, alphaMask: TColor32): TColor32;
function BlendDifference(color1, color2: TColor32): TColor32;
function BlendSubtract(bgColor, fgColor: TColor32): TColor32;
function BlendLighten(bgColor, fgColor: TColor32): TColor32;
function BlendDarken(bgColor, fgColor: TColor32): TColor32;
function BlendInvertedMask(bgColor, alphaMask: TColor32): TColor32;
//BlendBlueChannel: typically useful for white color masks
function BlendBlueChannel(bgColor, blueMask: TColor32): TColor32;
//COMPARE COLOR FUNCTIONS (ConvertToBoolMask, FloodFill, Vectorize etc.)
function CompareRGB(master, current: TColor32; tolerance: Integer): Boolean;
function CompareHue(master, current: TColor32; tolerance: Integer): Boolean;
function CompareAlpha(master, current: TColor32; tolerance: Integer): Boolean;
//CompareEx COLOR FUNCTIONS (see ConvertToAlphaMask)
function CompareRgbEx(master, current: TColor32): Byte;
function CompareAlphaEx(master, current: TColor32): Byte;
//MISCELLANEOUS FUNCTIONS ...
function GetBoolMask(img: TImage32; reference: TColor32;
compareFunc: TCompareFunction; tolerance: Integer): TArrayOfByte;
function GetByteMask(img: TImage32; reference: TColor32;
compareFunc: TCompareFunctionEx): TArrayOfByte;
{$IFDEF MSWINDOWS}
//Color32: Converts a Graphics.TColor value into a TColor32 value.
function Color32(rgbColor: Integer): TColor32; overload;
{$ENDIF}
function Color32(a, r, g, b: Byte): TColor32; overload;
//RGBColor: Converts a TColor32 value into a COLORREF value
function RGBColor(color: TColor32): Cardinal;
function InvertColor(color: TColor32): TColor32;
//RgbToHsl: See https://en.wikipedia.org/wiki/HSL_and_HSV
function RgbToHsl(color: TColor32): THsl;
//HslToRgb: See https://en.wikipedia.org/wiki/HSL_and_HSV
function HslToRgb(hslColor: THsl): TColor32;
function AdjustHue(color: TColor32; percent: Integer): TColor32;
function ArrayOfColor32ToArrayHSL(const clr32Arr: TArrayOfColor32): TArrayofHSL;
function ArrayOfHSLToArrayColor32(const hslArr: TArrayofHSL): TArrayOfColor32;
function GetAlpha(color: TColor32): Byte; {$IFDEF INLINE} inline; {$ENDIF}
function PointD(const X, Y: Double): TPointD; overload;
function PointD(const pt: TPoint): TPointD; overload;
function RectD(left, top, right, bottom: double): TRectD; overload;
function RectD(const rec: TRect): TRectD; overload;
function ClampByte(val: Integer): byte; overload; {$IFDEF INLINE} inline; {$ENDIF}
function ClampByte(val: double): byte; overload; {$IFDEF INLINE} inline; {$ENDIF}
function ClampRange(val, min, max: Integer): Integer; overload;
function ClampRange(val, min, max: double): double; overload;
function IncPColor32(pc: Pointer; cnt: Integer): PColor32;
procedure NormalizeAngle(var angle: double; tolerance: double = Pi/360);
function GrayScale(color: TColor32): TColor32;
//DPIAware: Useful for DPIAware sizing of images and their container controls.
//It scales values relative to the display's resolution (PixelsPerInch).
//See https://docs.microsoft.com/en-us/windows/desktop/hidpi/high-DPIAware-desktop-application-development-on-windows
function DPIAware(val: Integer): Integer; overload; {$IFDEF INLINE} inline; {$ENDIF}
function DPIAware(val: double): double; overload; {$IFDEF INLINE} inline; {$ENDIF}
function DPIAware(const pt: TPoint): TPoint; overload;
function DPIAware(const pt: TPointD): TPointD; overload;
function DPIAware(const rec: TRect): TRect; overload;
function DPIAware(const rec: TRectD): TRectD; overload;
{$IFDEF MSWINDOWS}
{$IFDEF FPC}
function AlphaBlend(DC: HDC; p2, p3, p4, p5: Integer;
DC6: HDC; p7, p8, p9, p10: Integer; p11: Windows.TBlendFunction): BOOL;
stdcall; external 'msimg32.dll' name 'AlphaBlend';
{$ENDIF}
{$ENDIF}
//CreateResourceStream: handles both numeric and string names and types
function CreateResourceStream(const resName: string;
resType: PChar): TResourceStream;
function GetResampler(id: integer): TResamplerFunction;
function RegisterResampler(func: TResamplerFunction; const name: string): integer;
procedure GetResamplerList(stringList: TStringList);
const
TwoPi = Pi *2;
angle0 = 0;
angle1 = Pi/180;
angle15 = Pi /12;
angle30 = angle15 *2;
angle45 = angle15 *3;
angle60 = angle15 *4;
angle75 = angle15 *5;
angle90 = Pi /2;
angle105 = Pi - angle75;
angle120 = Pi - angle60;
angle135 = Pi - angle45;
angle150 = Pi - angle30;
angle165 = Pi - angle15;
angle180 = Pi;
angle195 = Pi + angle15;
angle210 = Pi + angle30;
angle225 = Pi + angle45;
angle240 = Pi + angle60;
angle255 = Pi + angle75;
angle270 = TwoPi - angle90;
angle285 = TwoPi - angle75;
angle300 = TwoPi - angle60;
angle315 = TwoPi - angle45;
angle330 = TwoPi - angle30;
angle345 = TwoPi - angle15;
angle360 = TwoPi;
var
ClockwiseRotationIsAnglePositive: Boolean = true;
//Resampling function identifiers (initialized in Img32.Resamplers)
rNearestResampler : integer;
rBilinearResampler: integer;
rBicubicResampler : integer;
DefaultResampler: Integer = 0;
//Both MulTable and DivTable are used in blend functions
//MulTable[a,b] = a * b / 255
MulTable: array [Byte,Byte] of Byte;
//DivTable[a,b] = a * 255/b (for a <= b)
DivTable: array [Byte,Byte] of Byte;
dpiAware1 : integer = 1;
DpiAwareOne : double = 1.0;
//AND BECAUSE OLDER DELPHI COMPILERS (OLDER THAN D2006)
//DON'T SUPPORT RECORD METHODS
procedure RectWidthHeight(const rec: TRect; out width, height: Integer);
{$IFDEF INLINE} inline; {$ENDIF}
function RectWidth(const rec: TRect): Integer;
{$IFDEF INLINE} inline; {$ENDIF}
function RectHeight(const rec: TRect): Integer;
{$IFDEF INLINE} inline; {$ENDIF}
function IsEmptyRect(const rec: TRect): Boolean; overload;
{$IFDEF INLINE} inline; {$ENDIF}
function IsEmptyRect(const rec: TRectD): Boolean; overload;
{$IFDEF INLINE} inline; {$ENDIF}
function SwapRedBlue(color: TColor32): TColor32; overload;
procedure SwapRedBlue(color: PColor32; count: integer); overload;
function MulBytes(b1, b2: Byte) : Byte;
implementation
uses
Img32.Vector, Img32.Resamplers, Img32.Transform;
resourcestring
rsImageTooLarge = 'Image32 error: the image is too large.';
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
const
div255 : Double = 1 / 255;
type
TByteArray = array[0..MaxInt -1] of Byte;
PByteArray = ^TByteArray;
TImgFmtRec = record
Fmt: string;
SortOrder: TClipboardPriority;
Obj: TImageFormatClass;
end;
PImgFmtRec = ^TImgFmtRec;
TResamplerObj = class
id: integer;
name: string;
func: TResamplerFunction;
end;
var
{$IFDEF XPLAT_GENERICS}
ImageFormatClassList: TList; //list of supported file extensions
ResamplerList: TList; //list of resampler functions
{$ELSE}
ImageFormatClassList: TList;
ResamplerList: TList;
{$ENDIF}
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
procedure CreateImageFormatList;
begin
if Assigned(ImageFormatClassList) then Exit;
{$IFDEF XPLAT_GENERICS}
ImageFormatClassList := TList.Create;
{$ELSE}
ImageFormatClassList := TList.Create;
{$ENDIF}
end;
//------------------------------------------------------------------------------
function FMod(const ANumerator, ADenominator: Double): Double;
begin
Result := ANumerator - Trunc(ANumerator / ADenominator) * ADenominator;
end;
//------------------------------------------------------------------------------
procedure NormalizeAngle(var angle: double; tolerance: double = Pi/360);
var
aa: double;
begin
angle := FMod(angle, angle360);
if angle < -Angle180 then angle := angle + angle360
else if angle > angle180 then angle := angle - angle360;
aa := Abs(angle);
if aa < tolerance then angle := 0
else if aa > angle180 - tolerance then angle := angle180
else if (aa < angle90 - tolerance) or (aa > angle90 + tolerance) then Exit
else if angle < 0 then angle := -angle90
else angle := angle90;
end;
//------------------------------------------------------------------------------
function SwapRedBlue(color: TColor32): TColor32;
var
c: array[0..3] of byte absolute color;
r: array[0..3] of byte absolute Result;
begin
result := color;
r[0] := c[2];
r[2] := c[0];
end;
//------------------------------------------------------------------------------
procedure SwapRedBlue(color: PColor32; count: integer);
var
i: integer;
begin
for i := 1 to count do
begin
color^ := SwapRedBlue(color^);
inc(color);
end;
end;
//------------------------------------------------------------------------------
function MulBytes(b1, b2: Byte) : Byte; {$IFDEF INLINE} inline; {$ENDIF}
begin
Result := MulTable[b1, b2];
end;
//------------------------------------------------------------------------------
function ImageFormatClassListSort(item1, item2: Pointer): integer;
var
imgFmtRec1: PImgFmtRec absolute item1;
imgFmtRec2: PImgFmtRec absolute item2;
begin
Result := Integer(imgFmtRec1.SortOrder) - Integer(imgFmtRec2.SortOrder);
end;
//------------------------------------------------------------------------------
function ClampByte(val: Integer): byte;
begin
if val < 0 then result := 0
else if val > 255 then result := 255
else result := val;
end;
//------------------------------------------------------------------------------
function ClampByte(val: double): byte;
begin
if val <= 0 then result := 0
else if val >= 255 then result := 255
else result := Round(val);
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
// Blend functions - used by TImage32.CopyBlend()
//------------------------------------------------------------------------------
function BlendToOpaque(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
fw,bw: PByteArray;
begin
if fg.A = 0 then Result := bgColor
else if fg.A = 255 then Result := fgColor
else
begin
//assuming bg.A = 255, use just fg.A for color weighting
res.A := 255;
fw := PByteArray(@MulTable[fg.A]); //ie weight of foreground
bw := PByteArray(@MulTable[not fg.A]); //ie weight of foreground
res.R := fw[fg.R] + bw[bg.R];
res.G := fw[fg.G] + bw[bg.G];
res.B := fw[fg.B] + bw[bg.B];
end;
end;
//------------------------------------------------------------------------------
function BlendToAlpha(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
fgWeight: byte;
R, InvR: PByteArray;
begin
//(see https://en.wikipedia.org/wiki/Alpha_compositing)
if (bg.A = 0) or (fg.A = 255) then Result := fgColor
else if fg.A = 0 then Result := bgColor
else
begin
//combine alphas ...
res.A := not MulTable[not fg.A, not bg.A];
fgWeight := DivTable[fg.A, res.A]; //fgWeight = amount foreground color
//contibutes to total (result) color
R := PByteArray(@MulTable[fgWeight]); //ie weight of foreground
InvR := PByteArray(@MulTable[not fgWeight]); //ie weight of foreground
res.R := R[fg.R] + InvR[bg.R];
res.G := R[fg.G] + InvR[bg.G];
res.B := R[fg.B] + InvR[bg.B];
end;
end;
//------------------------------------------------------------------------------
function BlendMask(bgColor, alphaMask: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute alphaMask;
begin
Result := bgColor;
res.A := MulTable[bg.A, fg.A];
if res.A = 0 then Result := 0;
end;
//------------------------------------------------------------------------------
function BlendAltMask(bgColor, alphaMask: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute alphaMask;
begin
Result := bgColor;
res.A := MulTable[bg.A, 255-fg.A];
if res.A = 0 then Result := 0;
end;
//------------------------------------------------------------------------------
function BlendDifference(color1, color2: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute color1;
fg: TARGB absolute color2;
begin
if fg.A = 0 then Result := color1
else if bg.A = 0 then Result := color2
else
begin
res.A := (((fg.A xor 255) * (bg.A xor 255)) shr 8) xor 255;
res.R := Abs(fg.R - bg.R);
res.G := Abs(fg.G - bg.G);
res.B := Abs(fg.B - bg.B);
end;
end;
//------------------------------------------------------------------------------
function BlendSubtract(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
begin
if fg.A = 0 then Result := bgColor
else if bg.A = 0 then Result := fgColor
else
begin
res.A := (((fg.A xor 255) * (bg.A xor 255)) shr 8) xor 255;
res.R := ClampByte(fg.R - bg.R);
res.G := ClampByte(fg.G - bg.G);
res.B := ClampByte(fg.B - bg.B);
end;
end;
//------------------------------------------------------------------------------
function BlendLighten(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
begin
if fg.A = 0 then Result := bgColor
else if bg.A = 0 then Result := fgColor
else
begin
res.A := (((fg.A xor 255) * (bg.A xor 255)) shr 8) xor 255;
res.R := Max(fg.R, bg.R);
res.G := Max(fg.G, bg.G);
res.B := Max(fg.B, bg.B);
end;
end;
//------------------------------------------------------------------------------
function BlendDarken(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
begin
if fg.A = 0 then Result := bgColor
else if bg.A = 0 then Result := fgColor
else
begin
res.A := (((fg.A xor 255) * (bg.A xor 255)) shr 8) xor 255;
res.R := Min(fg.R, bg.R);
res.G := Min(fg.G, bg.G);
res.B := Min(fg.B, bg.B);
end;
end;
//------------------------------------------------------------------------------
function BlendBlueChannel(bgColor, blueMask: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute blueMask;
begin
Result := bgColor;
res.A := MulTable[bg.A, fg.B];
end;
//------------------------------------------------------------------------------
function BlendInvertedMask(bgColor, alphaMask: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute alphaMask;
begin
Result := bgColor;
res.A := MulTable[bg.A, 255 - fg.A];
if res.A < 2 then Result := 0;
end;
//------------------------------------------------------------------------------
// Compare functions (see ConvertToBoolMask, FloodFill & Vectorize)
//------------------------------------------------------------------------------
function CompareRGB(master, current: TColor32; tolerance: Integer): Boolean;
var
mast: TARGB absolute master;
curr: TARGB absolute current;
begin
if curr.A < $80 then
Result := false
else if (master and $FFFFFF) = (current and $FFFFFF) then
Result := true
else if tolerance = 0 then
Result := false
else result :=
(Abs(curr.R - mast.R) <= tolerance) and
(Abs(curr.G - mast.G) <= tolerance) and
(Abs(curr.B - mast.B) <= tolerance);
end;
//------------------------------------------------------------------------------
function CompareAlpha(master, current: TColor32; tolerance: Integer): Boolean;
var
mast: TARGB absolute master;
curr: TARGB absolute current;
begin
if mast.A = curr.A then Result := true
else if tolerance = 0 then Result := false
else result := Abs(curr.A - mast.A) <= tolerance;
end;
//------------------------------------------------------------------------------
function CompareHue(master, current: TColor32; tolerance: Integer): Boolean;
var
curr, mast: THsl;
val: Integer;
begin
if TARGB(current).A < $80 then
begin
Result := false;
Exit;
end;
curr := RgbToHsl(current);
mast := RgbToHsl(master);
if curr.hue > mast.hue then
begin
val := curr.hue - mast.hue;
if val > 127 then val := mast.hue - curr.hue + 255;
end else
begin
val := mast.hue - curr.hue;
if val > 127 then val := curr.hue - mast.hue + 255;
end;
result := val <= tolerance;
end;
//------------------------------------------------------------------------------
// CompareEx functions (see ConvertToAlphaMask)
//------------------------------------------------------------------------------
function CompareRgbEx(master, current: TColor32): Byte;
var
mast: TARGB absolute master;
curr: TARGB absolute current;
res: Cardinal;
begin
res := Sqr(mast.R - curr.R) + Sqr(mast.G - curr.G) + Sqr(mast.B - curr.B);
if res >= 65025 then result := 255
else result := Round(Sqrt(res));
end;
//------------------------------------------------------------------------------
function CompareAlphaEx(master, current: TColor32): Byte;
var
mast: TARGB absolute master;
curr: TARGB absolute current;
begin
Result := abs(mast.A - curr.A);
end;
//------------------------------------------------------------------------------
// Miscellaneous functions ...
//------------------------------------------------------------------------------
function IsAlphaChar(c: Char): Boolean;
begin
Result := ((c >= 'A') and (c <= 'Z')) or ((c >= 'a') and (c <= 'z'));
end;
//------------------------------------------------------------------------------
procedure RectWidthHeight(const rec: TRect; out width, height: Integer);
begin
width := rec.Right - rec.Left;
height := rec.Bottom - rec.Top;
end;
//------------------------------------------------------------------------------
function RectWidth(const rec: TRect): Integer;
begin
Result := rec.Right - rec.Left;
end;
//------------------------------------------------------------------------------
function RectHeight(const rec: TRect): Integer;
begin
Result := rec.Bottom - rec.Top;
end;
//------------------------------------------------------------------------------
function IsEmptyRect(const rec: TRect): Boolean;
begin
Result := (rec.Right <= rec.Left) or (rec.Bottom <= rec.Top);
end;
//------------------------------------------------------------------------------
function IsEmptyRect(const rec: TRectD): Boolean;
begin
Result := (rec.Right <= rec.Left) or (rec.Bottom <= rec.Top);
end;
//------------------------------------------------------------------------------
function InvertColor(color: TColor32): TColor32;
var
c: TARGB absolute color;
r: TARGB absolute Result;
begin
r.A := c.A;
r.R := 255 - c.R;
r.G := 255 - c.G;
r.B := 255 - c.B;
end;
//------------------------------------------------------------------------------
function GetAlpha(color: TColor32): Byte;
begin
Result := Byte(color shr 24);
end;
//------------------------------------------------------------------------------
function RGBColor(color: TColor32): Cardinal;
var
c : TARGB absolute color;
res: TARGB absolute Result;
begin
res.R := c.B; res.G := c.G; res.B := c.R; res.A := 0;
end;
//------------------------------------------------------------------------------
function Color32(a, r, g, b: Byte): TColor32;
var
res: TARGB absolute Result;
begin
res.A := a; res.R := r; res.G := g; res.B := b;
end;
//------------------------------------------------------------------------------
{$IFDEF MSWINDOWS}
function Color32(rgbColor: Integer): TColor32;
var
res: TARGB absolute Result;
begin
if rgbColor < 0 then
result := GetSysColor(rgbColor and $FFFFFF) else
result := rgbColor;
res.A := res.B; res.B := res.R; res.R := res.A; //byte swap
res.A := 255;
end;
//------------------------------------------------------------------------------
function Get32bitBitmapInfoHeader(width, height: Integer): TBitmapInfoHeader;
begin
FillChar(Result, sizeof(Result), #0);
Result.biSize := sizeof(TBitmapInfoHeader);
Result.biWidth := width;
Result.biHeight := height;
Result.biPlanes := 1;
Result.biBitCount := 32;
Result.biSizeImage := width * height * SizeOf(TColor32);
Result.biCompression := BI_RGB;
end;
//------------------------------------------------------------------------------
{$ENDIF}
function DPIAware(val: Integer): Integer;
begin
result := Round(val * DpiAwareOne);
end;
//------------------------------------------------------------------------------
function DPIAware(val: double): double;
begin
result := val * DpiAwareOne;
end;
//------------------------------------------------------------------------------
function DPIAware(const pt: TPoint): TPoint;
begin
result.X := Round(pt.X * DpiAwareOne);
result.Y := Round(pt.Y * DpiAwareOne);
end;
//------------------------------------------------------------------------------
function DPIAware(const pt: TPointD): TPointD;
begin
result.X := pt.X * DpiAwareOne;
result.Y := pt.Y * DpiAwareOne;
end;
//------------------------------------------------------------------------------
function DPIAware(const rec: TRect): TRect;
begin
result.Left := Round(rec.Left * DpiAwareOne);
result.Top := Round(rec.Top * DpiAwareOne);
result.Right := Round(rec.Right * DpiAwareOne);
result.Bottom := Round(rec.Bottom * DpiAwareOne);
end;
//------------------------------------------------------------------------------
function DPIAware(const rec: TRectD): TRectD;
begin
result.Left := rec.Left * DpiAwareOne;
result.Top := rec.Top * DpiAwareOne;
result.Right := rec.Right * DpiAwareOne;
result.Bottom := rec.Bottom * DpiAwareOne;
end;
//------------------------------------------------------------------------------
function GrayScale(color: TColor32): TColor32;
var
c: TARGB absolute color;
r: TARGB absolute result;
g: Byte;
begin
//https://www.w3.org/TR/AERT/#color-contrast
g := ClampByte(0.299 * c.R + 0.587 * c.G + 0.114 * c.B);
r.A := c.A;
r.R := g; r.G := g; r.B := g;
end;
//------------------------------------------------------------------------------
function ClampRange(val, min, max: Integer): Integer;
begin
if val < min then result := min
else if val > max then result := max
else result := val;
end;
//------------------------------------------------------------------------------
function ClampRange(val, min, max: double): double;
begin
if val < min then result := min
else if val > max then result := max
else result := val;
end;
//------------------------------------------------------------------------------
procedure ScaleRect(var rec: TRect; x,y: double);
begin
rec.Right := rec.Left + Round((rec.Right - rec.Left) * x);
rec.Bottom := rec.Top + Round((rec.Bottom - rec.Top) * y);
end;
//------------------------------------------------------------------------------
function IncPColor32(pc: Pointer; cnt: Integer): PColor32;
begin
result := PColor32(PByte(pc) + cnt * SizeOf(TColor32));
end;
//------------------------------------------------------------------------------
function PointD(const X, Y: Double): TPointD;
begin
Result.X := X;
Result.Y := Y;
end;
//------------------------------------------------------------------------------
function PointD(const pt: TPoint): TPointD;
begin
Result.X := pt.X;
Result.Y := pt.Y;
end;
//------------------------------------------------------------------------------
function GetBoolMask(img: TImage32; reference: TColor32;
compareFunc: TCompareFunction; tolerance: Integer): TArrayOfByte;
var
i: integer;
pa: PByte;
pc: PColor32;
begin
result := nil;
if not assigned(img) or img.IsEmpty then Exit;
if not Assigned(compareFunc) then compareFunc := CompareRGB;
SetLength(Result, img.Width * img.Height);
pa := @Result[0];
pc := img.PixelBase;
for i := 0 to img.Width * img.Height -1 do
begin
if compareFunc(reference, pc^, tolerance) then
{$IFDEF PBYTE}
pa^ := 1 else
pa^ := 0;
{$ELSE}
pa^ := #1 else
pa^ := #0;
{$ENDIF}
inc(pc); inc(pa);
end;
end;
//------------------------------------------------------------------------------
function GetAlphaEx(master, current: TColor32): Byte;
{$IFDEF INLINE} inline; {$ENDIF}
var
curr: TARGB absolute current;
begin
result := curr.A; //nb: 'master' is ignored
end;
//------------------------------------------------------------------------------
function GetByteMask(img: TImage32; reference: TColor32;
compareFunc: TCompareFunctionEx): TArrayOfByte;
var
i: integer;
pa: PByte;
pc: PColor32;
begin
result := nil;
if not assigned(img) or img.IsEmpty then Exit;
if not Assigned(compareFunc) then compareFunc := GetAlphaEx;
SetLength(Result, img.Width * img.Height);
pa := @Result[0];
pc := img.PixelBase;
for i := 0 to img.Width * img.Height -1 do
begin
{$IFDEF PBYTE}
pa^ := compareFunc(reference, pc^);
{$ELSE}
pa^ := Char(compareFunc(reference, pc^));
{$ENDIF}
inc(pc); inc(pa);
end;
end;
//------------------------------------------------------------------------------
function RgbToHsl(color: TColor32): THsl;
var
rgba: TARGB absolute color;
hsl: THsl absolute result;
r,g,b: byte;
maxRGB, minRGB, mAdd, mSub: Integer;
begin
//https://en.wikipedia.org/wiki/HSL_and_HSV and
//http://en.wikipedia.org/wiki/HSL_color_space
{$IF DEFINED(ANDROID)}
color := SwapRedBlue(color);
{$IFEND}
r := rgba.R; g := rgba.G; b := rgba.B;
maxRGB := Max(r, Max(g, b));
minRGB := Min(r, Min(g, b));
mAdd := maxRGB + minRGB;
hsl.lum := mAdd shr 1;
hsl.alpha := rgba.A;
if maxRGB = minRGB then
begin
hsl.hue := 0; //hsl.hue is undefined when gray
hsl.sat := 0;
Exit;
end;
mSub := maxRGB - minRGB;
if mAdd <= 255 then
hsl.sat := DivTable[mSub, mAdd] else
hsl.sat := DivTable[mSub, 511 - mAdd];
mSub := mSub * 6;
if r = maxRGB then
begin
if g >= b then
hsl.hue := (g - b) * 255 div mSub else
hsl.hue := 255 - ((b - g) * 255 div mSub);
end
else if G = maxRGB then
begin
if b > r then
hsl.hue := 85 + (b - r) * 255 div mSub else
hsl.hue := 85 - (r - b) * 255 div mSub;
end else
begin
if r > g then
hsl.hue := 170 + (r - g) * 255 div mSub else
hsl.hue := 170 - (g - r) * 255 div mSub;
end;
end;
//------------------------------------------------------------------------------
function HslToRgb(hslColor: THsl): TColor32;
var
rgba: TARGB absolute result;
hsl: THsl absolute hslColor;
c, x, m, a: Integer;
begin
//formula from https://www.rapidtables.com/convert/color/hsl-to-rgb.html
c := (255 - abs(2 * hsl.lum - 255)) * hsl.sat div 255;
a := (hsl.hue mod 85) * 6 - 255;
x := c * (255 - abs(a)) div 255;
m := hsl.lum - c div 2;
rgba.A := hsl.alpha;
case (hsl.hue * 6) shr 8 of
0: begin rgba.R := c + m; rgba.G := x + m; rgba.B := 0 + m; end;
1: begin rgba.R := x + m; rgba.G := c + m; rgba.B := 0 + m; end;
2: begin rgba.R := 0 + m; rgba.G := c + m; rgba.B := x + m; end;
3: begin rgba.R := 0 + m; rgba.G := x + m; rgba.B := c + m; end;
4: begin rgba.R := x + m; rgba.G := 0 + m; rgba.B := c + m; end;
5: begin rgba.R := c + m; rgba.G := 0 + m; rgba.B := x + m; end;
end;
{$IF DEFINED(ANDROID)}
Result := SwapRedBlue(Result);
{$IFEND}
end;
//------------------------------------------------------------------------------
function AdjustHue(color: TColor32; percent: Integer): TColor32;
var
hsl: THsl;
begin
percent := percent mod 100;
if percent < 0 then inc(percent, 100);
hsl := RgbToHsl(color);
hsl.hue := (hsl.hue + Round(percent*255/100)) mod 256;
result := HslToRgb(hsl);
end;
//------------------------------------------------------------------------------
function ArrayOfColor32ToArrayHSL(const clr32Arr: TArrayOfColor32): TArrayofHSL;
var
i, len: Integer;
begin
len := length(clr32Arr);
setLength(result, len);
for i := 0 to len -1 do
result[i] := RgbToHsl(clr32Arr[i]);
end;
//------------------------------------------------------------------------------
function ArrayOfHSLToArrayColor32(const hslArr: TArrayofHSL): TArrayOfColor32;
var
i, len: Integer;
begin
len := length(hslArr);
setLength(result, len);
for i := 0 to len -1 do
result[i] := HslToRgb(hslArr[i]);
end;
//------------------------------------------------------------------------------
function NameToId(Name: PChar): Longint;
begin
if Cardinal(PWord(Name)) < 30 then
begin
Result := Cardinal(PWord(Name))
end else
begin
if Name^ = '#' then inc(Name);
Result := StrToIntDef(Name, 0);
if Result > 65535 then Result := 0;
end;
end;
//------------------------------------------------------------------------------
function CreateResourceStream(const resName: string;
resType: PChar): TResourceStream;
var
nameId, typeId: Cardinal;
begin
Result := nil;
typeId := NameToId(resType);
if (typeId > 0) then resType := PChar(typeId)
else if (resType = 'BMP') then resType := RT_BITMAP;
nameId := NameToId(PChar(resName));
if nameId > 0 then
begin
if FindResource(hInstance, PChar(nameId), resType) <> 0 then
Result := TResourceStream.CreateFromID(hInstance, nameId, resType);
end else
begin
if FindResource(hInstance, PChar(resName), resType) <> 0 then
Result := TResourceStream.Create(hInstance, PChar(resName), resType);
end;
end;
//------------------------------------------------------------------------------
// TRectD methods (and helpers)
//------------------------------------------------------------------------------
function TRectD.IsEmpty: Boolean;
begin
result := (right <= left) or (bottom <= top);
end;
//------------------------------------------------------------------------------
function TRectD.Width: double;
begin
result := Max(0, right - left);
end;
//------------------------------------------------------------------------------
function TRectD.Height: double;
begin
result := Max(0, bottom - top);
end;
//------------------------------------------------------------------------------
function TRectD.MidPoint: TPointD;
begin
Result.X := (Right + Left)/2;
Result.Y := (Bottom + Top)/2;
end;
//------------------------------------------------------------------------------
{$IFNDEF RECORD_METHODS}
function TRectD.TopLeft: TPointD;
begin
Result.X := Left;
Result.Y := Top;
end;
//------------------------------------------------------------------------------
function TRectD.BottomRight: TPointD;
begin
Result.X := Right;
Result.Y := Bottom;
end;
//------------------------------------------------------------------------------
{$ENDIF}
function TRectD.Normalize: Boolean;
var
d: double;
begin
Result := false;
if Left > Right then
begin
d := Left;
Left := Right;
Right := d;
Result := True;
end;
if Top > Bottom then
begin
d := Top;
Top := Bottom;
Bottom := d;
Result := True;
end;
end;
//------------------------------------------------------------------------------
function TRectD.Contains(const Pt: TPoint): Boolean;
begin
Result := (pt.X >= Left) and (pt.X < Right) and
(pt.Y >= Top) and (pt.Y < Bottom);
end;
//------------------------------------------------------------------------------
function TRectD.Contains(const Pt: TPointD): Boolean;
begin
Result := (pt.X >= Left) and (pt.X < Right) and
(pt.Y >= Top) and (pt.Y < Bottom);
end;
//------------------------------------------------------------------------------
function RectD(left, top, right, bottom: double): TRectD;
begin
result.Left := left;
result.Top := top;
result.Right := right;
result.Bottom := bottom;
end;
//------------------------------------------------------------------------------
function RectD(const rec: TRect): TRectD;
begin
with rec do
begin
result.Left := left;
result.Top := top;
result.Right := right;
result.Bottom := bottom;
end;
end;
//------------------------------------------------------------------------------
// TImage32 methods
//------------------------------------------------------------------------------
constructor TImage32.Create(width: Integer; height: Integer);
begin
fAntiAliased := true;
fResampler := DefaultResampler;
fwidth := Max(0, width);
fheight := Max(0, height);
SetLength(fPixels, fwidth * fheight);
end;
//------------------------------------------------------------------------------
constructor TImage32.Create(src: TImage32);
begin
Assign(src);
end;
//------------------------------------------------------------------------------
constructor TImage32.Create(src: TImage32; const srcRec: TRect);
var
rec: TRect;
begin
fAntiAliased := src.AntiAliased;
fResampler := src.fResampler;
types.IntersectRect(rec, src.Bounds, srcRec);
RectWidthHeight(rec, fWidth, fHeight);
SetLength(fPixels, fWidth * fHeight);
if (fWidth = 0) or (fheight = 0) then Exit;
fPixels := src.CopyPixels(srcRec);
end;
//------------------------------------------------------------------------------
destructor TImage32.Destroy;
begin
fPixels := nil;
inherited;
end;
//------------------------------------------------------------------------------
class function TImage32.IsRegisteredFormat(const ext: string): Boolean;
begin
result := Assigned(TImage32.GetImageFormatClass(ext));
end;
//------------------------------------------------------------------------------
class procedure TImage32.RegisterImageFormatClass(ext: string;
bm32ExClass: TImageFormatClass; clipPriority: TClipboardPriority);
var
i: Integer;
imgFmtRec: PImgFmtRec;
isNewFormat: Boolean;
begin
if not Assigned(ImageFormatClassList) then CreateImageFormatList;
if (ext = '') or (ext = '.') then Exit;
if (ext[1] = '.') then Delete(ext, 1,1);
if not IsAlphaChar(ext[1]) then Exit;
isNewFormat := true;
// avoid duplicates but still allow overriding
for i := 0 to imageFormatClassList.count -1 do
begin
imgFmtRec := PImgFmtRec(imageFormatClassList[i]);
if SameText(imgFmtRec.Fmt, ext) then
begin
imgFmtRec.Obj := bm32ExClass; // replace prior class
if imgFmtRec.SortOrder = clipPriority then
Exit; // re-sorting isn't required
imgFmtRec.SortOrder := clipPriority;
isNewFormat := false;
Break;
end;
end;
if isNewFormat then
begin
new(imgFmtRec);
imgFmtRec.Fmt := ext;
imgFmtRec.SortOrder := clipPriority;
imgFmtRec.Obj := bm32ExClass;
ImageFormatClassList.Add(imgFmtRec);
end;
// Sort with lower priority before higher.
// Sorting here is arguably inefficient but, with so few
// entries, this inefficiency will be inconsequential.
{$IFDEF XPLAT_GENERICS}
ImageFormatClassList.Sort(TComparer.Construct(
function(const imgFmtRec1, imgFmtRec2: PImgFmtRec): Integer
begin
Result := Integer(imgFmtRec1.SortOrder) - Integer(imgFmtRec2.SortOrder);
end));
{$ELSE}
ImageFormatClassList.Sort(ImageFormatClassListSort);
{$ENDIF}
end;
//------------------------------------------------------------------------------
class function TImage32.GetImageFormatClass(const ext: string): TImageFormatClass;
var
i: Integer;
pattern: string;
imgFmtRec: PImgFmtRec;
begin
Result := nil;
pattern := ext;
if (pattern = '') or (pattern = '.') then Exit;
if pattern[1] = '.' then Delete(pattern, 1,1);
//try for highest priority first
for i := imageFormatClassList.count -1 downto 0 do
begin
imgFmtRec := PImgFmtRec(imageFormatClassList[i]);
if not SameText(imgFmtRec.Fmt, pattern) then Continue;
Result := imgFmtRec.Obj;
break;
end;
end;
//------------------------------------------------------------------------------
class function TImage32.GetImageFormatClass(stream: TStream): TImageFormatClass;
var
i: integer;
begin
Result := nil;
for i := 0 to imageFormatClassList.count -1 do
with PImgFmtRec(imageFormatClassList[i])^ do
if Obj.IsValidImageStream(stream) then
begin
Result := Obj;
break;
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.Assign(src: TImage32);
begin
if assigned(src) then
src.AssignTo(self);
end;
//------------------------------------------------------------------------------
procedure TImage32.AssignTo(dst: TImage32);
begin
if dst = self then Exit;
dst.BeginUpdate;
try
dst.fResampler := fResampler;
dst.fIsPremultiplied := fIsPremultiplied;
dst.fAntiAliased := fAntiAliased;
dst.fColorCount := 0;
try
dst.SetSize(Width, Height);
if (Width > 0) and (Height > 0) then
move(fPixels[0], dst.fPixels[0], Width * Height * SizeOf(TColor32));
except
dst.SetSize(0,0);
end;
finally
dst.EndUpdate;
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.Changed;
begin
if fUpdateCnt <> 0 then Exit;
fColorCount := 0;
if Assigned(fOnChange) then fOnChange(Self);
end;
//------------------------------------------------------------------------------
procedure TImage32.Resized;
begin
if fUpdateCnt <> 0 then Exit
else if Assigned(fOnResize) then fOnResize(Self)
else Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.BeginUpdate;
begin
if fNotifyBlocked then Exit;
inc(fUpdateCnt);
end;
//------------------------------------------------------------------------------
procedure TImage32.EndUpdate;
begin
if fNotifyBlocked then Exit;
dec(fUpdateCnt);
if fUpdateCnt = 0 then Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.BlockNotify;
begin
if fUpdateCnt <> 0 then Exit;
inc(fUpdateCnt);
fNotifyBlocked := true;
end;
//------------------------------------------------------------------------------
procedure TImage32.UnblockNotify;
begin
if not fNotifyBlocked then Exit;
dec(fUpdateCnt);
fNotifyBlocked := false;
end;
//------------------------------------------------------------------------------
procedure TImage32.SetBackgroundColor(bgColor: TColor32);
var
i: Integer;
pc: PColor32;
begin
pc := Pixelbase;
for i := 0 to high(fPixels) do
begin
pc^ := BlendToOpaque(bgColor, pc^);
inc(pc);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.Clear(color: TColor32);
var
i: Integer;
pc: PColor32;
begin
fIsPremultiplied := false;
if IsEmpty then Exit;
if color = clNone32 then
FillChar(fPixels[0], Width * Height * SizeOf(TColor32), 0)
else
begin
pc := PixelBase;
for i := 0 to Width * Height -1 do
begin
pc^ := color;
inc(pc);
end;
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.Clear(const rec: TRect; color: TColor32 = 0);
begin
FillRect(rec, color);
end;
//------------------------------------------------------------------------------
procedure TImage32.FillRect(rec: TRect; color: TColor32);
var
i,j, rw: Integer;
c: PColor32;
begin
Types.IntersectRect(rec, rec, bounds);
if IsEmptyRect(rec) then Exit;
rw := RectWidth(rec);
c := @Pixels[rec.Top * Width + rec.Left];
for i := rec.Top to rec.Bottom -1 do
begin
for j := 1 to rw do
begin
c^ := color;
inc(c);
end;
inc(c, Width - rw);
end;
Changed;
end;
//------------------------------------------------------------------------------
function TImage32.RectHasTransparency(rec: TRect): Boolean;
var
i,j, rw: Integer;
c: PARGB;
begin
Result := True;
Types.IntersectRect(rec, rec, bounds);
if IsEmptyRect(rec) then Exit;
rw := RectWidth(rec);
c := @Pixels[rec.Top * Width + rec.Left];
for i := rec.Top to rec.Bottom -1 do
begin
for j := 1 to rw do
begin
if c.A < 254 then Exit;
inc(c);
end;
inc(c, Width - rw);
end;
Result := False;
end;
//------------------------------------------------------------------------------
procedure CheckBlendFill(pc: PColor32; color: TColor32);
{$IFDEF INLINE} inline; {$ENDIF}
begin
if not assigned(pc) then Exit;
pc^ := BlendToAlpha(pc^, color);
end;
//------------------------------------------------------------------------------
function TImage32.CopyPixels(rec: TRect): TArrayOfColor32;
var
i, clipW, w,h: Integer;
pSrc, pDst, pDst2: PColor32;
recClipped: TRect;
begin
RectWidthHeight(rec, w,h);
setLength(result, w * h);
if w * h = 0 then Exit;
Types.IntersectRect(recClipped, rec, Bounds);
//if recClipped is wholely outside the bounds of the image ...
if IsEmptyRect(recClipped) then
begin
//rec is considered valid even when completely outside the image bounds,
//and so when that happens we simply return a fully transparent image ...
FillChar(Result[0], w * h * SizeOf(TColor32), 0);
Exit;
end;
//if recClipped is wholely within the bounds of the image ...
if RectsEqual(recClipped, rec) then
begin
pDst := @Result[0];
pSrc := @fPixels[recClipped.Top * Width + rec.Left];
for i := recClipped.Top to recClipped.Bottom -1 do
begin
Move(pSrc^, pDst^, w * SizeOf(TColor32));
inc(pSrc, Width); inc(pDst, w);
end;
Exit;
end;
//a part of 'rec' must be outside the bounds of the image ...
pDst := @Result[0];
for i := rec.Top to -1 do
begin
FillChar(pDst^, w * SizeOf(TColor32), 0);
inc(pDst, w);
end;
pSrc := @fPixels[recClipped.Top * Width + Max(0,rec.Left)];
if (rec.Left < 0) or (rec.Right > Width) then
begin
clipW := RectWidth(recClipped);
pDst2 := IncPColor32(pDst, -Min(0, rec.Left));
for i := recClipped.Top to recClipped.Bottom -1 do
begin
//when rec.left < 0 or rec.right > width it's simplest to
//start with a prefilled row of transparent pixels
FillChar(pDst^, w * SizeOf(TColor32), 0);
Move(pSrc^, pDst2^, clipW * SizeOf(TColor32));
inc(pDst, w); inc(pDst2, w); inc(pSrc, Width);
end;
end else
begin
//things are simpler when there's no part of 'rec' is
//outside the image, at least not on the left or right sides ...
for i := recClipped.Top to recClipped.Bottom -1 do
begin
Move(pSrc^, pDst^, w * SizeOf(TColor32));
inc(pSrc, Width); inc(pDst, w);
end;
end;
for i := Height to rec.Bottom -1 do
begin
FillChar(pDst^, w * SizeOf(TColor32), 0);
inc(pDst, w);
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.Crop(const rec: TRect);
var
newPixels: TArrayOfColor32;
w,h: integer;
begin
RectWidthHeight(rec, w, h);
if (w = Width) and (h = Height) then Exit;
newPixels := CopyPixels(rec);
BlockNotify;
try
SetSize(w, h);
if not IsEmptyRect(rec) then
fPixels := newPixels;
finally
UnblockNotify;
end;
Resized;
end;
//------------------------------------------------------------------------------
function TImage32.GetBounds: TRect;
begin
result := Types.Rect(0, 0, Width, Height);
end;
//------------------------------------------------------------------------------
function TImage32.GetMidPoint: TPointD;
begin
Result := PointD(fWidth * 0.5, fHeight * 0.5);
end;
//------------------------------------------------------------------------------
procedure TImage32.SetSize(newWidth, newHeight: Integer; color: TColor32);
begin
//very large images are usually due to a bug
if (newWidth > 20000) or (newHeight > 20000) then
raise Exception.Create(rsImageTooLarge);
fwidth := Max(0, newWidth);
fheight := Max(0, newHeight);
fPixels := nil; //forces a blank image
SetLength(fPixels, fwidth * fheight);
fIsPremultiplied := false;
if color > 0 then
begin
BlockNotify;
Clear(color);
UnblockNotify;
end;
Resized;
end;
//------------------------------------------------------------------------------
procedure TImage32.Resize(newWidth, newHeight: Integer; stretchImage: Boolean);
var
tmp: TImage32;
rec: TRect;
begin
if (newWidth <= 0) or (newHeight <= 0) then
begin
SetSize(0, 0);
Exit;
end
else if (newWidth = fwidth) and (newHeight = fheight) then
begin
Exit
end
else if IsEmpty then
begin
SetSize(newWidth, newHeight);
Exit;
end;
BlockNotify;
try
if stretchImage then
begin
if fResampler = 0 then
NearestNeighborResize(newWidth, newHeight)
else
ResamplerResize(newWidth, newHeight);
end else
begin
tmp := TImage32.create(self);
try
rec := Bounds;
SetSize(newWidth, newHeight, clNone32);
Copy(tmp, rec, rec); //this will clip as required.
finally
tmp.Free;
end;
end;
finally
UnblockNotify;
end;
Resized;
end;
//------------------------------------------------------------------------------
procedure TImage32.NearestNeighborResize(newWidth, newHeight: Integer);
var
x, y, srcY: Integer;
scaledXi, scaledYi: TArrayOfInteger;
tmp: TArrayOfColor32;
pc: PColor32;
begin
//this NearestNeighbor code is slightly more efficient than
//the more general purpose one in Img32.Resamplers
if (newWidth = fWidth) and (newHeight = fHeight) then Exit;
SetLength(tmp, newWidth * newHeight * SizeOf(TColor32));
//get scaled X & Y values once only (storing them in lookup arrays) ...
SetLength(scaledXi, newWidth);
for x := 0 to newWidth -1 do
scaledXi[x] := Floor(x * fWidth / newWidth);
SetLength(scaledYi, newHeight);
for y := 0 to newHeight -1 do
scaledYi[y] := Floor(y * fHeight / newHeight);
pc := @tmp[0];
for y := 0 to newHeight - 1 do
begin
srcY := scaledYi[y];
if (srcY < 0) or (srcY >= fHeight) then Continue;
for x := 0 to newWidth - 1 do
begin
pc^ := fPixels[scaledXi[x] + srcY * fWidth];
inc(pc);
end;
end;
fPixels := tmp;
fwidth := newWidth;
fheight := newHeight;
end;
//------------------------------------------------------------------------------
procedure TImage32.ResamplerResize(newWidth, newHeight: Integer);
var
mat: TMatrixD;
begin
mat := IdentityMatrix;
MatrixScale(mat, newWidth/fWidth, newHeight/fHeight);
AffineTransformImage(self, mat);
end;
//------------------------------------------------------------------------------
procedure TImage32.Scale(s: double);
begin
Scale(s, s);
end;
//------------------------------------------------------------------------------
procedure TImage32.Scale(sx, sy: double);
begin
//sx := Min(sx, 100); sy := Min(sy, 100);
if (sx > 0) and (sy > 0) then
ReSize(Round(width * sx), Round(height * sy));
end;
//------------------------------------------------------------------------------
procedure TImage32.ScaleToFit(width, height: integer);
var
sx, sy: double;
begin
if IsEmpty or (width <= 0) or (height <= 0) then Exit;
sx := width / self.Width;
sy := height / self.Height;
if sx <= sy then
Scale(sx) else
Scale(sy);
end;
//------------------------------------------------------------------------------
procedure TImage32.ScaleToFitCentered(const rect: TRect);
begin
ScaleToFitCentered(RectWidth(rect), RectHeight(rect));
end;
//------------------------------------------------------------------------------
procedure TImage32.ScaleToFitCentered(width, height: integer);
var
sx, sy: double;
tmp: TImage32;
rec2: TRect;
begin
if IsEmpty or (width <= 0) or (height <= 0) or
((width = self.Width) and (height = self.Height)) then Exit;
sx := width / self.Width;
sy := height / self.Height;
BlockNotify;
try
if sx <= sy then
begin
Scale(sx);
if height = self.Height then Exit;
rec2 := Bounds;
Types.OffsetRect(rec2, 0, (height - self.Height) div 2);
tmp := TImage32.Create(self);
try
SetSize(width, height);
CopyInternal(tmp, tmp.Bounds, rec2, nil);
finally
tmp.Free;
end;
end else
begin
Scale(sy);
if width = self.Width then Exit;
rec2 := Bounds;
Types.OffsetRect(rec2, (width - self.Width) div 2, 0);
tmp := TImage32.Create(self);
try
SetSize(width, height);
CopyInternal(tmp, tmp.Bounds, rec2, nil);
finally
tmp.Free;
end;
end;
finally
UnblockNotify;
end;
Resized;
end;
//------------------------------------------------------------------------------
procedure TImage32.RotateLeft90;
var
x,y, xx: Integer;
src, dst: PColor32;
tmp: TImage32;
begin
if IsEmpty then Exit;
BeginUpdate;
tmp := TImage32.create(Self);
try
SetSize(Height, Width);
xx := (width - 1) * Height;
dst := PixelBase;
for y := 0 to Height -1 do
begin
src := @tmp.Pixels[xx + y];
for x := 0 to Width -1 do
begin
dst^ := src^;
inc(dst); dec(src, Height);
end;
end;
finally
tmp.Free;
EndUpdate;
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.RotateRight90;
var
x,y: Integer;
src, dst: PColor32;
tmp: TImage32;
begin
if IsEmpty then Exit;
BeginUpdate;
tmp := TImage32.create(Self);
try
SetSize(Height, Width);
dst := PixelBase;
for y := 0 to Height -1 do
begin
src := @tmp.Pixels[Height -1 - y];
for x := 0 to Width -1 do
begin
dst^ := src^;
inc(dst); inc(src, Height);
end;
end;
finally
tmp.Free;
EndUpdate;
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.Rotate180;
var
x,y: Integer;
src, dst: PColor32;
tmp: TImage32;
begin
if IsEmpty then Exit;
tmp := TImage32.create(Self);
try
dst := PixelBase;
src := @tmp.Pixels[Width * Height -1];
for y := 0 to Height -1 do
begin
for x := 0 to Width -1 do
begin
dst^ := src^;
inc(dst); dec(src);
end;
end;
finally
tmp.Free;
end;
Changed;
end;
//------------------------------------------------------------------------------
function TImage32.GetColorCount: Integer;
var
allColors: PByteArray;
i: Integer;
c: PColor32;
const
cube256 = 256 * 256 * 256;
begin
result := 0;
if IsEmpty then Exit;
if fColorCount > 0 then
begin
result := fColorCount;
Exit;
end;
//because 'allColors' uses quite a chunk of memory, it's
//allocated on the heap rather than the stack
allColors := AllocMem(cube256); //nb: zero initialized
try
c := PixelBase;
for i := 0 to Width * Height -1 do
begin
//ignore colors with signifcant transparency
if GetAlpha(c^) > $80 then
allColors[c^ and $FFFFFF] := 1;
inc(c);
end;
for i := 0 to cube256 -1 do
if allColors[i] = 1 then inc(Result);
finally
FreeMem(allColors);
end;
fColorCount := Result; //avoids repeating the above unnecessarily
end;
//------------------------------------------------------------------------------
function TImage32.GetHasTransparency: Boolean;
var
i: Integer;
pc: PARGB;
begin
result := true;
If IsEmpty then Exit;
pc := PARGB(PixelBase);
for i := 0 to Width * Height -1 do
begin
if pc.A < 255 then Exit;
inc(pc);
end;
result := false;
end;
//------------------------------------------------------------------------------
function TImage32.SaveToFile(filename: string): Boolean;
var
fileFormatClass: TImageFormatClass;
begin
result := false;
if IsEmpty or (length(filename) < 5) then Exit;
//use the process's current working directory if no path supplied ...
if ExtractFilePath(filename) = '' then
filename := GetCurrentDir + '\'+ filename;
fileFormatClass := GetImageFormatClass(ExtractFileExt(filename));
if assigned(fileFormatClass) then
with fileFormatClass.Create do
try
result := SaveToFile(filename, self);
finally
free;
end;
end;
//------------------------------------------------------------------------------
function TImage32.SaveToStream(stream: TStream; const FmtExt: string): Boolean;
var
fileFormatClass: TImageFormatClass;
begin
result := false;
fileFormatClass := GetImageFormatClass(FmtExt);
if assigned(fileFormatClass) then
with fileFormatClass.Create do
try
SaveToStream(stream, self);
result := true;
finally
free;
end;
end;
//------------------------------------------------------------------------------
function TImage32.LoadFromFile(const filename: string): Boolean;
var
stream: TFileStream;
begin
Result := false;
if not FileExists(filename) then Exit;
stream := TFileStream.Create(filename, fmOpenRead or fmShareDenyNone);
try
result := LoadFromStream(stream);
finally
stream.Free;
end;
end;
//------------------------------------------------------------------------------
function TImage32.LoadFromStream(stream: TStream): Boolean;
var
ifc: TImageFormatClass;
begin
ifc := GetImageFormatClass(stream);
Result := Assigned(ifc);
if not Result then Exit;
with ifc.Create do
try
result := LoadFromStream(stream, self);
finally
free;
end;
end;
//------------------------------------------------------------------------------
function TImage32.GetPixel(x, y: Integer): TColor32;
begin
if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then
result := clNone32 else
result := fPixels[y * width + x];
end;
//------------------------------------------------------------------------------
procedure TImage32.SetPixel(x,y: Integer; color: TColor32);
begin
if (x < 0) or (x >= Width) or (y < 0) or (y >= Height) then Exit;
fPixels[y * width + x] := color;
//nb: no notify event here
end;
//------------------------------------------------------------------------------
function TImage32.GetIsBlank: Boolean;
var
i: integer;
pc: PARGB;
begin
result := IsEmpty;
if result then Exit;
pc := PARGB(PixelBase);
for i := 0 to width * height -1 do
begin
if pc.A > 0 then Exit;
inc(pc);
end;
result := true;
end;
//------------------------------------------------------------------------------
function TImage32.GetIsEmpty: Boolean;
begin
result := fPixels = nil;
end;
//------------------------------------------------------------------------------
function TImage32.GetPixelBase: PColor32;
begin
if IsEmpty then result := nil
else result := @fPixels[0];
end;
//------------------------------------------------------------------------------
function TImage32.GetPixelRow(row: Integer): PColor32;
begin
if IsEmpty then result := nil
else result := @fPixels[row * Width];
end;
//------------------------------------------------------------------------------
procedure TImage32.CopyInternal(src: TImage32;
const srcRec, dstRec: TRect; blendFunc: TBlendFunction);
var
i, j, srcRecWidth, srcRecHeight: Integer;
s, d: PColor32;
begin
// occasionally, due to rounding, srcRec and dstRec
// don't have exactly the same widths and heights, so ...
srcRecWidth :=
Min(srcRec.Right - srcRec.Left, dstRec.Right - dstRec.Left);
srcRecHeight :=
Min(srcRec.Bottom - srcRec.Top, dstRec.Bottom - dstRec.Top);
s := @src.Pixels[srcRec.Top * src.Width + srcRec.Left];
d := @Pixels[dstRec.top * Width + dstRec.Left];
if assigned(blendFunc) then
for i := srcRec.Top to srcRec.Top + srcRecHeight -1 do
begin
for j := 1 to srcRecWidth do
begin
d^ := blendFunc(d^, s^);
inc(s); inc(d);
end;
inc(s, src.Width - srcRecWidth);
inc(d, Width - srcRecWidth);
end
else
//simply overwrite src with dst (ie without blending)
for i := srcRec.Top to srcRec.Top + srcRecHeight -1 do
begin
move(s^, d^, srcRecWidth * SizeOf(TColor32));
inc(s, src.Width);
inc(d, Width);
end;
end;
//------------------------------------------------------------------------------
function TImage32.Copy(src: TImage32; srcRec, dstRec: TRect): Boolean;
begin
Result := CopyBlend(src, srcRec, dstRec, nil);
end;
//------------------------------------------------------------------------------
function TImage32.CopyBlend(src: TImage32; srcRec, dstRec: TRect;
blendFunc: TBlendFunction): Boolean;
var
tmp: TImage32;
srcRecClipped, dstRecClipped, r: TRect;
scaleX, scaleY: double;
w,h, dstW,dstH, srcW,srcH: integer;
begin
result := false;
if IsEmptyRect(srcRec) or IsEmptyRect(dstRec) then Exit;
Types.IntersectRect(srcRecClipped, srcRec, src.Bounds);
//get the scaling amount (if any) before
//dstRec might be adjusted due to clipping ...
RectWidthHeight(dstRec, dstW, dstH);
RectWidthHeight(srcRec, srcW, srcH);
//watching out for insignificant scaling
if Abs(dstW - srcW) < 2 then
scaleX := 1 else
scaleX := dstW / srcW;
if Abs(dstH - srcH) < 2 then
scaleY := 1 else
scaleY := dstH / srcH;
//check if the source rec has been clipped ...
if not RectsEqual(srcRecClipped, srcRec) then
begin
if IsEmptyRect(srcRecClipped) then Exit;
//the source has been clipped so clip the destination too ...
RectWidthHeight(srcRecClipped, w, h);
RectWidthHeight(srcRec, srcW, srcH);
ScaleRect(dstRec, w / srcW, h / srcH);
Types.OffsetRect(dstRec,
srcRecClipped.Left - srcRec.Left,
srcRecClipped.Top - srcRec.Top);
end;
if (scaleX <> 1.0) or (scaleY <> 1.0) then
begin
//scale source (tmp) to the destination then call CopyBlend() again ...
tmp := TImage32.Create(src, srcRecClipped);
try
tmp.Scale(scaleX, scaleY);
result := CopyBlend(tmp, tmp.Bounds, dstRec, blendFunc);
finally
tmp.Free;
end;
Exit;
end;
Types.IntersectRect(dstRecClipped, dstRec, Bounds);
if IsEmptyRect(dstRecClipped) then Exit;
//there's no scaling if we get here, but further clipping may be needed if
//the destination rec is partially outside the destination image's bounds
if not RectsEqual(dstRecClipped, dstRec) then
begin
//the destination rec has been clipped so clip the source too ...
RectWidthHeight(dstRecClipped, w, h);
RectWidthHeight(dstRec, dstW, dstH);
ScaleRect(srcRecClipped, w / dstW, h / dstH);
Types.OffsetRect(srcRecClipped,
dstRecClipped.Left - dstRec.Left,
dstRecClipped.Top - dstRec.Top);
end;
//when copying to self and srcRec & dstRec overlap then
//copy srcRec to a temporary image and use it as the source ...
if (src = self) and Types.IntersectRect(r, srcRecClipped, dstRecClipped) then
begin
tmp := TImage32.Create(self, srcRecClipped);
try
result := src.CopyBlend(tmp, tmp.Bounds, dstRecClipped, blendFunc);
finally
tmp.Free;
end;
Exit;
end;
CopyInternal(src, srcRecClipped, dstRecClipped, blendFunc);
result := true;
Changed;
end;
//------------------------------------------------------------------------------
function TImage32.LoadFromResource(const resName: string; resType: PChar): Boolean;
var
resStream: TResourceStream;
begin
resStream := CreateResourceStream(resName, resType);
try
Result := assigned(resStream) and
LoadFromStream(resStream);
finally
resStream.Free;
end;
end;
//------------------------------------------------------------------------------
{$IFDEF MSWINDOWS}
procedure TImage32.CopyFromDC(srcDc: HDC; const srcRect: TRect);
var
bi: TBitmapInfoHeader;
bm, oldBm: HBitmap;
dc, memDc: HDC;
pixels: Pointer;
w,h: integer;
begin
BeginUpdate;
try
RectWidthHeight(srcRect, w,h);
SetSize(w, h);
bi := Get32bitBitmapInfoHeader(w, h);
dc := GetDC(0);
memDc := CreateCompatibleDC(dc);
try
bm := CreateDIBSection(dc,
PBITMAPINFO(@bi)^, DIB_RGB_COLORS, pixels, 0, 0);
if bm = 0 then Exit;
try
oldBm := SelectObject(memDc, bm);
BitBlt(memDc, 0, 0, w, h, srcDc, srcRect.Left,srcRect.Top, SRCCOPY);
Move(pixels^, fPixels[0], w * h * sizeOf(TColor32));
SelectObject(memDc, oldBm);
finally
DeleteObject(bm);
end;
finally
DeleteDc(memDc);
ReleaseDc(0, dc);
end;
if IsBlank then SetAlpha(255);
FlipVertical;
finally
EndUpdate;
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.CopyToDc(dstDc: HDC; x,y: Integer; transparent: Boolean);
begin
CopyToDc(Bounds, Types.Rect(x,y, x+Width, y+Height),
dstDc, transparent);
end;
//------------------------------------------------------------------------------
procedure TImage32.CopyToDc(const srcRect: TRect; dstDc: HDC;
x: Integer = 0; y: Integer = 0; transparent: Boolean = true);
var
recW, recH: integer;
begin
RectWidthHeight(srcRect, recW, recH);
CopyToDc(srcRect, Types.Rect(x,y, x+recW, y+recH), dstDc, transparent);
end;
//------------------------------------------------------------------------------
procedure TImage32.CopyToDc(const srcRect, dstRect: TRect;
dstDc: HDC; transparent: Boolean = true);
var
i, x,y, wSrc ,hSrc, wDest, hDest: integer;
rec: TRect;
bi: TBitmapInfoHeader;
bm, oldBm: HBitmap;
dibBits: Pointer;
pc: PARGB;
memDc: HDC;
isTransparent: Boolean;
bf: BLENDFUNCTION;
begin
Types.IntersectRect(rec, srcRect, Bounds);
if IsEmpty or IsEmptyRect(rec) or IsEmptyRect(dstRect) then Exit;
RectWidthHeight(rec, wSrc, hSrc);
RectWidthHeight(dstRect, wDest, hDest);
x := dstRect.Left;
y := dstRect.Top;
inc(x, rec.Left - srcRect.Left);
inc(y, rec.Top - srcRect.Top);
bi := Get32bitBitmapInfoHeader(wSrc, hSrc);
isTransparent := transparent and RectHasTransparency(srcRect);
memDc := CreateCompatibleDC(0);
try
bm := CreateDIBSection(memDc, PBITMAPINFO(@bi)^,
DIB_RGB_COLORS, dibBits, 0, 0);
if bm = 0 then Exit;
try
//copy Image to dibBits (with vertical flip)
pc := dibBits;
for i := rec.Bottom -1 downto rec.Top do
begin
Move(Pixels[i * Width + rec.Left], pc^, wSrc * SizeOf(TColor32));
inc(pc, wSrc);
end;
oldBm := SelectObject(memDC, bm);
if isTransparent then
begin
//premultiplied alphas are required when alpha blending
pc := dibBits;
for i := 0 to wSrc * hSrc -1 do
begin
if pc.A > 0 then
begin
pc.R := MulTable[pc.R, pc.A];
pc.G := MulTable[pc.G, pc.A];
pc.B := MulTable[pc.B, pc.A];
end else
pc.Color := 0;
inc(pc);
end;
bf.BlendOp := AC_SRC_OVER;
bf.BlendFlags := 0;
bf.SourceConstantAlpha := 255;
bf.AlphaFormat := AC_SRC_ALPHA;
AlphaBlend(dstDc, x,y, wDest,hDest, memDC, 0,0, wSrc,hSrc, bf);
end
else if (wDest = wSrc) and (hDest = hSrc) then
BitBlt(dstDc, x,y, wSrc, hSrc, memDc, 0,0, SRCCOPY)
else
StretchBlt(dstDc, x,y, wDest, hDest, memDc, 0,0, wSrc,hSrc, SRCCOPY);
SelectObject(memDC, oldBm);
finally
DeleteObject(bm);
end;
finally
DeleteDc(memDc);
end;
end;
//------------------------------------------------------------------------------
{$ENDIF}
function TImage32.CopyToClipBoard: Boolean;
var
i: Integer;
formatClass: TImageFormatClass;
begin
//Sadly with CF_DIB (and even CF_DIBV5) clipboard formats, transparency is
//usually lost, so we'll copy all available formats including CF_PNG, that
//is if it's registered.
result := not IsEmpty;
if not result then Exit;
result := false;
for i := ImageFormatClassList.Count -1 downto 0 do
begin
formatClass := PImgFmtRec(ImageFormatClassList[i]).Obj;
if not formatClass.CanCopyToClipboard then Continue;
with formatClass.Create do
try
result := CopyToClipboard(self);
finally
free;
end;
end;
end;
//------------------------------------------------------------------------------
class function TImage32.CanPasteFromClipBoard: Boolean;
var
i: Integer;
formatClass: TImageFormatClass;
begin
result := false;
for i := ImageFormatClassList.Count -1 downto 0 do
begin
formatClass := PImgFmtRec(ImageFormatClassList[i]).Obj;
if formatClass.CanPasteFromClipboard then
begin
result := true;
Exit;
end;
end;
end;
//------------------------------------------------------------------------------
function TImage32.PasteFromClipBoard: Boolean;
var
i: Integer;
formatClass: TImageFormatClass;
begin
result := false;
for i := ImageFormatClassList.Count -1 downto 0 do
begin
formatClass := PImgFmtRec(ImageFormatClassList[i]).Obj;
if not formatClass.CanPasteFromClipboard then Continue;
with formatClass.Create do
try
result := PasteFromClipboard(self);
if not Result then Continue;
finally
free;
end;
Changed;
Break;
end;
end;
//------------------------------------------------------------------------------
{$IFDEF USING_VCL_LCL}
procedure TImage32.CopyFromBitmap(bmp: TBitmap);
var
savedPF: TPixelFormat;
{$IFNDEF MSWINDOWS}
i: integer;
pxDst, pxSrc: PColor32;
{$ENDIF}
begin
if not Assigned(bmp) then Exit;
savedPF := bmp.PixelFormat;
bmp.PixelFormat := pf32bit;
SetSize(bmp.Width, bmp.Height);
{$IFDEF MSWINDOWS}
GetBitmapBits(bmp.Handle, Width * Height * 4, PixelBase);
{$ELSE}
for i := 0 to bmp.Height -1 do
begin
pxSrc := bmp.ScanLine[i];
pxDst := PixelRow[i];
Move(pxSrc^, pxDst^, bmp.Width * SizeOf(TColor32));
end;
{$ENDIF}
bmp.PixelFormat := savedPF;
end;
//------------------------------------------------------------------------------
procedure TImage32.CopyToBitmap(bmp: TBitmap);
{$IFNDEF MSWINDOWS}
var
i: integer;
pxDst, pxSrc: PColor32;
{$ENDIF}
begin
if not Assigned(bmp) then Exit;
bmp.PixelFormat := pf32bit;
bmp.Width := Width;
bmp.Height := Height;
{$IFDEF MSWINDOWS}
{$IFNDEF FPC}
{$IFDEF ALPHAFORMAT}
bmp.AlphaFormat := afDefined;
{$ENDIF}
{$ENDIF}
SetBitmapBits(bmp.Handle, Width * Height * 4, PixelBase);
{$ELSE}
for i := 0 to bmp.Height -1 do
begin
pxDst := bmp.ScanLine[i];
pxSrc := PixelRow[i];
Move(pxSrc^, pxDst^, bmp.Width * SizeOf(TColor32));
end;
{$ENDIF}
end;
//------------------------------------------------------------------------------
{$ENDIF}
procedure TImage32.ConvertToBoolMask(reference: TColor32; tolerance: integer;
colorFunc: TCompareFunction; maskBg: TColor32; maskFg: TColor32);
var
i: Integer;
mask: TArrayOfByte;
c: PColor32;
b: PByte;
begin
if IsEmpty then Exit;
mask := GetBoolMask(self, reference, colorFunc, tolerance);
c := PixelBase;
b := @mask[0];
for i := 0 to Width * Height -1 do
begin
{$IFDEF PBYTE}
if b^ = 0 then c^ := maskBg else c^ := maskFg;
{$ELSE}
if b^ = #0 then c^ := maskBg else c^ := maskFg;
{$ENDIF}
inc(c); inc(b);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.ConvertToAlphaMask(reference: TColor32;
colorFunc: TCompareFunctionEx);
var
i: Integer;
mask: TArrayOfByte;
c: PColor32;
b: PByte;
begin
if IsEmpty then Exit;
mask := GetByteMask(self, reference, colorFunc);
c := PixelBase;
b := @mask[0];
for i := 0 to Width * Height -1 do
begin
{$IFDEF PBYTE}
c^ := b^ shl 24;
{$ELSE}
c^ := Ord(b^) shl 24;
{$ENDIF}
inc(c); inc(b);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.FlipVertical;
var
i: Integer;
a: TArrayOfColor32;
src, dst: PColor32;
begin
if IsEmpty then Exit;
SetLength(a, fWidth * fHeight);
src := @fPixels[(height-1) * width];
dst := @a[0];
for i := 0 to fHeight -1 do
begin
move(src^, dst^, fWidth * SizeOf(TColor32));
dec(src, fWidth); inc(dst, fWidth);
end;
fPixels := a;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.FlipHorizontal;
var
i,j, widthLess1: Integer;
a: TArrayOfColor32;
row: PColor32;
begin
if IsEmpty then Exit;
SetLength(a, fWidth);
widthLess1 := fWidth -1;
row := @fPixels[(height-1) * width]; //top row
for i := 0 to fHeight -1 do
begin
move(row^, a[0], fWidth * SizeOf(TColor32));
for j := 0 to widthLess1 do
begin
row^ := a[widthLess1 - j];
inc(row);
end;
dec(row, fWidth *2);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.PreMultiply;
var
i: Integer;
c: PARGB;
begin
if IsEmpty or fIsPremultiplied then Exit;
fIsPremultiplied := true;
c := PARGB(PixelBase);
for i := 0 to Width * Height -1 do
begin
if (c.A = 0) then c.Color := 0
else if (c.A < 255) then
begin
c.R := MulTable[c.R, c.A];
c.G := MulTable[c.G, c.A];
c.B := MulTable[c.B, c.A];
end;
inc(c);
end;
//nb: no OnChange notify event here
end;
//------------------------------------------------------------------------------
procedure TImage32.SetRGB(rgbColor: TColor32);
var
rgb: TARGB absolute rgbColor;
r,g,b: Byte;
i: Integer;
pc: PARGB;
begin
//this method leaves the alpha channel untouched
if IsEmpty then Exit;
r := rgb.R; g := rgb.G; b := rgb.B;
pc := PARGB(PixelBase);
for i := 0 to Width * Height -1 do
if pc.A = 0 then
begin
pc.Color := 0;
inc(pc);
end else
begin
pc.R := r;
pc.G := g;
pc.B := b;
inc(pc);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.SetRGB(rgbColor: TColor32; rec: TRect);
var
rgb: TARGB absolute rgbColor;
r,g,b: Byte;
i,j, dx: Integer;
pc: PARGB;
begin
Types.IntersectRect(rec, rec, bounds);
if IsEmptyRect(rec) then Exit;
r := rgb.R; g := rgb.G; b := rgb.B;
pc := PARGB(PixelBase);
inc(pc, rec.Left);
dx := Width - RectWidth(rec);
for i := rec.Top to rec.Bottom -1 do
begin
for j := rec.Left to rec.Right -1 do
begin
pc.R := r;
pc.G := g;
pc.B := b;
inc(pc);
end;
inc(pc, dx);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.SetAlpha(alpha: Byte);
var
i: Integer;
c: PARGB;
begin
//this method only changes the alpha channel
if IsEmpty then Exit;
c := PARGB(PixelBase);
for i := 0 to Width * Height -1 do
begin
c.A := alpha;
inc(c);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.ReduceOpacity(opacity: Byte);
var
i: Integer;
c: PARGB;
begin
if opacity = 255 then Exit;
c := PARGB(PixelBase);
for i := 0 to Width * Height -1 do
begin
c.A := MulTable[c.A, opacity];
inc(c);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.ReduceOpacity(opacity: Byte; rec: TRect);
var
i,j, rw: Integer;
c: PARGB;
begin
Types.IntersectRect(rec, rec, bounds);
if IsEmptyRect(rec) then Exit;
rw := RectWidth(rec);
c := @Pixels[rec.Top * Width + rec.Left];
for i := rec.Top to rec.Bottom -1 do
begin
for j := 1 to rw do
begin
c.A := MulTable[c.A, opacity];
inc(c);
end;
inc(c, Width - rw);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.Grayscale;
begin
AdjustSaturation(-100);
end;
//------------------------------------------------------------------------------
procedure TImage32.InvertColors;
var
pc: PARGB;
i: Integer;
begin
pc := PARGB(PixelBase);
for i := 0 to Width * Height -1 do
begin
pc.R := 255 - pc.R;
pc.G := 255 - pc.G;
pc.B := 255 - pc.B;
inc(pc);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.InvertAlphas;
var
pc: PARGB;
i: Integer;
begin
pc := PARGB(PixelBase);
for i := 0 to Width * Height -1 do
begin
pc.A := 255 - pc.A;
inc(pc);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.AdjustHue(percent: Integer);
var
i: Integer;
tmpImage: TArrayofHSL;
lut: array [byte] of byte;
begin
percent := percent mod 100;
if percent < 0 then inc(percent, 100);
percent := Round(percent * 255 / 100);
if (percent = 0) or IsEmpty then Exit;
for i := 0 to 255 do lut[i] := (i + percent) mod 255;
tmpImage := ArrayOfColor32ToArrayHSL(fPixels);
for i := 0 to high(tmpImage) do
tmpImage[i].hue := lut[ tmpImage[i].hue ];
fPixels := ArrayOfHSLToArrayColor32(tmpImage);
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.AdjustLuminance(percent: Integer);
var
i: Integer;
tmpImage: TArrayofHSL;
pc: double;
lut: array [byte] of byte;
begin
if (percent = 0) or IsEmpty then Exit;
percent := percent mod 101;
pc := percent / 100;
if pc > 0 then
for i := 0 to 255 do lut[i] := Round(i + (255 - i) * pc)
else
for i := 0 to 255 do lut[i] := Round(i + (i * pc));
tmpImage := ArrayOfColor32ToArrayHSL(fPixels);
for i := 0 to high(tmpImage) do
tmpImage[i].lum := lut[ tmpImage[i].lum ];
fPixels := ArrayOfHSLToArrayColor32(tmpImage);
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.AdjustSaturation(percent: Integer);
var
i: Integer;
tmpImage: TArrayofHSL;
lut: array [byte] of byte;
pc: double;
begin
if (percent = 0) or IsEmpty then Exit;
percent := percent mod 101;
pc := percent / 100;
if pc > 0 then
for i := 0 to 255 do lut[i] := Round(i + (255 - i) * pc)
else
for i := 0 to 255 do lut[i] := Round(i + (i * pc));
tmpImage := ArrayOfColor32ToArrayHSL(fPixels);
for i := 0 to high(tmpImage) do
tmpImage[i].sat := lut[ tmpImage[i].sat ];
fPixels := ArrayOfHSLToArrayColor32(tmpImage);
Changed;
end;
//------------------------------------------------------------------------------
function TImage32.CropTransparentPixels: TRect;
var
x,y, x1,x2,y1,y2: Integer;
found: Boolean;
begin
y1 := 0; y2 := 0;
found := false;
for y := 0 to Height -1 do
begin
for x := 0 to Width -1 do
if TARGB(fPixels[y * Width + x]).A > 0 then
begin
y1 := y;
found := true;
break;
end;
if found then break;
end;
if not found then
begin
SetSize(0, 0);
Exit;
end;
found := false;
for y := Height -1 downto 0 do
begin
for x := 0 to Width -1 do
if TARGB(fPixels[y * Width + x]).A > 0 then
begin
y2 := y;
found := true;
break;
end;
if found then break;
end;
x1 := Width; x2 := 0;
for y := y1 to y2 do
for x := 0 to Width -1 do
if TARGB(fPixels[y * Width + x]).A > 0 then
begin
if x < x1 then x1 := x;
if x > x2 then x2 := x;
end;
Result := Types.Rect(x1, y1, x2+1, y2+1);
Crop(Result);
end;
//------------------------------------------------------------------------------
procedure TImage32.Rotate(angleRads: double);
var
rec: TRectD;
mat: TMatrixD;
begin
if not ClockwiseRotationIsAnglePositive then
angleRads := -angleRads;
//nb: There's no point rotating about a specific point
//since the rotated image will be recentered.
NormalizeAngle(angleRads);
if IsEmpty or (angleRads = 0) then Exit;
if angleRads = angle180 then
begin
Rotate180; //because we've excluded 0 & 360 deg angles
end
else if angleRads = angle90 then
begin
RotateRight90;
end
else if angleRads = -angle90 then
begin
RotateLeft90;
end else
begin
mat := IdentityMatrix;
MatrixTranslate(mat, Width/2, Height/2);
rec := RectD(Bounds);
rec := GetRotatedRectBounds(rec, angleRads);
MatrixRotate(mat, NullPointD, angleRads);
MatrixTranslate(mat, rec.Width/2, rec.Height/2);
AffineTransformImage(self, mat);
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.RotateRect(const rec: TRect;
angleRads: double; eraseColor: TColor32 = 0);
var
tmp: TImage32;
rec2: TRect;
recWidth, recHeight: integer;
begin
recWidth := rec.Right - rec.Left;
recHeight := rec.Bottom - rec.Top;
//create a tmp image with a copy of the pixels inside rec ...
tmp := TImage32.Create(self, rec);
try
tmp.Rotate(angleRads);
//since rotating also resizes, get a centered
//(clipped) rect of the rotated pixels ...
rec2.Left := (tmp.Width - recWidth) div 2;
rec2.Top := (tmp.Height - recHeight) div 2;
rec2.Right := rec2.Left + recWidth;
rec2.Bottom := rec2.Top + recHeight;
//finally move the rotated rec back to the image ...
FillRect(rec, eraseColor);
CopyBlend(tmp, rec2, rec);
finally
tmp.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.Skew(dx,dy: double);
var
mat: TMatrixD;
begin
if IsEmpty or ((dx = 0) and (dy = 0)) then Exit;
//limit skewing to twice the image's width and/or height
dx := ClampRange(dx, -2.0, 2.0);
dy := ClampRange(dy, -2.0, 2.0);
mat := IdentityMatrix;
MatrixSkew(mat, dx, dy);
AffineTransformImage(self, mat);
end;
//------------------------------------------------------------------------------
procedure TImage32.ScaleAlpha(scale: double);
var
i: Integer;
pb: PARGB;
begin
pb := PARGB(PixelBase);
for i := 0 to Width * Height - 1 do
begin
pb.A := ClampByte(Round(pb.A * scale));
inc(pb);
end;
Changed;
end;
//------------------------------------------------------------------------------
// TImageList32
//------------------------------------------------------------------------------
constructor TImageList32.Create;
begin
{$IFDEF XPLAT_GENERICS}
fList := TList.Create;
{$ELSE}
fList := TList.Create;
{$ENDIF}
fIsImageOwner := true;
end;
//------------------------------------------------------------------------------
destructor TImageList32.Destroy;
begin
Clear;
fList.Free;
inherited;
end;
//------------------------------------------------------------------------------
function TImageList32.Count: integer;
begin
result := fList.Count;
end;
//------------------------------------------------------------------------------
procedure TImageList32.Clear;
var
i: integer;
begin
if IsImageOwner then
for i := 0 to fList.Count -1 do
TImage32(fList[i]).Free;
fList.Clear;
end;
//------------------------------------------------------------------------------
function TImageList32.GetImage(index: integer): TImage32;
begin
result := TImage32(fList[index]);
end;
//------------------------------------------------------------------------------
procedure TImageList32.SetImage(index: integer; img: TIMage32);
begin
if fIsImageOwner then TImage32(fList[index]).Free;
fList[index] := img;
end;
//------------------------------------------------------------------------------
function TImageList32.GetLast: TImage32;
begin
if Count = 0 then Result := nil
else Result := TImage32(fList[Count -1]);
end;
//------------------------------------------------------------------------------
procedure TImageList32.Add(image: TImage32);
begin
fList.Add(image);
end;
//------------------------------------------------------------------------------
function TImageList32.Add(width, height: integer): TImage32;
begin
Result := TImage32.create(width, height);
fList.Add(Result);
end;
//------------------------------------------------------------------------------
procedure TImageList32.Insert(index: integer; image: TImage32);
begin
fList.Insert(index, image);
end;
//------------------------------------------------------------------------------
procedure TImageList32.Move(currentIndex, newIndex: integer);
begin
fList.Move(currentIndex, newIndex);
end;
//------------------------------------------------------------------------------
procedure TImageList32.Delete(index: integer);
begin
if fIsImageOwner then TImage32(fList[index]).Free;
fList.Delete(index);
end;
//------------------------------------------------------------------------------
// TImageFormat methods
//------------------------------------------------------------------------------
function TImageFormat.LoadFromFile(const filename: string;
img32: TImage32): Boolean;
var
fs: TFileStream;
begin
result := FileExists(filename);
if not result then Exit;
fs := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);
try
Result := LoadFromStream(fs, img32);
finally
fs.Free;
end;
end;
//------------------------------------------------------------------------------
function TImageFormat.SaveToFile(const filename: string;
img32: TImage32): Boolean;
var
fs: TFileStream;
begin
result := (pos('.', filename) = 1) or
DirectoryExists(ExtractFilePath(filename));
if not result then Exit;
fs := TFileStream.Create(filename, fmCreate);
try
SaveToStream(fs, img32);
finally
fs.Free;
end;
end;
//------------------------------------------------------------------------------
class function TImageFormat.CanCopyToClipboard: Boolean;
begin
Result := false;
end;
//------------------------------------------------------------------------------
// TInterfacedObj
//------------------------------------------------------------------------------
{$IFDEF FPC}
function TInterfacedObj._AddRef: Integer;
{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result := -1;
end;
//------------------------------------------------------------------------------
function TInterfacedObj._Release: Integer;
{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
begin
Result := -1;
end;
//------------------------------------------------------------------------------
function TInterfacedObj.QueryInterface(
{$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;
out obj) : longint;
begin
if GetInterface(IID, Obj) then Result := 0
else Result := E_NOINTERFACE;
end;
{$ELSE}
function TInterfacedObj._AddRef: Integer; stdcall;
begin
Result := -1;
end;
//------------------------------------------------------------------------------
function TInterfacedObj._Release: Integer; stdcall;
begin
Result := -1;
end;
//------------------------------------------------------------------------------
function TInterfacedObj.QueryInterface(const IID: TGUID;
out Obj): HResult;
begin
if GetInterface(IID, Obj) then Result := 0
else Result := E_NOINTERFACE;
end;
{$ENDIF}
//------------------------------------------------------------------------------
// Initialization and Finalization functions
//------------------------------------------------------------------------------
procedure MakeBlendTables;
var
i,j: Integer;
begin
for j := 0 to 255 do MulTable[0, j] := 0;
for i := 0 to 255 do MulTable[i, 0] := 0;
for j := 0 to 255 do DivTable[0, j] := 0;
for i := 0 to 255 do DivTable[i, 0] := 0;
for i := 1 to 255 do
for j := 1 to 255 do
begin
MulTable[i, j] := Round(i * j * div255);
if i >= j then
DivTable[i, j] := 255 else
DivTable[i, j] := Round(i * $FF / j);
end;
end;
//------------------------------------------------------------------------------
{$IFDEF MSWINDOWS}
procedure GetScreenScale;
var
dc: HDC;
ScreenPixelsY: integer;
begin
dc := GetDC(0);
try
ScreenPixelsY := GetDeviceCaps(dc, LOGPIXELSY);
DpiAwareOne := ScreenPixelsY / 96;
finally
ReleaseDC(0, dc);
end;
dpiAware1 := Round(DpiAwareOne);
end;
{$ENDIF}
//------------------------------------------------------------------------------
{$IFDEF USING_VCL_LCL}
procedure GetScreenScale2;
begin
DpiAwareOne := Screen.PixelsPerInch / 96;
dpiAware1 := Round(DpiAwareOne);
end;
{$ENDIF}
//------------------------------------------------------------------------------
procedure CleanUpImageFormatClassList;
var
i: integer;
begin
for i := ImageFormatClassList.Count -1 downto 0 do
Dispose(PImgFmtRec(ImageFormatClassList[i]));
ImageFormatClassList.Free;
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
procedure CreateResamplerList;
begin
{$IFDEF XPLAT_GENERICS}
ResamplerList := TList.Create;
{$ELSE}
ResamplerList := TList.Create;
{$ENDIF}
end;
//------------------------------------------------------------------------------
function GetResampler(id: integer): TResamplerFunction;
var
i: integer;
begin
result := nil;
if not Assigned(ResamplerList) then Exit;
for i := ResamplerList.Count -1 downto 0 do
if TResamplerObj(ResamplerList[i]).id = id then
begin
Result := TResamplerObj(ResamplerList[i]).func;
Break;
end;
end;
//------------------------------------------------------------------------------
function RegisterResampler(func: TResamplerFunction; const name: string): integer;
var
resampleObj: TResamplerObj;
begin
if not Assigned(ResamplerList) then
CreateResamplerList;
resampleObj := TResamplerObj.Create;
Result := ResamplerList.Add(resampleObj) +1;
resampleObj.id := Result;
resampleObj.name := name;
resampleObj.func := func;
end;
//------------------------------------------------------------------------------
procedure GetResamplerList(stringList: TStringList);
var
i: integer;
resampleObj: TResamplerObj;
begin
stringList.Clear;
stringList.Capacity := ResamplerList.Count;
for i := 0 to ResamplerList.Count -1 do
begin
resampleObj := ResamplerList[i];
stringList.AddObject(resampleObj.name, resampleObj);
end;
end;
//------------------------------------------------------------------------------
procedure CleanUpResamplerClassList;
var
i: integer;
begin
if not Assigned(ResamplerList) then Exit;
for i := ResamplerList.Count -1 downto 0 do
TResamplerObj(ResamplerList[i]).Free;
ResamplerList.Free;
end;
//------------------------------------------------------------------------------
initialization
CreateImageFormatList;
MakeBlendTables;
{$IFDEF MSWINDOWS}
GetScreenScale;
{$ELSE}
{$IFDEF USING_VCL_LCL}
GetScreenScale2;
{$ENDIF}
{$ENDIF}
finalization
CleanUpImageFormatClassList;
CleanUpResamplerClassList;
end.