unit Img32;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.8 *
* Date : 10 January 2025 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2025 *
* Purpose : The core module of the Image32 library *
* License : 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}
{$IFDEF UITYPES} UITypes,{$ENDIF} Math;
type
{$IF not declared(SizeInt)} // FPC has SizeInt
{$IF CompilerVersion < 20.0}
SizeInt = Integer; // Delphi 7-2007 can't use NativeInt with "FOR"
SizeUInt = Cardinal; // Delphi 7-2007 can't use NativeUInt with "FOR"
{$ELSE}
SizeInt = NativeInt;
SizeUInt = NativeUInt;
{$IFEND}
{$IFEND}
TRect = Types.TRect;
TColor32 = type Cardinal;
TPointD = record
X, Y: double;
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;
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);
defaultCompression = -1;
{$IFDEF ZEROBASEDSTR}
{$ZEROBASEDSTRINGS OFF}
{$ENDIF}
RT_BITMAP = PChar(2);
type
{$IFDEF SUPPORTS_POINTERMATH}
// Works for Delphi 2009 and newer. For FPC, POINTERMATH is
// a requirement for negative indices. Otherwise 32bit and 64bit
// code would behave differently since FPC doesn't otherwise
// sign-extend the index variable of type Integer when it's used
// as an array-index into an array with an unsigned index range.
// i32:=-1; i64:=-1 => i32=i64 but @arr[i32] <> @arr[i64]
PByteArray = PByte; // PByte already has PointerMath
{$POINTERMATH ON}
PDoubleArray = ^Double;
PInt64Array = ^Int64;
PColor32Array = ^TColor32;
PARGBArray = ^TARGB;
{$POINTERMATH OFF}
{$ELSE} // Delphi 7-2007
PByteArray = ^TStaticByteArray;
TStaticByteArray = array[0..MaxInt div SizeOf(byte) - 1] of byte;
PDoubleArray = ^TStaticDoubleArray;
TStaticDoubleArray = array[0..MaxInt div SizeOf(double) - 1] of double;
PInt64Array = ^TStaticInt64Array;
TStaticInt64Array = array[0..MaxInt div SizeOf(int64) - 1] of int64;
PColor32Array = ^TStaticColor32Array;
TStaticColor32Array = array[0..MaxInt div SizeOf(TColor32) - 1] of TColor32;
PARGBArray = ^TStaticARGBArray;
TStaticARGBArray = array[0..MaxInt div SizeOf(TARGB) - 1] of TARGB;
{$ENDIF}
TArrayOfByte = array of Byte;
TArrayOfWord = array of WORD;
TArrayOfInteger = array of Integer;
TArrayOfDouble = array of double;
PColor32 = ^TColor32;
TArrayOfColor32 = array of TColor32;
TArrayOfArrayOfColor32 = array of TArrayOfColor32;
TArrayOfString = array of string;
TClipboardPriority = (cpLow, cpMedium, cpHigh);
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
public
class function IsValidImageStream(stream: TStream): Boolean; virtual; abstract;
procedure SaveToStream(stream: TStream; img32: TImage32; quality: integer = 0); virtual; abstract;
function SaveToFile(const filename: string; img32: TImage32; quality: integer = 0): Boolean; virtual;
function LoadFromStream(stream: TStream;
img32: TImage32; imgIndex: integer = 0): Boolean; virtual; abstract;
function LoadFromFile(const filename: string; img32: TImage32): Boolean; virtual;
class function GetImageCount(stream: TStream): integer; 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;
TBlendLineFunction = procedure(bgColor, fgColor: PColor32; width: nativeint);
TCompareFunction = function(master, current: TColor32; data: integer): Boolean;
TCompareFunctionEx = function(master, current: TColor32): Byte;
TTileFillStyle = (tfsRepeat, tfsMirrorHorz, tfsMirrorVert, tfsRotate180);
TResamplerFunction = function(img: TImage32; x, y: double): TColor32;
TGrayscaleMode = (gsmSaturation, gsmLinear, gsmColorimetric);
TImage32 = class(TObject)
private
fWidth: integer;
fHeight: Integer;
fResampler: integer;
fIsPremultiplied: Boolean;
fColorCount: integer;
fPixels: TArrayOfColor32;
fOnChange: TNotifyEvent;
fOnResize: TNotifyEvent;
fUpdateCnt: integer;
fAntiAliased: Boolean;
fNotifyBlockCnt: integer;
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 RotateLeft90;
procedure RotateRight90;
procedure Rotate180;
function GetColorCount: Integer;
function GetHasTransparency: Boolean;
function GetBounds: TRect;
function GetMidPoint: TPointD;
protected
procedure ResetColorCount;
function RectHasTransparency(const rec: TRect): Boolean;
function CopyPixels(const rec: TRect): TArrayOfColor32;
//CopyInternal: Internal routine (has no scaling or bounds checking)
procedure CopyInternal(src: TImage32;
const srcRec, dstRec: TRect; blendFunc: TBlendFunction);
procedure CopyInternalLine(src: TImage32;
const srcRec, dstRec: TRect; blendLineFunc: TBlendLineFunction);
function CopyBlendInternal(src: TImage32; const srcRec: TRect; dstRec: TRect;
blendFunc: TBlendFunction = nil; blendLineFunc: TBlendLineFunction = nil): Boolean; overload;
procedure Changed; virtual;
procedure Resized; virtual;
function SetPixels(const newPixels: TArrayOfColor32): Boolean;
property UpdateCount: integer read fUpdateCnt;
public
constructor Create(width: Integer = 0; height: Integer = 0); overload;
//Create(src:array, width, height): Uses the specified array for the pixels.
// Uses src for the pixels without copying it.
constructor Create(const src: TArrayOfColor32; width: Integer; height: Integer); overload;
constructor Create(src: TImage32); overload;
constructor Create(src: TImage32; const srcRec: TRect); overload;
destructor Destroy; override;
//BeginUpdate/EndUpdate: postpones calls to OnChange event (can be nested)
procedure BeginUpdate;
procedure EndUpdate;
//BlockUpdate/UnBlockUpdate: blocks calls to OnChange event (can be nested)
procedure BlockNotify;
procedure UnblockNotify;
procedure Assign(src: TImage32);
procedure AssignTo(dst: TImage32);
procedure AssignSettings(src: TImage32);
//AssignPixelArray: Replaces the content and takes ownership of src.
// Uses src for the pixels without copying it.
procedure AssignPixelArray(const src: TArrayOfColor32; width: Integer; height: Integer);
//SetSize: Erases any current image, and fills with the specified color.
procedure SetSize(newWidth, newHeight: Integer; color: TColor32 = 0);
//Resize: is very similar to Scale()
procedure Resize(newWidth, newHeight: Integer);
procedure ResizeTo(targetImg: TImage32; newWidth, newHeight: Integer);
//ScaleToFit: The image will be scaled proportionally
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;
procedure ScaleTo(targetImg: TImage32; s: double); overload;
procedure ScaleTo(targetImg: TImage32; 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; const srcRec, dstRec: TRect;
blendFunc: TBlendFunction = nil): Boolean; overload; {$IFDEF INLINE} inline; {$ENDIF}
function CopyBlend(src: TImage32; const srcRec, dstRec: TRect;
blendLineFunc: TBlendLineFunction): Boolean; overload; {$IFDEF INLINE} inline; {$ENDIF}
{$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}
{$IF DEFINED(USING_VCL_LCL)}
procedure CopyFromBitmap(bmp: TBitmap);
procedure CopyToBitmap(bmp: TBitmap);
{$IFEND}
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(const 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(mode: TGrayscaleMode = gsmSaturation;
linearAmountPercentage: double = 1.0);
procedure InvertColors;
procedure InvertAlphas;
procedure AdjustHue(percent: Integer); //ie +/- 100%
procedure AdjustLuminance(percent: Integer); //ie +/- 100%
procedure AdjustSaturation(percent: Integer); //ie +/- 100%
function GetOpaqueBounds: TRect;
//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;
compressionQuality: integer = defaultCompression): Boolean;
function SaveToStream(stream: TStream; const FmtExt: string;
compressionQuality: integer = defaultCompression): Boolean;
function LoadFromFile(const filename: string): Boolean;
function LoadFromStream(stream: TStream; imgIdx: integer = 0): 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;
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;
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;
function BlendToAlpha3(bgColor, fgColor: TColor32; blendOpacity: Byte): TColor32;
procedure BlendToAlphaLine(bgColor, fgColor: PColor32; width: nativeint);
//BlendMask: Whereever the mask is, preserves the background
function BlendMask(bgColor, alphaMask: TColor32): TColor32;
procedure BlendMaskLine(bgColor, alphaMask: PColor32; width: nativeint);
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;
procedure BlendInvertedMaskLine(bgColor, alphaMask: PColor32; width: nativeint);
//BlendBlueChannel: typically useful for white color masks
function BlendBlueChannel(bgColor, blueMask: TColor32): TColor32;
procedure BlendBlueChannelLine(bgColor, blueMask: PColor32; width: nativeint);
//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;
function GetColorMask(img: TImage32; reference: TColor32;
compareFunc: TCompareFunction; tolerance: Integer): TArrayOfColor32;
{$IFDEF MSWINDOWS}
//Color32: Converts a Graphics.TColor value into a TColor32 value.
function Color32(rgbColor: Integer): TColor32; overload; {$IFDEF INLINE} inline; {$ENDIF}
procedure FixPalette(p: PARGB; count: integer);
{$ENDIF}
function Color32(a, r, g, b: Byte): TColor32; overload; {$IFDEF INLINE} inline; {$ENDIF}
//RGBColor: Converts a TColor32 value into a COLORREF value
function RGBColor(color: TColor32): Cardinal; {$IFDEF INLINE} inline; {$ENDIF}
function InvertColor(color: TColor32): TColor32; {$IFDEF INLINE} inline; {$ENDIF}
//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; {$IFDEF INLINE} inline; {$ENDIF}
function PointD(const pt: TPoint): TPointD; overload; {$IFDEF INLINE} inline; {$ENDIF}
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;
{$IFDEF INLINE} inline; {$ENDIF}
function ClampRange(val, min, max: double): double; overload;
{$IFDEF INLINE} inline; {$ENDIF}
function IncPColor32(pc: Pointer; cnt: Integer): PColor32; {$IFDEF INLINE} inline; {$ENDIF}
procedure NormalizeAngle(var angle: double; tolerance: double = Pi/360);
function GrayScale(color: TColor32): TColor32; {$IFDEF INLINE} inline; {$ENDIF}
//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;
div255: Double = 1 / 255;
var
//Resampling function identifiers (initialized in Img32.Resamplers)
rNearestResampler : integer;
rBilinearResampler: integer;
rBicubicResampler : integer;
rWeightedBilinear : 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;
//Sigmoid: weight byte values towards each end
Sigmoid: array[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); overload;
{$IFDEF INLINE} inline; {$ENDIF}
procedure RectWidthHeight(const rec: TRectD; out width, height: double); overload;
{$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;
function __Trunc(Value: Double): Integer; {$IFNDEF CPUX86} {$IFDEF INLINE} inline; {$ENDIF} {$ENDIF}
// NewColor32Array creates a new "array of TColor32". "a" is nil'ed
// before allocating the array. If "count" is zero or negative "a" will
// be nil. If "uninitialized" is True, the memory will not be zero'ed.
procedure NewColor32Array(var a: TArrayOfColor32; count: nativeint;
uninitialized: boolean = False);
procedure NewIntegerArray(var a: TArrayOfInteger; count: nativeint;
uninitialized: boolean = False);
procedure NewByteArray(var a: TArrayOfByte; count: nativeint;
uninitialized: boolean = False);
procedure NewPointDArray(var a: TPathD; count: nativeint;
uninitialized: boolean = False);
// SetLengthUninit changes the dyn. array's length but does not initialize
// the new elements with zeros. It can be used as a replacement for
// SetLength where the zero-initialitation is not required.
procedure SetLengthUninit(var a: TArrayOfColor32; count: nativeint); overload;
procedure SetLengthUninit(var a: TArrayOfInteger; count: nativeint); overload;
procedure SetLengthUninit(var a: TArrayOfByte; count: nativeint); overload;
procedure SetLengthUninit(var a: TPathD; count: nativeint); overload;
implementation
uses
Img32.Vector, Img32.Resamplers, Img32.Transform
{$IF DEFINED(USING_VCL_LCL)}
, Img32.Fmt.BMP
{$ENDIF}
;
resourcestring
rsImageTooLarge = 'Image32 error: the image is too large.';
rsInvalidImageArrayData = 'Image32 error: the specified pixels array and the size does not match.';
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
{$IFDEF CPUX86}
const
// Use faster Trunc for x86 code in this unit.
Trunc: function(Value: Double): Integer = __Trunc;
{$ENDIF CPUX86}
type
TImgFmtRec = record
Fmt: string;
SortOrder: TClipboardPriority;
Obj: TImageFormatClass;
end;
PImgFmtRec = ^TImgFmtRec;
TResamplerObj = class
id: integer;
name: string;
func: TResamplerFunction;
end;
PDynArrayRec = ^TDynArrayRec;
{$IFDEF FPC}
tdynarrayindex = sizeint;
TDynArrayRec = packed record
refcount: ptrint;
high: tdynarrayindex;
Data: record end;
end;
{$ELSE}
TDynArrayRec = packed record
{$IFDEF CPU64BITS}
_Padding: Integer;
{$ENDIF}
RefCnt: Integer;
Length: NativeInt;
Data: record end;
end;
{$ENDIF}
var
{$IFDEF XPLAT_GENERICS}
ImageFormatClassList: TList; //list of supported file extensions
ResamplerList: TList; //list of resampler functions
{$ELSE}
ImageFormatClassList: TList;
ResamplerList: TList;
{$ENDIF}
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
function NewSimpleDynArray(count: nativeint; elemSize: integer; uninitialized: boolean = False): Pointer;
var
p: PDynArrayRec;
begin
Result := nil;
if (count > 0) and (elemSize > 0) then
begin
if uninitialized then
GetMem(Pointer(p), SizeOf(TDynArrayRec) + count * elemSize)
else
p := AllocMem(SizeOf(TDynArrayRec) + count * elemSize);
{$IFDEF FPC}
p.refcount := 1;
p.high := count -1;
{$ELSE}
p.RefCnt := 1;
p.Length := count;
{$ENDIF}
Result := @p.Data;
end;
end;
//------------------------------------------------------------------------------
function InternSetSimpleDynArrayLengthUninit(a: Pointer; count: nativeint; elemSize: integer): Pointer;
var
p: PDynArrayRec;
oldCount: nativeint;
begin
if a = nil then
Result := NewSimpleDynArray(count, elemSize)
else if (count > 0) and (elemSize > 0) then
begin
p := PDynArrayRec(PByte(a) - SizeOf(TDynArrayRec));
{$IFDEF FPC}
oldCount := p.high + 1;
if p.refcount = 1 then
{$ELSE}
oldCount := p.Length;
if p.RefCnt = 1 then
{$ENDIF}
begin
// There is only one reference to this array and that is "a",
// so we can use ReallocMem to change the array's length.
if oldCount = count then
begin
Result := a;
Exit;
end;
ReallocMem(Pointer(p), SizeOf(TDynArrayRec) + count * elemSize);
end
else
begin
// SetLength makes a copy of the dyn array to get RefCnt=1
GetMem(Pointer(p), SizeOf(TDynArrayRec) + count * elemSize);
if oldCount < 0 then oldCount := 0; // data corruption detected
if oldCount > count then oldCount := count;
Move(a^, p.Data, oldCount * elemSize);
TArrayOfByte(a) := nil; // use a non-managed dyn.array type
end;
{$IFDEF FPC}
p.refcount := 1;
p.high := count -1;
{$ELSE}
p.RefCnt := 1;
p.Length := count;
{$ENDIF}
Result := @p.Data;
end
else
begin
TArrayOfByte(a) := nil; // use a non-managed dyn.array type
Result := nil;
end;
end;
//------------------------------------------------------------------------------
function CanReuseDynArray(a: Pointer; count: nativeint): Boolean;
// returns True if RefCnt=1 and Length=count
begin
//Assert(a <> nil);
a := PByte(a) - SizeOf(TDynArrayRec);
Result :=
{$IFDEF FPC}
(PDynArrayRec(a).refcount = 1) and
(PDynArrayRec(a).high = count - 1);
{$ELSE}
(PDynArrayRec(a).RefCnt = 1) and
(PDynArrayRec(a).Length = count);
{$ENDIF}
end;
//------------------------------------------------------------------------------
procedure NewColor32Array(var a: TArrayOfColor32; count: nativeint; uninitialized: boolean);
begin
{$IF COMPILERVERSION < 16}
SetLength(a, count);
{$ELSE}
if a <> nil then
begin
if uninitialized and CanReuseDynArray(a, count) then Exit;
a := nil;
end;
Pointer(a) := NewSimpleDynArray(count, SizeOf(TColor32), uninitialized);
{$IFEND}
end;
//------------------------------------------------------------------------------
procedure NewIntegerArray(var a: TArrayOfInteger; count: nativeint; uninitialized: boolean);
begin
{$IF COMPILERVERSION < 16}
SetLength(a, count);
{$ELSE}
if a <> nil then
begin
if uninitialized and CanReuseDynArray(a, count) then
Exit;
a := nil;
end;
Pointer(a) := NewSimpleDynArray(count, SizeOf(Integer), uninitialized);
{$IFEND}
end;
//------------------------------------------------------------------------------
procedure NewByteArray(var a: TArrayOfByte; count: nativeint; uninitialized: boolean);
begin
{$IF COMPILERVERSION < 16}
SetLength(a, count);
{$ELSE}
if a <> nil then
begin
if uninitialized and CanReuseDynArray(a, count) then
Exit;
a := nil;
end;
Pointer(a) := NewSimpleDynArray(count, SizeOf(Byte), uninitialized);
{$IFEND}
end;
//------------------------------------------------------------------------------
procedure NewPointDArray(var a: TPathD; count: nativeint; uninitialized: boolean);
begin
{$IF COMPILERVERSION < 16}
SetLength(a, count);
{$ELSE}
if a <> nil then
begin
if uninitialized and CanReuseDynArray(a, count) then
Exit;
a := nil;
end;
Pointer(a) := NewSimpleDynArray(count, SizeOf(TPointD), uninitialized);
{$IFEND}
end;
//------------------------------------------------------------------------------
procedure SetLengthUninit(var a: TArrayOfColor32; count: nativeint);
begin
SetLength(a, count);
// Pointer(a) := InternSetSimpleDynArrayLengthUninit(Pointer(a), count, SizeOf(TColor32));
end;
//------------------------------------------------------------------------------
procedure SetLengthUninit(var a: TArrayOfInteger; count: nativeint);
begin
{$IF COMPILERVERSION < 16}
SetLength(a, count);
{$ELSE}
Pointer(a) := InternSetSimpleDynArrayLengthUninit(Pointer(a), count, SizeOf(Integer));
{$IFEND}
end;
//------------------------------------------------------------------------------
procedure SetLengthUninit(var a: TArrayOfByte; count: nativeint);
begin
{$IF COMPILERVERSION < 16}
SetLength(a, count);
{$ELSE}
Pointer(a) := InternSetSimpleDynArrayLengthUninit(Pointer(a), count, SizeOf(Byte));
{$IFEND}
end;
//------------------------------------------------------------------------------
procedure SetLengthUninit(var a: TPathD; count: nativeint);
begin
{$IF COMPILERVERSION < 16}
SetLength(a, count);
{$ELSE}
Pointer(a) := InternSetSimpleDynArrayLengthUninit(Pointer(a), count, SizeOf(TPointD));
{$IFEND}
end;
//------------------------------------------------------------------------------
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;
//------------------------------------------------------------------------------
{$IFDEF CPUX86}
{ Trunc with FPU code is very slow because the x87 ControlWord has to be changed
and then there is Delphi's Default8087CW variable that is not thread-safe. }
//__Trunc: An efficient Trunc() algorithm (ie rounds toward zero)
function __Trunc(Value: Double): Integer;
var
exp: integer;
i64: UInt64 absolute Value;
valueBytes: array[0..7] of Byte absolute Value;
begin
// https://en.wikipedia.org/wiki/Double-precision_floating-point_format
// 52 bit fractional value, 11bit ($7FF) exponent, and 1bit sign
Result := 0;
if i64 = 0 then Exit;
exp := Integer(Cardinal(i64 shr 52) and $7FF) - 1023;
// nb: when exp == 1024 then Value == INF or NAN.
if exp < 0 then
Exit
//else if exp > 52 then // ie only for 64bit int results
// Result := ((i64 and $1FFFFFFFFFFFFF) shl (exp - 52)) or (1 shl exp)
//else if exp > 31 then // alternatively, range check for 32bit ints ????
// raise Exception.Create(rsIntegerOverflow)
else
Result := Integer((i64 and $1FFFFFFFFFFFFF) shr (52 - exp)) or (1 shl exp);
// Check for the sign bit without loading Value into the FPU.
if valueBytes[7] and $80 <> 0 then Result := -Result;
end;
//------------------------------------------------------------------------------
{$ELSE}
function __Trunc(Value: Double): Integer;
begin
// Uses fast SSE2 instruction
Result := System.Trunc(Value);
end;
//------------------------------------------------------------------------------
{$ENDIF CPUX86}
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
fgA: byte;
fw,bw: PByteArray;
begin
fgA := fgColor shr 24;
if fgA = 0 then Result := bgColor
else if fgA = 255 then Result := fgColor
else
begin
//assuming bg.A = 255, use just fg.A for color weighting
fw := PByteArray(@MulTable[fgA]); //ie weight of foreground
bw := PByteArray(@MulTable[not fgA]); //ie weight of background
Result := $FF000000
or (TColor32(Byte(fw[Byte(fgColor shr 16)] + bw[Byte(bgColor shr 16)])) shl 16)
or (TColor32(Byte(fw[Byte(fgColor shr 8 )] + bw[Byte(bgColor shr 8)])) shl 8)
or (TColor32(Byte(fw[Byte(fgColor )] + bw[Byte(bgColor )])) );
end;
end;
//------------------------------------------------------------------------------
function BlendToAlpha(bgColor, fgColor: TColor32): TColor32;
var
fgWeight: byte;
R, InvR: PByteArray;
bgA, fgA: byte;
begin
//(see https://en.wikipedia.org/wiki/Alpha_compositing)
fgA := fgColor shr 24;
bgA := bgColor shr 24;
if fgA = 0 then Result := bgColor
else if (bgA = 0) or (fgA = 255) then Result := fgColor
else
begin
//combine alphas ...
bgA := not MulTable[not fgA, not bgA];
fgWeight := DivTable[fgA, bgA]; // fgWeight = amount foreground color
// contibutes to the result color
R := PByteArray(@MulTable[fgWeight]); // ie weight of foreground
InvR := PByteArray(@MulTable[not fgWeight]); // ie weight of background
Result := bgA shl 24
or (TColor32(R[Byte(fgColor shr 16)] + InvR[Byte(bgColor shr 16)]) shl 16)
or (TColor32(R[Byte(fgColor shr 8 )] + InvR[Byte(bgColor shr 8)]) shl 8)
or (TColor32(R[Byte(fgColor) ] + InvR[Byte(bgColor) ]) );
end;
end;
//------------------------------------------------------------------------------
function BlendToAlpha3(bgColor, fgColor: TColor32; blendOpacity: Byte): TColor32;
var
fgWeight: byte;
R, InvR: PByteArray;
bgA, fgA: byte;
begin
fgA := MulTable[blendOpacity, fgColor shr 24];
bgA := bgColor shr 24;
if fgA = 0 then
Result := bgColor // must do first
else if (bgA = 0) or (fgA = 255) then
Result := (fgA shl 24) or (fgColor and $FFFFFF)
else
begin
//combine alphas ...
bgA := not MulTable[not fgA, not bgA];
fgWeight := DivTable[fgA, bgA]; // fgWeight = amount foreground color
// contibutes to the result color
R := PByteArray(@MulTable[fgWeight]); // ie weight of foreground
InvR := PByteArray(@MulTable[not fgWeight]); // ie weight of background
Result := bgA shl 24
or (TColor32(R[Byte(fgColor shr 16)] + InvR[Byte(bgColor shr 16)]) shl 16)
or (TColor32(R[Byte(fgColor shr 8 )] + InvR[Byte(bgColor shr 8)]) shl 8)
or (TColor32(R[Byte(fgColor) ] + InvR[Byte(bgColor) ]) );
end;
end;
//------------------------------------------------------------------------------
{$RANGECHECKS OFF} // negative array index is used
{$IFNDEF CPUX64}
function BlendToAlphaLineX86(bgColorArr, fgColorArr: PColor32Array;
idx: nativeint): nativeint;
// Helper function for x86 code, reduces the CPU register pressure in
// BlendToAlphaLine().
var
fgWeight: byte;
R, InvR: PByteArray;
fgA, bgA, newBgA: byte;
fgCol, bgCol: TColor32;
begin
fgCol := fgColorArr[idx];
bgCol := bgColorArr[idx];
Result := idx; // idx - negative offset into color arrays
while True do
begin
fgA := fgCol shr 24;
bgA := bgCol shr 24;
//combine alphas ...
newBgA := not MulTable[not fgA, not bgA];
fgWeight := DivTable[fgA, newBgA]; //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
while True do
begin
bgColorArr[Result] := TColor32(newBgA) shl 24
or (TColor32(R[Byte(fgCol shr 16)] + InvR[Byte(bgCol shr 16)]) shl 16)
or (TColor32(R[Byte(fgCol shr 8 )] + InvR[Byte(bgCol shr 8)]) shl 8)
or (TColor32(R[Byte(fgCol) ] + InvR[Byte(bgCol) ]) );
inc(Result);
if Result = 0 then exit;
fgCol := fgColorArr[Result];
bgCol := bgColorArr[Result];
// if both alpha channels are the same in the new pixels, we
// can use the already calculated R/InvR tables.
if (fgCol shr 24 <> fgA) or (bgCol shr 24 <> bgA) then break;
end;
// return if we have alpha channel values for which we have special code
if (fgCol and $FF000000 = 0) or (fgCol and $FF000000 = $FF000000) or (bgCol and $FF000000 = 0) then exit;
end;
end;
//------------------------------------------------------------------------------
{$ENDIF ~CPUX64}
procedure BlendToAlphaLine(bgColor, fgColor: PColor32; width: nativeint);
label
LabelBgAlphaIsZero;
var
bgColorArr, fgColorArr: PColor32Array;
bgCol, fgCol: TColor32;
{$IFDEF CPUX64}
fgWeight, fgA, bgA: byte;
R, InvR: PByteArray;
{$ENDIF CPUX64}
begin
//(see https://en.wikipedia.org/wiki/Alpha_compositing)
// Use the negative offset trick to only increment the array "width"
// until it reaches zero. And by offsetting the arrays by "width",
// the negative "width" values also becomes the index into these arrays.
inc(bgColor, width);
inc(fgColor, width);
width := -width;
bgColorArr := PColor32Array(bgColor);
fgColorArr := PColor32Array(fgColor);
while width < 0 do
begin
bgCol := bgColorArr[width];
fgCol := fgColorArr[width];
// bgColor.A is zero => change bgColor to fgColor
while bgCol shr 24 = 0 do
begin
LabelBgAlphaIsZero:
bgColorArr[width] := fgCol;
inc(width);
if width = 0 then exit;
fgCol := fgColorArr[width];
bgCol := bgColorArr[width];
end;
// fgColor.A is zero => don't change bgColor
while fgCol shr 24 = 0 do
begin
// bgColorArr[w] := bgColorArr[w];
inc(width);
if width = 0 then exit;
fgCol := fgColorArr[width];
bgCol := bgColorArr[width];
if bgCol shr 24 = 0 then goto LabelBgAlphaIsZero;
end;
// fgColor.A is 255 => change bgColor to fgColor
while fgCol shr 24 = 255 do
begin
bgColorArr[width] := fgCol;
inc(width);
if width = 0 then exit;
fgCol := fgColorArr[width];
bgCol := bgColorArr[width];
if bgCol shr 24 = 0 then goto LabelBgAlphaIsZero;
end;
{$IFDEF CPUX64}
// x64 has more CPU registers than x86 and calling BlendToAlphaLineX86
// is slower, so we inline it.
//combine alphas ...
fgA := fgCol shr 24;
bgA := bgCol shr 24;
bgA := not MulTable[not fgA, not bgA];
fgWeight := DivTable[fgA, bgA]; //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
bgColorArr[width] := TColor32(bgA) shl 24
or (TColor32(R[Byte(fgCol shr 16)] + InvR[Byte(bgCol shr 16)]) shl 16)
or (TColor32(R[Byte(fgCol shr 8 )] + InvR[Byte(bgCol shr 8)]) shl 8)
or (TColor32(R[Byte(fgCol) ] + InvR[Byte(bgCol) ]) );
inc(width);
{$ELSE}
// x86 has not enough CPU registers and the loops above will suffer if we
// inline the code. So we let the compiler use a "new set" of CPU registers
// by calling a function.
width := BlendToAlphaLineX86(bgColorArr, fgColorArr, width);
{$ENDIF CPUX64}
end;
end;
//------------------------------------------------------------------------------
{
// reference implementation
procedure BlendToAlphaLine(bgColor, fgColor: PColor32; width: nativeint);
var
fgWeight: byte;
R, InvR: PByteArray;
bgA, fgA: Byte;
bgColorArr, fgColorArr: PColor32Array;
bgCol, fgCol: TColor32;
begin
//(see https://en.wikipedia.org/wiki/Alpha_compositing)
// Use the negative offset trick to only increment the array "width"
// until it reaches zero. And by offsetting the arrays by "width",
// the negative "width" values also becomes the index into these arrays.
inc(bgColor, width);
inc(fgColor, width);
width := -width;
bgColorArr := PColor32Array(bgColor);
fgColorArr := PColor32Array(fgColor);
while width < 0 do
begin
bgCol := bgColorArr[width];
fgCol := fgColorArr[width];
bgA := bgCol shr 24;
if bgA = 0 then bgColorArr[width] := fgCol
else
begin
fgA := fgCol shr 24;
if fgA > 0 then
begin
if fgA = 255 then bgColorArr[width] := fgCol
else if fgA > 0 then
begin
//combine alphas ...
bgA := not MulTable[not fgA, not bgA];
fgWeight := DivTable[fgA, bgA]; //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
bgColorArr[width] := TColor32(bgA) shl 24
or (TColor32(R[Byte(fgCol shr 16)] + InvR[Byte(bgCol shr 16)]) shl 16)
or (TColor32(R[Byte(fgCol shr 8 )] + InvR[Byte(bgCol shr 8)]) shl 8)
or (TColor32(R[Byte(fgCol) ] + InvR[Byte(bgCol) ]) );
end;
end;
end;
inc(width);
end;
end;}
{$IFDEF RANGECHECKS_ENABLED}
{$RANGECHECKS ON}
{$ENDIF}
//------------------------------------------------------------------------------
function BlendMask(bgColor, alphaMask: TColor32): TColor32;
var
a: byte;
begin
a := MulTable[bgColor shr 24, alphaMask shr 24];
if a <> 0 then Result := (TColor32(a) shl 24) or (bgColor and $00FFFFFF)
else Result := 0;
end;
//------------------------------------------------------------------------------
{$RANGECHECKS OFF} // negative array index is used
procedure BlendMaskLine(bgColor, alphaMask: PColor32; width: nativeint);
label
SkipNone32;
var
a: byte;
begin
// Use the negative offset trick to only increment the array "width"
// until it reaches zero. And by offsetting the arrays by "width",
// the negative "width" values also becomes the index into these arrays.
inc(bgColor, width);
inc(alphaMask, width);
width := -width;
// Handle special cases Alpha=0 or 255 as those are the most
// common values.
while width < 0 do
begin
// MulTable[0, fgA] -> 0, if bgColor is already 0 => skip
while PARGBArray(bgColor)[width].Color = 0 do
begin
SkipNone32:
inc(width);
if width = 0 then exit;
end;
a := PARGBArray(bgColor)[width].A;
// MulTable[0, fgA] -> 0 => replace color with 0
while a = 0 do
begin
PColor32Array(bgColor)[width] := 0;
inc(width);
if width = 0 then exit;
if PARGBArray(bgColor)[width].Color = 0 then
goto SkipNone32;
a := PARGBArray(bgColor)[width].A;
end;
// MulTable[255, fgA] -> fgA => replace alpha with fgA
while a = 255 do
begin
PARGBArray(bgColor)[width].A := PARGBArray(alphaMask)[width].A;
inc(width);
if width = 0 then exit;
a := PARGBArray(bgColor)[width].A;
end;
a := PARGBArray(alphaMask)[width].A;
// MulTable[bgA, 0] -> 0 => replace color with 0
while a = 0 do
begin
PColor32Array(bgColor)[width] := 0;
inc(width);
if width = 0 then exit;
a := PARGBArray(alphaMask)[width].A;
end;
// MulTable[bgA, 255] -> bgA => nothing to do
while a = 255 do
begin
inc(width);
if width = 0 then exit;
a := PARGBArray(alphaMask)[width].A;
end;
a := MulTable[PARGBArray(bgColor)[width].A, a];
if a <> 0 then PARGBArray(bgColor)[width].A := a
else PColor32Array(bgColor)[width] := 0;
inc(width);
end;
end;
//------------------------------------------------------------------------------
{
// reference implementation
procedure BlendMaskLine(bgColor, alphaMask: PColor32; width: nativeint);
var
a: byte;
begin
// Use the negative offset trick to only increment the array "width"
// until it reaches zero. And by offsetting the arrays by "width",
// the negative "width" values also becomes the index into these arrays.
inc(bgColor, width);
inc(alphaMask, width);
width := -width;
while width < 0 do
begin
a := MulTable[PARGBArray(bgColor)[width].A,
PARGBArray(alphaMask)[width].A];
if a = 0 then PColor32Array(bgColor)[width] := 0
else PARGBArray(bgColor)[width].A := a;
inc(width);
end;
end;}
{$IFDEF RANGECHECKS_ENABLED}
{$RANGECHECKS ON}
{$ENDIF}
//------------------------------------------------------------------------------
function BlendAltMask(bgColor, alphaMask: TColor32): TColor32;
var
a: byte;
begin
a := MulTable[bgColor shr 24, (alphaMask shr 24) xor 255];
if a <> 0 then Result := (TColor32(a) shl 24) or (bgColor and $00FFFFFF)
else Result := 0;
end;
//------------------------------------------------------------------------------
function BlendDifference(color1, color2: TColor32): TColor32;
var
fgA, bgA: byte;
begin
fgA := color2 shr 24;
bgA := color1 shr 24;
if fgA = 0 then Result := color1
else if bgA = 0 then Result := color2
else
begin
Result := TColor32(MulTable[(fgA xor 255), (bgA xor 255)] xor 255) shl 24
or (TColor32(Abs(Byte(color2 shr 16) - Byte(color1 shr 16))) shl 16)
or (TColor32(Abs(Byte(color2 shr 8) - Byte(color1 shr 8))) shl 8)
or (TColor32(Abs(Byte(color2 ) - Byte(color1 ))) );
end;
end;
//------------------------------------------------------------------------------
function BlendSubtract(bgColor, fgColor: TColor32): TColor32;
var
fgA, bgA: byte;
begin
fgA := fgColor shr 24;
bgA := bgColor shr 24;
if fgA = 0 then Result := bgColor
else if bgA = 0 then Result := fgColor
else
begin
Result := TColor32(MulTable[(fgA xor 255), (bgA xor 255)] xor 255) shl 24
or (TColor32(ClampByte(Byte(fgColor shr 16) - Byte(bgColor shr 16))) shl 16)
or (TColor32(ClampByte(Byte(fgColor shr 8 ) - Byte(bgColor shr 8))) shl 8)
or (TColor32(ClampByte(Byte(fgColor ) - Byte(bgColor ))) );
end;
end;
//------------------------------------------------------------------------------
function BlendLighten(bgColor, fgColor: TColor32): TColor32;
var
fgA, bgA: byte;
begin
fgA := fgColor shr 24;
bgA := bgColor shr 24;
if fgA = 0 then Result := bgColor
else if bgA = 0 then Result := fgColor
else
begin
Result := TColor32(MulTable[(fgA xor 255), (bgA xor 255)] xor 255) shl 24
or (TColor32(Max(Byte(fgColor shr 16), Byte(bgColor shr 16))) shl 16)
or (TColor32(Max(Byte(fgColor shr 8 ), Byte(bgColor shr 8))) shl 8)
or (TColor32(Max(Byte(fgColor ), Byte(bgColor ))) );
end;
end;
//------------------------------------------------------------------------------
function BlendDarken(bgColor, fgColor: TColor32): TColor32;
var
fgA, bgA: byte;
begin
fgA := fgColor shr 24;
bgA := bgColor shr 24;
if fgA = 0 then Result := bgColor
else if bgA = 0 then Result := fgColor
else
begin
Result := TColor32(MulTable[(fgA xor 255), (bgA xor 255)] xor 255) shl 24
or (TColor32(Min(Byte(fgColor shr 16), Byte(bgColor shr 16))) shl 16)
or (TColor32(Min(Byte(fgColor shr 8 ), Byte(bgColor shr 8))) shl 8)
or (TColor32(Min(Byte(fgColor ), Byte(bgColor ))) );
end;
end;
//------------------------------------------------------------------------------
function BlendBlueChannel(bgColor, blueMask: TColor32): TColor32;
begin
Result := (bgColor and $00FFFFFF) or
(TColor32(MulTable[bgColor shr 24, Byte(blueMask)]) shl 24);
end;
//------------------------------------------------------------------------------
function BlendInvertedMask(bgColor, alphaMask: TColor32): TColor32;
var
a: byte;
begin
a := MulTable[bgColor shr 24, (alphaMask shr 24) xor 255];
if a < 2 then Result := 0
else Result := (bgColor and $00FFFFFF) or (TColor32(a) shl 24);
end;
//------------------------------------------------------------------------------
{$RANGECHECKS OFF} // negative array index is used
procedure BlendBlueChannelLine(bgColor, blueMask: PColor32; width: nativeint);
begin
inc(bgColor, width);
inc(blueMask, width);
width := -width;
while width < 0 do
begin
PARGBArray(bgColor)[width].A :=
MulTable[PARGBArray(bgColor)[width].A,
PARGBArray(blueMask)[width].B];
inc(width);
end;
end;
//------------------------------------------------------------------------------
procedure BlendInvertedMaskLine(bgColor, alphaMask: PColor32; width: nativeint);
var
a: byte;
begin
// Use the negative offset trick to only increment the array "width"
// until it reaches zero. And by offsetting the arrays by "width",
// the negative "width" values also becomes the index into these arrays.
inc(bgColor, width);
inc(alphaMask, width);
width := -width;
while width < 0 do
begin
a := MulTable[PARGBArray(bgColor)[width].A,
PARGBArray(alphaMask)[width].A xor 255];
if a < 2 then PColor32Array(bgColor)[width] := 0
else PARGBArray(bgColor)[width].A := a;
inc(width);
end;
end;
{$IFDEF RANGECHECKS_ENABLED}
{$RANGECHECKS ON}
{$ENDIF}
//------------------------------------------------------------------------------
// 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;
//------------------------------------------------------------------------------
procedure RectWidthHeight(const rec: TRectD; out width, height: double);
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;
begin
Result := color xor $00FFFFFF;
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;
//------------------------------------------------------------------------------
procedure FixPalette(p: PARGB; count: integer);
var
i: integer;
begin
for i := 1 to count do
begin
p.Color := SwapRedBlue(p.Color);
p.A := 255;
inc(p);
end;
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 * Abs(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;
NewByteArray(Result, img.Width * img.Height, True);
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 GetColorMask(img: TImage32; reference: TColor32;
compareFunc: TCompareFunction; tolerance: Integer): TArrayOfColor32;
var
i: integer;
pDstPxl: PColor32;
pSrcPxl: PColor32;
begin
result := nil;
if not assigned(img) or img.IsEmpty then Exit;
if not Assigned(compareFunc) then compareFunc := CompareRGB;
NewColor32Array(Result, img.Width * img.Height, True);
pDstPxl := @Result[0];
pSrcPxl := img.PixelBase;
for i := 0 to img.Width * img.Height -1 do
begin
if compareFunc(reference, pSrcPxl^, tolerance) then
pDstPxl^ := clWhite32 else
pDstPxl^ := clBlack32;
inc(pSrcPxl); inc(pDstPxl);
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;
NewByteArray(Result, img.Width * img.Height, True);
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) shr 8;
a := 252 - (hsl.hue mod 85) * 6;
x := (c * (255 - abs(a))) shr 8;
m := hsl.lum - c shr 1{div 2}; // Delphi's 64bit compiler can't optimize this
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);
NewColor32Array(result, len, True);
for i := 0 to len -1 do
result[i] := HslToRgb(hslArr[i]);
end;
//------------------------------------------------------------------------------
function NameToId(Name: PChar): Longint;
begin
if Name < Pointer(30) then
begin
Result := Longint(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);
NewColor32Array(fPixels, fwidth * fheight);
end;
//------------------------------------------------------------------------------
constructor TImage32.Create(const src: TArrayOfColor32; width: Integer; height: Integer);
begin
fAntiAliased := true;
fResampler := DefaultResampler;
width := Max(0, width);
height := Max(0, height);
if Length(src) <> width * height then
raise Exception.Create(rsInvalidImageArrayData);
fWidth := width;
fHeight := height;
fPixels := src;
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);
if (fWidth = 0) or (fheight = 0) then Exit;
fPixels := src.CopyPixels(rec);
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.AssignSettings(Self);
try
dst.fPixels := System.Copy(fPixels, 0, Length(fPixels));
dst.fWidth := fWidth;
dst.fHeight := fHeight;
dst.Resized;
except
dst.SetSize(0,0);
end;
finally
dst.EndUpdate;
end;
dst.fColorCount := fColorCount; // dst.EndUpdate called ResetColorCount
end;
//------------------------------------------------------------------------------
procedure TImage32.AssignSettings(src: TImage32);
begin
if assigned(src) and (src <> Self) then
begin
BeginUpdate;
try
fResampler := src.fResampler;
fIsPremultiplied := src.fIsPremultiplied;
fAntiAliased := src.fAntiAliased;
ResetColorCount;
finally
EndUpdate;
end;
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.AssignPixelArray(const src: TArrayOfColor32; width: Integer; height: Integer);
var
wasResized: Boolean;
begin
width := Max(0, width);
height := Max(0, height);
if Length(src) <> width * height then
raise Exception.Create(rsInvalidImageArrayData);
wasResized := (fWidth <> width) or (fHeight <> height);
BeginUpdate;
try
fWidth := width;
fHeight := height;
fPixels := src;
finally
EndUpdate;
end;
if wasResized then
Resized;
end;
//------------------------------------------------------------------------------
procedure TImage32.Changed;
begin
if fUpdateCnt <> 0 then Exit;
ResetColorCount;
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;
//------------------------------------------------------------------------------
function TImage32.SetPixels(const newPixels: TArrayOfColor32): Boolean;
var
len: integer;
begin
len := Length(newPixels);
Result := (len > 0)and (len = Width * height);
if Result then fPixels := System.Copy(newPixels, 0, len);
end;
//------------------------------------------------------------------------------
procedure TImage32.BeginUpdate;
begin
if fNotifyBlockCnt > 0 then Exit;
inc(fUpdateCnt);
end;
//------------------------------------------------------------------------------
procedure TImage32.EndUpdate;
begin
if fNotifyBlockCnt > 0 then Exit;
dec(fUpdateCnt);
if fUpdateCnt = 0 then Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.BlockNotify;
begin
inc(fNotifyBlockCnt);
inc(fUpdateCnt);
end;
//------------------------------------------------------------------------------
procedure TImage32.UnblockNotify;
begin
dec(fNotifyBlockCnt);
dec(fUpdateCnt);
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(const rec: TRect; color: TColor32);
var
i,j, rw, w: Integer;
c: PColor32;
r: TRect;
begin
Types.IntersectRect(r, rec, bounds);
if IsEmptyRect(r) then Exit;
rw := RectWidth(r);
w := Width;
c := @Pixels[r.Top * w + r.Left];
if (color = 0) and (w = rw) then
FillChar(c^, (r.Bottom - r.Top) * rw * SizeOf(TColor32), 0)
else if rw = 1 then
begin
for i := r.Top to r.Bottom -1 do
begin
c^ := color;
inc(c, w);
end;
end
else if (color = 0) and (rw > 15) then
begin
for i := r.Top to r.Bottom -1 do
begin
FillChar(c^, rw * SizeOf(TColor32), 0);
inc(c, w);
end;
end
else
begin
for i := r.Top to r.Bottom -1 do
begin
for j := 1 to rw do
begin
c^ := color;
inc(c);
end;
inc(c, w - rw);
end;
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.ResetColorCount;
begin
fColorCount := 0;
end;
//------------------------------------------------------------------------------
{$RANGECHECKS OFF} // negative array index is used
function TImage32.RectHasTransparency(const rec: TRect): Boolean;
var
i, j, rw: Integer;
lineByteOffset: nativeint;
c: PARGB;
r: TRect;
begin
Result := True;
Types.IntersectRect(r, rec, bounds);
if IsEmptyRect(r) then Exit;
rw := RectWidth(r);
c := @Pixels[r.Top * Width + r.Left];
if rw = Width then // we can use one loop
begin
i := (r.Bottom - r.Top) * rw;
inc(c, i);
i := -i;
while i < 0 do
begin
if PARGBArray(c)[i].A < 254 then Exit;
inc(i);
end;
end
else
begin
lineByteOffset := (Width - rw) * SizeOf(TColor32);
for i := r.Top to r.Bottom -1 do
begin
for j := 1 to rw do
begin
if c.A < 254 then Exit;
inc(c);
end;
inc(PByte(c), lineByteOffset);
end;
end;
Result := False;
end;
{$IFDEF RANGECHECKS_ENABLED}
{$RANGECHECKS ON}
{$ENDIF}
//------------------------------------------------------------------------------
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(const rec: TRect): TArrayOfColor32;
var
i, clipW, w,h: Integer;
pSrc, pDst, pDst2: PColor32;
recClipped: TRect;
begin
RectWidthHeight(rec, w,h);
NewColor32Array(result, w * h, True);
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); // get pixels **before** resizing
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
NewColor32Array(fPixels, fwidth * fheight, True);
fIsPremultiplied := false;
BlockNotify;
Clear(color);
UnblockNotify;
Resized;
end;
//------------------------------------------------------------------------------
procedure TImage32.Resize(newWidth, newHeight: Integer);
begin
ResizeTo(Self, newWidth, newHeight);
end;
//------------------------------------------------------------------------------
procedure TImage32.ResizeTo(targetImg: TImage32; newWidth, newHeight: Integer);
begin
if (newWidth <= 0) or (newHeight <= 0) then
begin
targetImg.SetSize(0, 0);
Exit;
end
else if (newWidth = fwidth) and (newHeight = fheight) then
begin
if targetImg <> Self then targetImg.Assign(Self);
Exit
end
else if IsEmpty then
begin
targetImg.SetSize(newWidth, newHeight);
Exit;
end;
targetImg.BlockNotify;
try
if targetImg.fResampler <= rNearestResampler then
NearestNeighborResize(Self, targetImg, newWidth, newHeight)
else
ResamplerResize(Self, targetImg, newWidth, newHeight);
finally
targetImg.UnblockNotify;
end;
targetImg.Resized;
end;
//------------------------------------------------------------------------------
procedure TImage32.Scale(s: double);
begin
Scale(s, s);
end;
//------------------------------------------------------------------------------
procedure TImage32.ScaleTo(targetImg: TImage32; s: double);
begin
ScaleTo(targetImg, s, s);
end;
//------------------------------------------------------------------------------
procedure TImage32.Scale(sx, sy: double);
begin
if (sx > 0) and (sy > 0) then
Resize(Round(width * sx), Round(height * sy));
end;
//------------------------------------------------------------------------------
procedure TImage32.ScaleTo(targetImg: TImage32; sx, sy: double);
begin
if (sx > 0) and (sy > 0) then
ResizeTo(targetImg, Round(width * sx), Round(height * sy));
end;
//------------------------------------------------------------------------------
procedure TImage32.ScaleToFit(width, height: integer);
var
sx, sy: double;
begin
if IsEmpty or (width < 2) or (height < 2) 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;
TranslateRect(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;
TranslateRect(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 < 128 then Exit;
inc(pc);
end;
result := false;
end;
//------------------------------------------------------------------------------
function TImage32.SaveToFile(filename: string; compressionQuality: integer): 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, compressionQuality);
finally
free;
end;
end;
//------------------------------------------------------------------------------
function TImage32.SaveToStream(stream: TStream;
const FmtExt: string; compressionQuality: integer): Boolean;
var
fileFormatClass: TImageFormatClass;
begin
result := false;
fileFormatClass := GetImageFormatClass(FmtExt);
if assigned(fileFormatClass) then
with fileFormatClass.Create do
try
SaveToStream(stream, self, compressionQuality);
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; imgIdx: integer): 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, imgIdx);
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: integer;
srcRecWidth, srcRecHeight: nativeint;
srcWidth, dstWidth: nativeint;
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);
srcWidth := src.Width;
dstWidth := Width;
s := @src.Pixels[srcRec.Top * srcWidth + srcRec.Left];
d := @Pixels[dstRec.top * dstWidth + dstRec.Left];
if assigned(blendFunc) then
begin
srcWidth := (srcWidth - srcRecWidth) * SizeOf(TColor32);
dstWidth := (dstWidth - srcRecWidth) * SizeOf(TColor32);
for i := 1 to srcRecHeight do
begin
for j := 1 to srcRecWidth do
begin
d^ := blendFunc(d^, s^);
inc(s); inc(d);
end;
inc(PByte(s), srcWidth); // byte offset to the next s line
inc(PByte(d), dstWidth); // byte offset to the next d line
end;
end
//simply overwrite src with dst (ie without blending)
else if (srcRecWidth = dstWidth) and (srcWidth = dstWidth) then
move(s^, d^, srcRecWidth * srcRecHeight * SizeOf(TColor32))
else
begin
srcWidth := srcWidth * SizeOf(TColor32);
dstWidth := dstWidth * SizeOf(TColor32);
srcRecWidth := srcRecWidth * SizeOf(TColor32);
for i := 1 to srcRecHeight do
begin
move(s^, d^, srcRecWidth);
inc(PByte(s), srcWidth); // srcWidth is in bytes
inc(PByte(d), dstWidth); // dstWidth is in bytes
end;
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.CopyInternalLine(src: TImage32;
const srcRec, dstRec: TRect; blendLineFunc: TBlendLineFunction);
var
i: integer;
srcRecWidth, srcRecHeight: nativeint;
srcWidth, dstWidth: nativeint;
s, d: PColor32;
begin
if not Assigned(blendLineFunc) then
begin
CopyInternal(src, srcRec, dstRec, nil);
Exit;
end;
// 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);
srcWidth := src.Width;
dstWidth := Width;
s := @src.Pixels[srcRec.Top * srcWidth + srcRec.Left];
d := @Pixels[dstRec.top * dstWidth + dstRec.Left];
if (srcRecWidth = dstWidth) and (srcWidth = dstWidth) then
blendLineFunc(d, s, srcRecWidth * srcRecHeight)
else
begin
srcWidth := srcWidth * SizeOf(TColor32);
dstWidth := dstWidth * SizeOf(TColor32);
for i := 1 to srcRecHeight do
begin
blendLineFunc(d, s, srcRecWidth);
inc(PByte(s), srcWidth); // srcWidth is in bytes
inc(PByte(d), dstWidth); // dstWidth is in bytes
end;
end;
end;
//------------------------------------------------------------------------------
function TImage32.Copy(src: TImage32; srcRec, dstRec: TRect): Boolean;
begin
Result := CopyBlendInternal(src, srcRec, dstRec, nil, nil);
end;
//------------------------------------------------------------------------------
function TImage32.CopyBlend(src: TImage32; const srcRec, dstRec: TRect;
blendFunc: TBlendFunction): Boolean;
begin
Result := CopyBlendInternal(src, srcRec, dstRec, blendFunc, nil);
end;
//------------------------------------------------------------------------------
function TImage32.CopyBlend(src: TImage32; const srcRec, dstRec: TRect;
blendLineFunc: TBlendLineFunction): Boolean;
begin
Result := CopyBlendInternal(src, srcRec, dstRec, nil, blendLineFunc);
end;
//------------------------------------------------------------------------------
function TImage32.CopyBlendInternal(src: TImage32; const srcRec: TRect; dstRec: TRect;
blendFunc: TBlendFunction; blendLineFunc: TBlendLineFunction): 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);
TranslateRect(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;
try
tmp.AssignSettings(src);
src.ScaleTo(tmp, scaleX, scaleY);
ScaleRect(srcRecClipped, scaleX, scaleY);
result := CopyBlendInternal(tmp, srcRecClipped, dstRec, blendFunc, blendLineFunc);
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);
TranslateRect(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.CopyBlendInternal(tmp, tmp.Bounds, dstRecClipped, blendFunc, blendLineFunc);
finally
tmp.Free;
end;
Exit;
end;
if Assigned(blendLineFunc) then
CopyInternalLine(src, srcRecClipped, dstRecClipped, blendLineFunc)
else
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;
//------------------------------------------------------------------------------
{$IF DEFINED (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); // -h => avoids need to flip image
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, wBytes: integer;
rec: TRect;
bi: TBitmapInfoHeader;
bm, oldBm: HBitmap;
dibBits: Pointer;
pDst, pSrc: PARGB;
memDc: HDC;
isTransparent: Boolean;
bf: BLENDFUNCTION;
oldStretchBltMode: integer;
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(dstDc);
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)
wBytes := wSrc * SizeOf(TColor32);
pDst := dibBits;
pSrc := PARGB(PixelRow[rec.Bottom -1]);
inc(pSrc, rec.Left);
if isTransparent and not IsPremultiplied then
begin
//premultiplied alphas are required when alpha blending
for i := rec.Bottom -1 downto rec.Top do
begin
PremultiplyAlpha(pSrc, pDst, wSrc);
dec(pSrc, Width);
inc(pDst, wSrc);
end;
end
else
begin
for i := rec.Bottom -1 downto rec.Top do
begin
Move(pSrc^, pDst^, wBytes);
dec(pSrc, Width);
inc(pDst, wSrc);
end;
end;
oldBm := SelectObject(memDC, bm);
if isTransparent then
begin
//premultiplied alphas are required when alpha blending
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
begin
BitBlt(dstDc, x,y, wSrc, hSrc, memDc, 0,0, SRCCOPY)
end else
begin
oldStretchBltMode := SetStretchBltMode(dstDc, COLORONCOLOR);
StretchBlt(dstDc, x,y, wDest, hDest, memDc, 0,0, wSrc,hSrc, SRCCOPY);
if oldStretchBltMode <> COLORONCOLOR then // restore mode
SetStretchBltMode(dstDc, oldStretchBltMode);
end;
SelectObject(memDC, oldBm);
finally
DeleteObject(bm);
end;
finally
DeleteDc(memDc);
end;
end;
{$IFEND}
//------------------------------------------------------------------------------
{$IF DEFINED(USING_VCL_LCL)}
procedure TImage32.CopyFromBitmap(bmp: TBitmap);
var
ms: TMemoryStream;
bmpFormat: TImageFormat_BMP;
begin
ms := TMemoryStream.create;
bmpFormat := TImageFormat_BMP.Create;
try
bmp.SaveToStream(ms);
ms.Position := 0;
bmpFormat.LoadFromStream(ms, self);
finally
ms.Free;
bmpFormat.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TImage32.CopyToBitmap(bmp: TBitmap);
var
ms: TMemoryStream;
bmpFormat: TImageFormat_BMP;
begin
ms := TMemoryStream.create;
bmpFormat := TImageFormat_BMP.Create;
try
bmpFormat.IncludeFileHeaderInSaveStream := true;
bmpFormat.SaveToStream(ms, self);
ms.Position := 0;
bmp.PixelFormat := pf32bit;
{$IF DEFINED(USING_VCL) AND DEFINED(ALPHAFORMAT)}
bmp.AlphaFormat := afDefined;
{$IFEND}
bmp.LoadFromStream(ms);
finally
ms.Free;
bmpFormat.Free;
end;
end;
//------------------------------------------------------------------------------
{$IFEND}
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;
//------------------------------------------------------------------------------
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;
NewColor32Array(a, fWidth * fHeight, True);
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;
NewColor32Array(a, fWidth, True);
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;
begin
if IsEmpty or fIsPremultiplied then Exit;
fIsPremultiplied := true;
PremultiplyAlpha(PARGB(PixelBase), PARGB(PixelBase), Width * Height);
//nb: no OnChange notify event here
end;
//------------------------------------------------------------------------------
procedure TImage32.SetRGB(rgbColor: TColor32);
var
i: Integer;
pc: PColor32;
c: TColor32;
begin
//this method leaves the alpha channel untouched
if IsEmpty then Exit;
pc := PixelBase;
rgbColor := rgbColor and $00FFFFFF;
for i := 0 to Width * Height - 1 do
begin
c := pc^;
if c and $FF000000 = 0 then
pc^ := 0 else
pc^ := c and $FF000000 or rgbColor;
inc(pc);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.SetRGB(rgbColor: TColor32; rec: TRect);
var
i,j, dx: Integer;
pc: PColor32;
begin
Types.IntersectRect(rec, rec, bounds);
if IsEmptyRect(rec) then Exit;
rgbColor := rgbColor and $00FFFFFF;
pc := 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^ := pc^ and $FF000000 or rgbColor;
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;
a: Byte;
begin
if opacity = 255 then Exit;
c := PARGB(PixelBase);
for i := 0 to Width * Height -1 do
begin
a := c.A;
if a <> 0 then
c.A := MulTable[a, opacity];
inc(c);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.ReduceOpacity(opacity: Byte; rec: TRect);
var
i,j, rw: Integer;
c: PARGB;
a: Byte;
lineOffsetInBytes: integer;
begin
Types.IntersectRect(rec, rec, bounds);
if IsEmptyRect(rec) then Exit;
rw := RectWidth(rec);
c := @Pixels[rec.Top * Width + rec.Left];
lineOffsetInBytes := (Width - rw) * SizeOf(TARGB);
for i := rec.Top to rec.Bottom - 1 do
begin
for j := 1 to rw do
begin
a := c.A;
if a <> 0 then
c.A := MulTable[a, opacity];
inc(c);
end;
inc(PByte(c), lineOffsetInBytes);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.Grayscale(mode: TGrayscaleMode;
linearAmountPercentage: double);
var
i: SizeInt;
cLinear: double;
c, lastC, grayC: TColor32;
p: PColor32Array;
amountCalc: Boolean;
oneMinusAmount: double;
begin
if mode = gsmSaturation then
begin
// linearAmountPercentage has no effect here
AdjustSaturation(-100);
Exit;
end;
// Colorimetric (perceptual luminance-preserving) conversion to grayscale
// See https://en.wikipedia.org/wiki/Grayscale#Converting_color_to_grayscale
if IsEmpty then Exit;
if linearAmountPercentage <= 0.0 then Exit;
amountCalc := linearAmountPercentage < 1.0;
oneMinusAmount := 1.0 - linearAmountPercentage;
p := PColor32Array(PixelBase);
lastC := 0;
grayC := 0;
for i := 0 to high(fPixels) do
begin
c := p[i] and $00FFFFFF;
if c <> 0 then
begin
if c <> lastC then // only do the calculation if the color channels changed
begin
lastC := c;
{$IF DEFINED(ANDROID)}
c := SwapRedBlue(c);
{$IFEND}
// We don't divide by 255 here, so can skip some division and multiplications.
// That means cLinear is actually "cLinear * 255"
cLinear := (0.2126 * Byte(c shr 16)) + (0.7152 * Byte(c shr 8)) + (0.0722 * Byte(c));
//cLinear := (0.2126 * TARGB(c).R) + (0.7152 * TARGB(c).G) + (0.0722 * TARGB(c).B);
if mode = gsmLinear then
c := ClampByte(cLinear)
else //if mode = gsmColorimetric then
begin
if cLinear <= (0.0031308 * 255) then // adjust for cLinear being "cLiniear * 255"
c := ClampByte(Integer(Round(12.92 * cLinear)))
else // for Power we must divide by 255 and then later multipy by 255
//c := ClampByte(Integer(Round((1.055 * 255) * Power(cLinear / 255, 1/2.4) - (0.055 * 255))));
end;
if not amountCalc then
grayC := (c shl 16) or (c shl 8) or c
else
begin
cLinear := c * linearAmountPercentage;
grayC := ClampByte(Integer(Round(Byte(lastC shr 16) * oneMinusAmount + cLinear))) shl 16 or
ClampByte(Integer(Round(Byte(lastC shr 8) * oneMinusAmount + cLinear))) shl 8 or
ClampByte(Integer(Round(Byte(lastC ) * oneMinusAmount + cLinear)));
end;
{$IF DEFINED(ANDROID)}
grayC := SwapRedBlue(grayC);
{$IFEND}
end;
p[i] := (p[i] and $FF000000) or grayC;
end;
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.InvertColors;
var
pc: PColor32Array;
i: SizeInt;
begin
pc := PColor32Array(PixelBase);
for i := 0 to Width * Height -1 do
pc[i] := pc[i] xor $00FFFFFF; // keep the alpha channel untouched
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.InvertAlphas;
var
pc: PColor32Array;
i: SizeInt;
begin
pc := PColor32Array(PixelBase);
for i := 0 to Width * Height -1 do
pc[i] := pc[i] xor $FF000000; // keep the color channels untouched
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.AdjustHue(percent: Integer);
var
i: SizeInt;
hsl: THsl;
lut: array [byte] of byte;
c, lastC, newC: TColor32;
p: PColor32Array;
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;
lastC := 0;
newC := 0;
p := PColor32Array(fPixels);
for i := 0 to high(fPixels) do
begin
c := p[i];
c := c and $00FFFFFF;
if c <> 0 then
begin
if c <> lastC then // only do the calculation if the color channels changed
begin
lastC := C;
hsl := RgbToHsl(c);
hsl.hue := lut[hsl.hue];
newC := HslToRgb(hsl);
end;
p[i] := (p[i] and $FF000000) or newC; // keep the alpha channel
end;
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.AdjustLuminance(percent: Integer);
var
i: SizeInt;
hsl: THsl;
pc: double;
lut: array [byte] of byte;
c, lastC, newC: TColor32;
p: PColor32Array;
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));
lastC := 0;
newC := 0;
p := PColor32Array(fPixels);
for i := 0 to high(fPixels) do
begin
c := p[i];
c := c and $00FFFFFF;
if c <> 0 then
begin
if c <> lastC then // only do the calculation if the color channels changed
begin
lastC := C;
hsl := RgbToHsl(c);
hsl.lum := lut[hsl.lum];
newC := HslToRgb(hsl);
end;
p[i] := (p[i] and $FF000000) or newC; // keep the alpha channel
end;
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TImage32.AdjustSaturation(percent: Integer);
var
i: SizeInt;
hsl: THsl;
lut: array [byte] of byte;
pc: double;
c, lastC, newC: TColor32;
p: PColor32Array;
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));
lastC := 0;
newC := 0;
p := PColor32Array(fPixels);
for i := 0 to high(fPixels) do
begin
c := p[i];
c := c and $00FFFFFF;
if c <> 0 then
begin
if c <> lastC then // only do the calculation if the color channels changed
begin
lastC := C;
hsl := RgbToHsl(c);
hsl.sat := lut[hsl.sat];
newC := HslToRgb(hsl);
end;
p[i] := (p[i] and $FF000000) or newC; // keep the alpha channel
end;
end;
Changed;
end;
//------------------------------------------------------------------------------
function TImage32.GetOpaqueBounds: TRect;
var
x,y, x1,x2,y1,y2: Integer;
found: Boolean;
begin
y1 := 0; y2 := 0;
found := false;
Result := NullRect;
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
Exit;
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);
end;
//------------------------------------------------------------------------------
function TImage32.CropTransparentPixels: TRect;
begin
Result := GetOpaqueBounds;
if IsEmptyRect(Result) then
SetSize(0,0) else
Crop(Result);
end;
//------------------------------------------------------------------------------
procedure TImage32.Rotate(angleRads: double);
var
mat: TMatrixD;
begin
{$IFDEF CLOCKWISE_ROTATION_WITH_NEGATIVE_ANGLES}
angleRads := -angleRads;
{$ENDIF}
//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;
// the rotation point isn't important
// because AffineTransformImage() will
// will resize and recenter the image
MatrixRotate(mat, NullPointD, angleRads);
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(Integer(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; quality: integer): 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, quality);
finally
fs.Free;
end;
end;
//------------------------------------------------------------------------------
class function TImageFormat.CanCopyToClipboard: Boolean;
begin
Result := false;
end;
//------------------------------------------------------------------------------
class function TImageFormat.GetImageCount(stream: TStream): integer;
begin
Result := 1;
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
begin
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;
Sigmoid[128] := 128;
for i := 1 to 127 do
Sigmoid[128+i] := 128 + Round(127 * sin(angle90 * i/127));
for i := 0 to 127 do
Sigmoid[i] := 255- Sigmoid[255-i];
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}
//------------------------------------------------------------------------------
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;
{$ENDIF}
finalization
CleanUpImageFormatClassList;
CleanUpResamplerClassList;
end.