{******************************************************************************}
{ }
{ Project JEDI Code Library (JCL) }
{ }
{ The contents of this file are subject to the Mozilla Public License Version }
{ 1.1 (the "License"); you may not use this file except in compliance with the }
{ License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ }
{ }
{ Software distributed under the License is distributed on an "AS IS" basis, }
{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for }
{ the specific language governing rights and limitations under the License. }
{ }
{ The Original Code is JclGraphics.pas. }
{ }
{ The resampling algorithms and methods used in this library were adapted by }
{ Anders Melander from the article "General Filtered Image Rescaling" by Dale }
{ Schumacher which appeared in the book Graphics Gems III, published by }
{ Academic Press, Inc. Additional improvements were done by David Ullrich and }
{ Josha Beukema. }
{ }
{ (C)opyright 1997-1999 Anders Melander }
{ }
{ The Initial Developer of the Original Code is documented in the accompanying }
{ help file JCL.chm. Portions created by these individuals are Copyright (C) }
{ of these individuals. }
{ }
{ Last modified: January 29, 2001 }
{ by Roland for use under BCB5 }
{ }
{******************************************************************************}
// (rom) added ScreenShot() functions from Bernhard Berger
unit JclGraphics;
{$I jcl.inc}
interface
uses
Windows, Classes, Graphics, SysUtils,
JclBase, JclGraphUtils, JclSynch;
type
EJclGraphicsError = class (EJclError);
TDynDynIntegerArrayArray = array of TDynIntegerArray;
TDynPointArray = array of TPoint;
TDynDynPointArrayArray = array of TDynPointArray;
TPointF = record
X: Single;
Y: Single;
end;
TDynPointArrayF = array of TPointF;
{ TJclBitmap32 draw mode }
TDrawMode = (dmOpaque, dmBlend);
{ stretch filter }
TStretchFilter = (sfNearest, sfLinear, sfSpline);
TConversionKind = (ckRed, ckGreen, ckBlue, ckAlpha, ckUniformRGB, ckWeightedRGB);
{ resampling support types }
TResamplingFilter = (rfBox, rfTriangle, rfHermite, rfBell, rfSpline,
rfLanczos3, rfMitchell);
{ Matrix declaration for transformation }
// modify Jan 28, 2001 for use under BCB5
// the compiler show error 245 "language feature ist not available"
// we must take a record and under this we can use the static array
// Note: the sourcecode modify general from M[] to M.A[] !!!!!
// TMatrix3d = array [0..2, 0..2] of Extended; // 3x3 double precision
TMatrix3d = record
A: array [0..2, 0..2] of Extended;
end;
TDynDynPointArrayArrayF = array of TDynPointArrayF;
TScanLine = array of Integer;
TScanLines = array of TScanLine;
TLUT8 = array [Byte] of Byte;
TGamma = array [Byte] of Byte;
TColorChannel = (ccRed, ccGreen, ccBlue, ccAlpha);
TGradientDirection = (gdVertical, gdHorizontal);
TPolyFillMode = (fmAlternate, fmWinding);
TJclRegionCombineOperator = (coAnd, coDiff, coOr, coXor);
TJclRegionBitmapMode = (rmInclude, rmExclude);
TJclRegionKind = (rkNull, rkSimple, rkComplex, rkError);
// modify Jan 28, 2001 for use under BCB5
// the compiler show error 245 "language feature ist not available"
// wie must take a record and under this we can use the static array
// Note: for init the array we used initialisation at the end of this unit
//
// const
// IdentityMatrix: TMatrix3d = (
// (1, 0, 0),
// (0, 1, 0),
// (0, 0, 1));
var
IdentityMatrix: TMatrix3d;
//------------------------------------------------------------------------------
// Classes
//------------------------------------------------------------------------------
type
TJclDesktopCanvas = class (TCanvas)
private
FDesktop: HDC;
public
constructor Create;
destructor Destroy; override;
end;
TJclRegion = class;
TJclRegionInfo = class (TObject)
private
FData: Pointer;
FDataSize: Integer;
function GetBox: TRect;
protected
function GetCount: Integer;
function GetRect(index: Integer): TRect;
public
constructor Create(Region: TJclRegion);
destructor Destroy; override;
property Box: TRect read GetBox;
property Rectangles[Index: Integer]: TRect read GetRect;
property Count: Integer read GetCount;
end;
TJclRegion = class (TObject)
private
FHandle: HRGN;
FBoxRect: TRect;
FRegionType: Integer;
procedure CheckHandle;
protected
function GetHandle: HRGN;
function GetBox: TRect;
function GetRegionType: TJclRegionKind;
public
constructor Create(RegionHandle: HRGN);
constructor CreateElliptic(const ARect: TRect); overload;
constructor CreateElliptic(Top, Left, Bottom, Right: Integer); overload;
constructor CreatePoly(const Points: TDynPointArray; Count: Integer; FillMode: TPolyFillMode);
constructor CreatePolyPolygon(const Points: TDynPointArray; const Vertex: TDynIntegerArray;
Count: Integer; FillMode: TPolyFillMode);
constructor CreateRect(const Top, Left, Bottom, Right: Integer); overload;
constructor CreateRect(ARect: TRect); overload;
constructor CreateRoundRect(const ARect: TRect; CornerWidth, CornerHeight: Integer); overload;
constructor CreateRoundRect(Top, Left, Bottom, Right: Integer; CornerWidth, CornerHeight: Integer); overload;
constructor CreateBitmap(Bitmap: TBitmap; RegionColor: TColor; RegionBitmapMode: TJclRegionBitmapMode);
constructor CreatePath(Canvas: TCanvas);
constructor CreateRegionInfo(RegionInfo: TJclRegionInfo);
destructor Destroy; override;
procedure Clip(Canvas: TCanvas);
procedure Combine(DestRegion, SrcRegion: TJclRegion; CombineOp: TJclRegionCombineOperator); overload;
procedure Combine(SrcRegion: TJclRegion; CombineOp: TJclRegionCombineOperator); overload;
function Copy: TJclRegion;
function Equals(CompareRegion: TJclRegion): Boolean;
procedure Fill(Canvas: TCanvas);
procedure FillGradient(Canvas: TCanvas; ColorCount: Integer; StartColor, EndColor: TColor; ADirection: TGradientDirection);
procedure Frame(Canvas: TCanvas; FrameWidth, FrameHeight: Integer);
procedure Invert(Canvas: TCanvas);
procedure Offset(X, Y: Integer);
procedure Paint(Canvas: TCanvas);
function PointIn(X, Y: Integer): Boolean; overload;
function PointIn(const Point: TPoint): Boolean; overload;
function RectIn(const ARect: TRect): Boolean; overload;
function RectIn(Top, Left, Bottom, Right: Integer): Boolean; overload;
procedure SetWindow(Window: HWND; Redraw: Boolean);
function GetRegionInfo: TJclRegionInfo;
property Box: TRect read GetBox;
property Handle: HRGN read GetHandle;
property RegionType: TJclRegionKind read GetRegionType;
end;
{ TJclThreadPersistent }
{ TJclThreadPersistent is an ancestor for TJclBitmap32 object. In addition to
TPersistent methods, it provides thread-safe locking and change notification }
TJclThreadPersistent = class (TPersistent)
private
FLock: TJclCriticalSection;
FLockCount: Integer;
FUpdateCount: Integer;
FOnChanging: TNotifyEvent;
FOnChange: TNotifyEvent;
protected
property LockCount: Integer read FLockCount;
property UpdateCount: Integer read FUpdateCount;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Changing; virtual;
procedure Changed; virtual;
procedure BeginUpdate;
procedure EndUpdate;
procedure Lock;
procedure Unlock;
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
{ TJclCustomMap }
{ An ancestor for bitmaps and similar 2D distributions wich have width and
height properties }
TJclCustomMap = class (TJclThreadPersistent)
private
FHeight: Integer;
FWidth: Integer;
procedure SetHeight(NewHeight: Integer);
procedure SetWidth(NewWidth: Integer);
public
procedure Delete; virtual;
function Empty: Boolean; virtual;
procedure SetSize(Source: TPersistent); overload;
procedure SetSize(NewWidth, NewHeight: Integer); overload; virtual;
property Height: Integer read FHeight write SetHeight;
property Width: Integer read FWidth write SetWidth;
end;
{ TJclBitmap32 }
{ This is the core of Graphics32 unit. The TJclBitmap32 class is responsible
for storage of a bitmap, as well as for drawing in it }
TJclBitmap32 = class (TJclCustomMap)
private
FBitmapInfo: TBitmapInfo;
FBits: PColor32Array;
FDrawMode: TDrawMode;
FFont: TFont;
FHandle: HBITMAP;
FHDC: HDC;
FMasterAlpha: Byte;
FOuterColor: TColor32; // the value returned when accessing outer areas
FPenColor: TColor32;
FStippleCounter: Single;
FStipplePattern: TArrayOfColor32;
FStippleStep: Single;
FStretchFilter: TStretchFilter;
function GetPixel(X, Y: Integer): TColor32;
function GetPixelS(X, Y: Integer): TColor32;
function GetPixelPtr(X, Y: Integer): PColor32;
function GetScanLine(Y: Integer): PColor32Array;
procedure SetDrawMode(Value: TDrawMode);
procedure SetFont(Value: TFont);
procedure SetMasterAlpha(Value: Byte);
procedure SetPixel(X, Y: Integer; Value: TColor32);
procedure SetPixelS(X, Y: Integer; Value: TColor32);
procedure SetStretchFilter(Value: TStretchFilter);
protected
FontHandle: HFont;
RasterX: Integer;
RasterY: Integer;
RasterXF: Single;
RasterYF: Single;
procedure AssignTo(Dst: TPersistent); override;
function ClipLine(var X0, Y0, X1, Y1: Integer): Boolean;
function ClipLineF(var X0, Y0, X1, Y1: Single; MinX, MaxX, MinY, MaxY: Single): Boolean;
procedure FontChanged(Sender: TObject);
procedure SET_T256(X, Y: Integer; C: TColor32);
procedure SET_TS256(X, Y: Integer; C: TColor32);
procedure ReadData(Stream: TStream); virtual;
procedure WriteData(Stream: TStream); virtual;
procedure DefineProperties(Filer: TFiler); override;
public
constructor Create; override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure SetSize(NewWidth, NewHeight: Integer); override;
function Empty: Boolean; override;
procedure Clear; overload;
procedure Clear(FillColor: TColor32); overload;
procedure Delete; override;
procedure LoadFromStream(Stream: TStream);
procedure SaveToStream(Stream: TStream);
procedure LoadFromFile(const FileName: string);
procedure SaveToFile(const FileName: string);
procedure ResetAlpha;
procedure Draw(DstX, DstY: Integer; Src: TJclBitmap32); overload;
procedure Draw(DstRect, SrcRect: TRect; Src: TJclBitmap32); overload;
procedure Draw(DstRect, SrcRect: TRect; hSrc: HDC); overload;
procedure DrawTo(Dst: TJclBitmap32); overload;
procedure DrawTo(Dst: TJclBitmap32; DstX, DstY: Integer); overload;
procedure DrawTo(Dst: TJclBitmap32; DstRect: TRect); overload;
procedure DrawTo(Dst: TJclBitmap32; DstRect, SrcRect: TRect); overload;
procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload;
procedure DrawTo(hDst: HDC; DstRect, SrcRect: TRect); overload;
function GetPixelB(X, Y: Integer): TColor32;
procedure SetPixelT(X, Y: Integer; Value: TColor32); overload;
procedure SetPixelT(var Ptr: PColor32; Value: TColor32); overload;
procedure SetPixelTS(X, Y: Integer; Value: TColor32);
procedure SetPixelF(X, Y: Single; Value: TColor32);
procedure SetPixelFS(X, Y: Single; Value: TColor32);
procedure SetStipple(NewStipple: TArrayOfColor32); overload;
procedure SetStipple(NewStipple: array of TColor32); overload;
procedure SetStippleStep(Value: Single);
procedure ResetStippleCounter;
function GetStippleColor: TColor32;
procedure DrawHorzLine(X1, Y, X2: Integer; Value: TColor32);
procedure DrawHorzLineS(X1, Y, X2: Integer; Value: TColor32);
procedure DrawHorzLineT(X1, Y, X2: Integer; Value: TColor32);
procedure DrawHorzLineTS(X1, Y, X2: Integer; Value: TColor32);
procedure DrawHorzLineTSP(X1, Y, X2: Integer);
procedure DrawVertLine(X, Y1, Y2: Integer; Value: TColor32);
procedure DrawVertLineS(X, Y1, Y2: Integer; Value: TColor32);
procedure DrawVertLineT(X, Y1, Y2: Integer; Value: TColor32);
procedure DrawVertLineTS(X, Y1, Y2: Integer; Value: TColor32);
procedure DrawVertLineTSP(X, Y1, Y2: Integer);
procedure DrawLine(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = False {$ENDIF});
procedure DrawLineS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = False {$ENDIF});
procedure DrawLineT(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = False {$ENDIF});
procedure DrawLineTS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = False {$ENDIF});
procedure DrawLineA(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = False {$ENDIF});
procedure DrawLineAS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = False {$ENDIF});
procedure DrawLineF(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = False {$ENDIF});
procedure DrawLineFS(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = False {$ENDIF});
procedure DrawLineFP(X1, Y1, X2, Y2: Single; L: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = False {$ENDIF});
procedure DrawLineFSP(X1, Y1, X2, Y2: Single; L: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = False {$ENDIF});
procedure MoveTo(X, Y: Integer);
procedure LineToS(X, Y: Integer);
procedure LineToTS(X, Y: Integer);
procedure LineToAS(X, Y: Integer);
procedure MoveToF(X, Y: Single);
procedure LineToFS(X, Y: Single);
procedure FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure FillRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure FillRectT(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure FillRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure FrameRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure FrameRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload;
procedure FrameRectTSP(X1, Y1, X2, Y2: Integer); overload;
procedure RaiseRectTS(X1, Y1, X2, Y2: Integer; Contrast: Integer);
procedure UpdateFont;
procedure TextOut(X, Y: Integer; const Text: string); overload;
procedure TextOut(X, Y: Integer; const ClipRect: TRect; const Text: string); overload;
procedure TextOut(ClipRect: TRect; const Flags: Cardinal; const Text: string); overload;
function TextExtent(const Text: string): TSize;
function TextHeight(const Text: string): Integer;
function TextWidth(const Text: string): Integer;
procedure RenderText(X, Y: Integer; const Text: string; AALevel: Integer; Color: TColor32);
property BitmapHandle: HBITMAP read FHandle;
property BitmapInfo: TBitmapInfo read FBitmapInfo;
property Bits: PColor32Array read FBits;
property Font: TFont read FFont write SetFont;
property Handle: HDC read FHDC;
property PenColor: TColor32 read FPenColor write FPenColor;
property Pixel[X, Y: Integer]: TColor32 read GetPixel write SetPixel; default;
property PixelS[X, Y: Integer]: TColor32 read GetPixelS write SetPixelS;
property PixelPtr[X, Y: Integer]: PColor32 read GetPixelPtr;
property ScanLine[Y: Integer]: PColor32Array read GetScanLine;
published
property DrawMode: TDrawMode read FDrawMode write SetDrawMode default dmOpaque;
property MasterAlpha: Byte read FMasterAlpha write SetMasterAlpha default $FF;
property OuterColor: TColor32 read FOuterColor write FOuterColor default 0;
property StretchFilter: TStretchFilter read FStretchFilter write SetStretchFilter default sfNearest;
property OnChanging;
property OnChange;
end;
TJclByteMap = class (TJclCustomMap)
private
FBytes: TDynByteArray;
FHeight: Integer;
FWidth: Integer;
function GetValue(X, Y: Integer): Byte;
function GetValPtr(X, Y: Integer): PByte;
procedure SetValue(X, Y: Integer; Value: Byte);
protected
procedure AssignTo(Dst: TPersistent); override;
public
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
function Empty: Boolean; override;
procedure Clear(FillValue: Byte);
procedure ReadFrom(Source: TJclBitmap32; Conversion: TConversionKind);
procedure SetSize(NewWidth, NewHeight: Integer); override;
procedure WriteTo(Dest: TJclBitmap32; Conversion: TConversionKind); overload;
procedure WriteTo(Dest: TJclBitmap32; const Palette: TPalette32); overload;
property Bytes: TDynByteArray read FBytes;
property ValPtr[X, Y: Integer]: PByte read GetValPtr;
property Value[X, Y: Integer]: Byte read GetValue write SetValue; default;
end;
TJclTransformation = class (TObject)
public
function GetTransformedBounds(const Src: TRect): TRect; virtual; abstract;
procedure PrepareTransform; virtual; abstract;
procedure Transform(DstX, DstY: Integer; out SrcX, SrcY: Integer); virtual; abstract;
procedure Transform256(DstX, DstY: Integer; out SrcX256, SrcY256: Integer); virtual; abstract;
end;
TJclLinearTransformation = class (TJclTransformation)
private
FMatrix: TMatrix3d;
protected
A: Integer;
B: Integer;
C: Integer;
D: Integer;
E: Integer;
F: Integer;
public
constructor Create; virtual;
function GetTransformedBounds(const Src: TRect): TRect; override;
procedure PrepareTransform; override;
procedure Transform(DstX, DstY: Integer; out SrcX, SrcY: Integer); override;
procedure Transform256(DstX, DstY: Integer; out SrcX256, SrcY256: Integer); override;
procedure Clear;
procedure Rotate(Cx, Cy, Alpha: Extended); // degrees
procedure Skew(Fx, Fy: Extended);
procedure Scale(Sx, Sy: Extended);
procedure Translate(Dx, Dy: Extended);
property Matrix: TMatrix3d read FMatrix write FMatrix;
end;
//------------------------------------------------------------------------------
// Bitmap Functions
//------------------------------------------------------------------------------
procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter;
Radius: Single; Source, Target: TBitmap); overload;
procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter;
Radius: Single; Source: TBitmap); overload;
procedure DrawBitmap(DC: HDC; Bitmap: HBitMap; X, Y, Width, Height: Integer);
function GetAntialiasedBitmap(const Bitmap: TBitmap): TBitmap;
{$IFDEF COMPILER4_UP}
procedure BitmapToJPeg(const FileName: string);
procedure JPegToBitmap(const FileName: string);
{$ENDIF COMPILER4_UP}
function ExtractIconCount(const FileName: string): Integer;
function BitmapToIcon(Bitmap: HBITMAP; cx, cy: Integer): HICON;
function IconToBitmap(Icon: HICON): HBITMAP;
procedure BlockTransfer( Dst: TJclBitmap32; DstX: Integer; DstY: Integer; Src: TJclBitmap32;
SrcRect: TRect; CombineOp: TDrawMode);
procedure StretchTransfer( Dst: TJclBitmap32; DstRect: TRect; Src: TJclBitmap32; SrcRect: TRect;
StretchFilter: TStretchFilter; CombineOp: TDrawMode);
procedure Transform(Dst, Src: TJclBitmap32; SrcRect: TRect; Transformation: TJclTransformation);
procedure SetBorderTransparent(ABitmap: TJclBitmap32; ARect: TRect);
function FillGradient(DC: HDC; ARect: TRect; ColorCount: Integer;
StartColor, EndColor: TColor; ADirection: TGradientDirection): Boolean; overload;
function CreateRegionFromBitmap(Bitmap: TBitmap; RegionColor: TColor;
RegionBitmapMode: TJclRegionBitmapMode): HRGN;
procedure ScreenShot(bm: TBitmap; Left, Top, Width, Height: Integer; Window: HWND {$IFDEF SUPPORTS_DEFAULTPARAMS} = 0 {$ENDIF}); overload;
procedure ScreenShot(bm: TBitmap); overload;
//------------------------------------------------------------------------------
// PolyLines and Polygons
//------------------------------------------------------------------------------
procedure PolyLineTS(Bitmap: TJclBitmap32; const Points: TDynPointArray; Color: TColor32);
procedure PolyLineAS(Bitmap: TJclBitmap32; const Points: TDynPointArray; Color: TColor32);
procedure PolyLineFS(Bitmap: TJclBitmap32; const Points: TDynPointArrayF; Color: TColor32);
procedure PolygonTS(Bitmap: TJclBitmap32; const Points: TDynPointArray; Color: TColor32);
procedure PolygonAS(Bitmap: TJclBitmap32; const Points: TDynPointArray; Color: TColor32);
procedure PolygonFS(Bitmap: TJclBitmap32; const Points: TDynPointArrayF; Color: TColor32);
procedure PolyPolygonTS(Bitmap: TJclBitmap32; const Points: TDynDynPointArrayArray;
Color: TColor32);
procedure PolyPolygonAS(Bitmap: TJclBitmap32; const Points: TDynDynPointArrayArray;
Color: TColor32);
procedure PolyPolygonFS(Bitmap: TJclBitmap32; const Points: TDynDynPointArrayArrayF;
Color: TColor32);
//------------------------------------------------------------------------------
// Filters
//------------------------------------------------------------------------------
procedure AlphaToGrayscale(Dst, Src: TJclBitmap32);
procedure IntensityToAlpha(Dst, Src: TJclBitmap32);
procedure Invert(Dst, Src: TJclBitmap32);
procedure InvertRGB(Dst, Src: TJclBitmap32);
procedure ColorToGrayscale(Dst, Src: TJclBitmap32);
procedure ApplyLUT(Dst, Src: TJclBitmap32; const LUT: TLUT8);
procedure SetGamma(Gamma: Single {$IFDEF SUPPORTS_DEFAULTPARAMS} = 0.7 {$ENDIF});
implementation
uses
ClipBrd, CommCtrl, Controls, Math, ShellApi,
{$IFDEF COMPILER4_UP}
ImgList, JPeg,
{$ENDIF COMPILER4_UP}
JclLogic, JclResources, JclSysUtils;
type
TRGBInt = record
R: Integer;
G: Integer;
B: Integer;
end;
PBGR = ^TBGR;
TBGR = packed record
B: Byte;
G: Byte;
R: Byte;
end;
PPixelArray = ^TPixelArray;
TPixelArray = array [0..0] of TBGR;
TBitmapFilterFunction = function (Value: Single): Single;
PContributor = ^TContributor;
TContributor = record
Weight: Integer; // Pixel Weight
Pixel: Integer; // Source Pixel
end;
TContributors = array of TContributor;
// list of source pixels contributing to a destination pixel
TContributorEntry = record
N: Integer;
Contributors: TContributors;
end;
TContributorList = array of TContributorEntry;
TJclGraphicAccess = class (TGraphic);
const
DefaultFilterRadius: array [TResamplingFilter] of Single =
(0.5, 1.0, 1.0, 1.5, 2.0, 3.0, 2.0);
_RGB: TColor32 = $00FFFFFF;
var
{ Gamma bias for line/pixel antialiasing/shape correction }
GAMMA_TABLE: TGamma;
threadvar
// globally used cache for current image (speeds up resampling about 10%)
CurrentLineR: array of Integer;
CurrentLineG: array of Integer;
CurrentLineB: array of Integer;
//==============================================================================
// Helper functions
//==============================================================================
function IntToByte(Value: Integer): Byte;
begin
Result := Math.Max(0, Math.Min(255, Value));
end;
//------------------------------------------------------------------------------
procedure CheckBitmaps(Dst, Src: TJclBitmap32);
begin
if (Dst = nil) or Dst.Empty then
raise EJclGraphicsError.CreateResRec(@RsDestinationBitmapEmpty);
if (Src = nil) or Src.Empty then
raise EJclGraphicsError.CreateResRec(@RsSourceBitmapEmpty);
end;
//------------------------------------------------------------------------------
function CheckSrcRect(Src: TJclBitmap32; const SrcRect: TRect): Boolean;
begin
Result := False;
if IsRectEmpty(SrcRect) then
Exit;
if (SrcRect.Left < 0) or (SrcRect.Right > Src.Width) or
(SrcRect.Top < 0) or (SrcRect.Bottom > Src.Height) then
raise EJclGraphicsError.CreateResRec(@RsSourceBitmapInvalid);
Result := True;
end;
//==============================================================================
// Internal low level routines
//==============================================================================
procedure FillLongword(var X; Count: Integer; Value: LongWord); assembler;
asm
// EAX = X
// EDX = Count
// ECX = Value
PUSH EDI
MOV EDI, EAX // Point EDI to destination
MOV EAX, ECX
MOV ECX, EDX
TEST ECX, ECX
JS @@EXIT
REP STOSD // Fill count dwords
@@EXIT:
POP EDI
end;
//------------------------------------------------------------------------------
function Clamp(Value: Integer): TColor32;
begin
if Value < 0 then
Result := 0
else
if Value > 255 then
Result := 255
else
Result := Value;
end;
//------------------------------------------------------------------------------
procedure TestSwap(var A, B: Integer); assembler;
asm
// EAX = [A]
// EDX = [B]
MOV ECX, [EAX] // ECX := [A]
CMP ECX, [EDX] // ECX <= [B]? Exit
JLE @@EXIT
XCHG ECX, [EDX] // ECX <-> [B];
MOV [EAX], ECX // [A] := ECX
@@EXIT:
end;
//------------------------------------------------------------------------------
function TestClip(var A, B: Integer; Size: Integer): Boolean;
begin
TestSwap(A, B); // now A = min(A,B) and B = max(A, B)
if A < 0 then
A := 0;
if B >= Size then
B := Size - 1;
Result := B >= A;
end;
//------------------------------------------------------------------------------
function Constrain(Value, Lo, Hi: Integer): Integer;
begin
if Value <= Lo then
Result := Lo
else
if Value >= Hi then
Result := Hi
else
Result := Value;
end;
//==============================================================================
// Filter functions for stretching of TBitmaps
//==============================================================================
// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1
function BitmapHermiteFilter(Value: Single): Single;
begin
if Value < 0.0 then
Value := -Value;
if Value < 1 then
Result := (2 * Value - 3) * Sqr(Value) + 1
else
Result := 0;
end;
//------------------------------------------------------------------------------
function BitmapBoxFilter(Value: Single): Single;
// This filter is also known as 'nearest neighbour' Filter.
begin
if (Value > -0.5) and (Value <= 0.5) then
Result := 1.0
else
Result := 0.0;
end;
//------------------------------------------------------------------------------
// aka 'linear' or 'bilinear' filter
function BitmapTriangleFilter(Value: Single): Single;
begin
if Value < 0.0 then
Value := -Value;
if Value < 1.0 then
Result := 1.0 - Value
else
Result := 0.0;
end;
//------------------------------------------------------------------------------
function BitmapBellFilter(Value: Single): Single;
begin
if Value < 0.0 then
Value := -Value;
if Value < 0.5 then
Result := 0.75 - Sqr(Value)
else
if Value < 1.5 then
begin
Value := Value - 1.5;
Result := 0.5 * Sqr(Value);
end
else
Result := 0.0;
end;
//------------------------------------------------------------------------------
// B-spline filter
function BitmapSplineFilter(Value: Single): Single;
var
Temp: Single;
begin
if Value < 0.0 then
Value := -Value;
if Value < 1.0 then
begin
Temp := Sqr(Value);
Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0;
end
else
if Value < 2.0 then
begin
Value := 2.0 - Value;
Result := Sqr(Value) * Value / 6.0;
end
else
Result := 0.0;
end;
//------------------------------------------------------------------------------
function BitmapLanczos3Filter(Value: Single): Single;
function SinC(Value: Single): Single;
begin
if Value <> 0.0 then
begin
Value := Value * Pi;
Result := System.Sin(Value) / Value;
end
else
Result := 1.0;
end;
begin
if Value < 0.0 then
Value := -Value;
if Value < 3.0 then
Result := SinC(Value) * SinC(Value / 3.0)
else
Result := 0.0;
end;
//------------------------------------------------------------------------------
function BitmapMitchellFilter(Value: Single): Single;
const
B = 1.0 / 3.0;
C = 1.0 / 3.0;
var
Temp: Single;
begin
if Value < 0.0 then
Value := -Value;
Temp := Sqr(Value);
if Value < 1.0 then
begin
Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp))
+ ((-18.0 + 12.0 * B + 6.0 * C) * Temp)
+ (6.0 - 2.0 * B));
Result := Value / 6.0;
end
else
if Value < 2.0 then
begin
Value := (((-B - 6.0 * C) * (Value * Temp))
+ ((6.0 * B + 30.0 * C) * Temp)
+ ((-12.0 * B - 48.0 * C) * Value)
+ (8.0 * B + 24.0 * C));
Result := Value / 6.0;
end
else
Result := 0.0;
end;
//------------------------------------------------------------------------------
const
FilterList: array [TResamplingFilter] of TBitmapFilterFunction = (
BitmapBoxFilter,
BitmapTriangleFilter,
BitmapHermiteFilter,
BitmapBellFilter,
BitmapSplineFilter,
BitmapLanczos3Filter,
BitmapMitchellFilter
);
//------------------------------------------------------------------------------
procedure FillLineCache(N, Delta: Integer; Line: Pointer);
var
I: Integer;
Run: PBGR;
begin
Run := Line;
for I := 0 to N - 1 do
begin
CurrentLineR[I] := Run.R;
CurrentLineG[I] := Run.G;
CurrentLineB[I] := Run.B;
Inc(PByte(Run), Delta);
end;
end;
//------------------------------------------------------------------------------
function ApplyContributors(N: Integer; Contributors: TContributors): TBGR;
var
J: Integer;
RGB: TRGBInt;
Total,
Weight: Integer;
Pixel: Cardinal;
Contr: ^TContributor;
begin
RGB.R := 0;
RGB.G := 0;
RGB.B := 0;
Total := 0;
Contr := @Contributors[0];
for J := 0 to N - 1 do
begin
Weight := Contr.Weight;
Inc(Total, Weight);
Pixel := Contr.Pixel;
Inc(RGB.R, CurrentLineR[Pixel] * Weight);
Inc(RGB.G, CurrentLineG[Pixel] * Weight);
Inc(RGB.B, CurrentLineB[Pixel] * Weight);
Inc(Contr);
end;
if Total = 0 then
begin
Result.R := IntToByte(RGB.R shr 8);
Result.G := IntToByte(RGB.G shr 8);
Result.B := IntToByte(RGB.B shr 8);
end
else
begin
Result.R := IntToByte(RGB.R div Total);
Result.G := IntToByte(RGB.G div Total);
Result.B := IntToByte(RGB.B div Total);
end;
end;
//------------------------------------------------------------------------------
// This is the actual scaling routine. Target must be allocated already with
// sufficient size. Source must contain valid data, Radius must not be 0 and
// Filter must not be nil.
procedure DoStretch(Filter: TBitmapFilterFunction; Radius: Single; Source, Target: TBitmap);
var
ScaleX, ScaleY: Single; // Zoom scale factors
I, J, K, N: Integer; // Loop variables
Center: Single; // Filter calculation variables
Width: Single;
Weight: Integer; // Filter calculation variables
Left, Right: Integer; // Filter calculation variables
Work: TBitmap;
ContributorList: TContributorList;
SourceLine, DestLine: PPixelArray;
DestPixel: PBGR;
Delta, DestDelta: Integer;
SourceHeight, SourceWidth: Integer;
TargetHeight, TargetWidth: Integer;
begin
// shortcut variables
SourceHeight := Source.Height;
SourceWidth := Source.Width;
TargetHeight := Target.Height;
TargetWidth := Target.Width;
// create intermediate image to hold horizontal zoom
Work := TBitmap.Create;
try
Work.PixelFormat := pf24Bit;
Work.Height := SourceHeight;
Work.Width := TargetWidth;
if SourceWidth = 1 then
ScaleX := TargetWidth / SourceWidth
else
ScaleX := (TargetWidth - 1) / (SourceWidth - 1);
if SourceHeight = 1 then
ScaleY := TargetHeight / SourceHeight
else
ScaleY := (TargetHeight - 1) / (SourceHeight - 1);
// pre-calculate filter contributions for a row
SetLength(ContributorList, TargetWidth);
// horizontal sub-sampling
if ScaleX < 1 then
begin
// scales from bigger to smaller Width
Width := Radius / ScaleX;
for I := 0 to TargetWidth - 1 do
begin
ContributorList[I].N := 0;
SetLength(ContributorList[I].Contributors, Trunc(2 * Width + 1));
Center := I / ScaleX;
Left := Math.Floor(Center - Width);
Right := Math.Ceil(Center + Width);
for J := Left to Right do
begin
Weight := Round(Filter((Center - J) * ScaleX) * ScaleX * 256);
if Weight <> 0 then
begin
if J < 0 then
N := -J
else
if J >= SourceWidth then
N := SourceWidth - J + SourceWidth - 1
else
N := J;
K := ContributorList[I].N;
Inc(ContributorList[I].N);
ContributorList[I].Contributors[K].Pixel := N;
ContributorList[I].Contributors[K].Weight := Weight;
end;
end;
end;
end
else
begin
// horizontal super-sampling
// scales from smaller to bigger Width
for I := 0 to TargetWidth - 1 do
begin
ContributorList[I].N := 0;
SetLength(ContributorList[I].Contributors, Trunc(2 * Radius + 1));
Center := I / ScaleX;
Left := Math.Floor(Center - Radius);
Right := Math.Ceil(Center + Radius);
for J := Left to Right do
begin
Weight := Round(Filter(Center - J) * 256);
if Weight <> 0 then
begin
if J < 0 then
N := -J
else
if J >= SourceWidth then
N := SourceWidth - J + SourceWidth - 1
else
N := J;
K := ContributorList[I].N;
Inc(ContributorList[I].N);
ContributorList[I].Contributors[K].Pixel := N;
ContributorList[I].Contributors[K].Weight := Weight;
end;
end;
end;
end;
// now apply filter to sample horizontally from Src to Work
SetLength(CurrentLineR, SourceWidth);
SetLength(CurrentLineG, SourceWidth);
SetLength(CurrentLineB, SourceWidth);
for K := 0 to SourceHeight - 1 do
begin
SourceLine := Source.ScanLine[K];
FillLineCache(SourceWidth, 3, SourceLine);
DestPixel := Work.ScanLine[K];
for I := 0 to TargetWidth - 1 do
with ContributorList[I] do
begin
DestPixel^ := ApplyContributors(N, ContributorList[I].Contributors);
// move on to next column
Inc(DestPixel);
end;
end;
// free the memory allocated for horizontal filter weights, since we need
// the structure again
for I := 0 to TargetWidth - 1 do
ContributorList[I].Contributors := nil;
ContributorList := nil;
// pre-calculate filter contributions for a column
SetLength(ContributorList, TargetHeight);
// vertical sub-sampling
if ScaleY < 1 then
begin
// scales from bigger to smaller height
Width := Radius / ScaleY;
for I := 0 to TargetHeight - 1 do
begin
ContributorList[I].N := 0;
SetLength(ContributorList[I].Contributors, Trunc(2 * Width + 1));
Center := I / ScaleY;
Left := Math.Floor(Center - Width);
Right := Math.Ceil(Center + Width);
for J := Left to Right do
begin
Weight := Round(Filter((Center - J) * ScaleY) * ScaleY * 256);
if Weight <> 0 then
begin
if J < 0 then
N := -J
else
if J >= SourceHeight then
N := SourceHeight - J + SourceHeight - 1
else
N := J;
K := ContributorList[I].N;
Inc(ContributorList[I].N);
ContributorList[I].Contributors[K].Pixel := N;
ContributorList[I].Contributors[K].Weight := Weight;
end;
end;
end;
end
else
begin
// vertical super-sampling
// scales from smaller to bigger height
for I := 0 to TargetHeight - 1 do
begin
ContributorList[I].N := 0;
SetLength(ContributorList[I].Contributors, Trunc(2 * Radius + 1));
Center := I / ScaleY;
Left := Math.Floor(Center - Radius);
Right := Math.Ceil(Center + Radius);
for J := Left to Right do
begin
Weight := Round(Filter(Center - J) * 256);
if Weight <> 0 then
begin
if J < 0 then
N := -J
else
if J >= SourceHeight then
N := SourceHeight - J + SourceHeight - 1
else
N := J;
K := ContributorList[I].N;
Inc(ContributorList[I].N);
ContributorList[I].Contributors[K].Pixel := N;
ContributorList[I].Contributors[K].Weight := Weight;
end;
end;
end;
end;
// apply filter to sample vertically from Work to Target
SetLength(CurrentLineR, SourceHeight);
SetLength(CurrentLineG, SourceHeight);
SetLength(CurrentLineB, SourceHeight);
SourceLine := Work.ScanLine[0];
Delta := Integer(Work.ScanLine[1]) - Integer(SourceLine);
DestLine := Target.ScanLine[0];
DestDelta := Integer(Target.ScanLine[1]) - Integer(DestLine);
for K := 0 to TargetWidth - 1 do
begin
DestPixel := Pointer(DestLine);
FillLineCache(SourceHeight, Delta, SourceLine);
for I := 0 to TargetHeight - 1 do
with ContributorList[I] do
begin
DestPixel^ := ApplyContributors(N, ContributorList[I].Contributors);
Inc(Integer(DestPixel), DestDelta);
end;
Inc(SourceLine);
Inc(DestLine);
end;
// free the memory allocated for vertical filter weights
for I := 0 to TargetHeight - 1 do
ContributorList[I].Contributors := nil;
// this one is done automatically on exit, but is here for completeness
ContributorList := nil;
finally
Work.Free;
CurrentLineR := nil;
CurrentLineG := nil;
CurrentLineB := nil;
end;
end;
//==============================================================================
// Filter functions for TJclBitmap32
//==============================================================================
type
TPointRec = record
Pos: Integer;
Weight: Integer;
end;
TCluster = array of TPointRec;
TMappingTable = array of TCluster;
TFilterFunc = function (Value: Extended): Extended;
//------------------------------------------------------------------------------
function NearestFilter(Value: Extended): Extended;
begin
if (Value > -0.5) and (Value <= 0.5) then
Result := 1
else
Result := 0;
end;
//------------------------------------------------------------------------------
function LinearFilter(Value: Extended): Extended;
begin
if Value < -1 then
Result := 0
else
if Value < 0 then
Result := 1 + Value
else
if Value < 1 then
Result := 1 - Value
else
Result := 0;
end;
//------------------------------------------------------------------------------
function SplineFilter(Value: Extended): Extended;
var
tt: Extended;
begin
Value := Abs(Value);
if Value < 1 then
begin
tt := Sqr(Value);
Result := 0.5 * tt * Value - tt + 2 / 3;
end
else
if Value < 2 then
begin
Value := 2 - Value;
Result := 1 / 6 * Sqr(Value) * Value;
end
else
Result := 0;
end;
//------------------------------------------------------------------------------
function BuildMappingTable(
DstWidth, SrcFrom, SrcWidth: Integer;
StretchFilter: TStretchFilter): TMappingTable;
const
FILTERS: array [TStretchFilter] of TFilterFunc = (NearestFilter, LinearFilter,
SplineFilter);
var
Filter: TFilterFunc;
FilterWidth: Extended;
Scale, OldScale: Extended;
Center: Extended;
Bias: Extended;
Left, Right: Integer;
I, J, K: Integer;
Weight: Integer;
begin
if SrcWidth = 0 then
begin
Result := nil;
Exit;
end;
Filter := FILTERS[StretchFilter];
if StretchFilter in [sfNearest, sfLinear] then
FilterWidth := 1
else
FilterWidth := 1.5;
SetLength(Result, DstWidth);
Scale := (DstWidth - 1) / (SrcWidth - 1);
if Scale < 1 then
begin
OldScale := Scale;
Scale := 1 / Scale;
FilterWidth := FilterWidth * Scale;
for I := 0 to DstWidth - 1 do
begin
Center := I * Scale;
Left := Floor(Center - FilterWidth);
Right := Ceil(Center + FilterWidth);
Bias := 0;
for J := Left to Right do
begin
Weight := Round(255 * Filter((Center - J) * OldScale) * OldScale);
if Weight <> 0 then
begin
Bias := Bias + Weight / 255;
k := Length(Result[I]);
SetLength(Result[I], k + 1);
Result[I][k].Pos := Constrain(j + SrcFrom, 0, SrcWidth - 1);
Result[I][k].Weight := Weight;
end;
end;
if (Bias > 0) and (Bias <> 1) then
begin
Bias := 1 / Bias;
for k := 0 to High(Result[I]) do
Result[I][k].Weight := Round(Result[I][k].Weight * Bias);
end;
end;
end
else // scale > 1
begin
FilterWidth := 1 / FilterWidth;
Scale := 1 / Scale;
for I := 0 to DstWidth - 1 do
begin
Center := I * Scale;
Left := Floor(Center - FilterWidth);
Right := Ceil(Center + FilterWidth);
for j := Left to Right do
begin
Weight := Round(255 * Filter(Center - j));
if Weight <> 0 then
begin
k := Length(Result[I]);
SetLength(Result[I], k + 1);
Result[i][k].Pos := Constrain(j + SrcFrom, 0, SrcWidth - 1);
Result[i][k].Weight := Weight;
end;
end;
end;
end;
end;
//==============================================================================
// Bitmap Functions
//==============================================================================
// Scales the source bitmap to the given size (NewWidth, NewHeight) and stores the Result in Target.
// Filter describes the filter function to be applied and Radius the size of the filter area.
// Is Radius = 0 then the recommended filter area will be used (see DefaultFilterRadius).
procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter;
Radius: Single; Source, Target: TBitmap);
begin
if Radius = 0 then
Radius := DefaultFilterRadius[Filter];
Target.FreeImage;
Target.PixelFormat := pf24Bit;
Target.Width := NewWidth;
Target.Height := NewHeight;
Source.PixelFormat := pf24Bit;
DoStretch(FilterList[Filter], Radius, Source, Target);
end;
//------------------------------------------------------------------------------
procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter;
Radius: Single; Source: TBitmap);
var
Target: TBitmap;
begin
if Radius = 0 then
Radius := DefaultFilterRadius[Filter];
Target := TBitmap.Create;
try
Target.PixelFormat := pf24Bit;
Target.Width := NewWidth;
Target.Height := NewHeight;
Source.PixelFormat := pf24Bit;
DoStretch(FilterList[Filter], Radius, Source, Target);
Source.Assign(Target);
finally
Target.Free;
end;
end;
//------------------------------------------------------------------------------
procedure StretchNearest(Dst: TJclBitmap32; DstRect: TRect;
Src: TJclBitmap32; SrcRect: TRect; CombineOp: TDrawMode);
var
SrcW, SrcH, DstW, DstH: Integer;
MapX, MapY: array of Integer;
DstX, DstY: Integer;
R: TRect;
I, J, Y: Integer;
P: PColor32;
MstrAlpha: TColor32;
begin
// check source and destination
CheckBitmaps(Dst, Src);
if not CheckSrcRect(Src, SrcRect) then
Exit;
if IsRectEmpty(DstRect) then
Exit;
IntersectRect(R, DstRect, Rect(0, 0, Dst.Width, Dst.Height));
if IsRectEmpty(R) then
Exit;
if (CombineOp = dmBlend) and (Src.MasterAlpha = 0) then
Exit;
SrcW := SrcRect.Right - SrcRect.Left;
SrcH := SrcRect.Bottom - SrcRect.Top;
DstW := DstRect.Right - DstRect.Left;
DstH := DstRect.Bottom - DstRect.Top;
DstX := DstRect.Left;
DstY := DstRect.Top;
// check if we actually have to stretch anything
if (SrcW = DstW) and (SrcH = DstH) then
begin
BlockTransfer(Dst, DstX, DstY, Src, SrcRect, CombineOp);
Exit;
end;
// build X coord mapping table
SetLength(MapX, DstW);
SetLength(MapY, DstH);
try
for I := 0 to DstW - 1 do
MapX[I] := I * (SrcW) div (DstW) + SrcRect.Left;
// build Y coord mapping table
for J := 0 to DstH - 1 do
MapY[J] := J * (SrcH) div (DstH) + SrcRect.Top;
// transfer pixels
case CombineOp of
dmOpaque:
for J := R.Top to R.Bottom - 1 do
begin
Y := MapY[J - DstY];
P := Dst.PixelPtr[R.Left, J];
for I := R.Left to R.Right - 1 do
begin
P^ := Src[MapX[I - DstX], Y];
Inc(P);
end;
end;
dmBlend:
begin
MstrAlpha := Src.MasterAlpha;
if MstrAlpha = 255 then
for J := R.Top to R.Bottom - 1 do
begin
Y := MapY[J - DstY];
P := Dst.PixelPtr[R.Left, J];
for I := R.Left to R.Right - 1 do
begin
BlendMem(Src[MapX[I - DstX], Y], P^);
Inc(P);
end;
end
else // Master Alpha is in [1..254] range
for J := R.Top to R.Bottom - 1 do
begin
Y := MapY[J - DstY];
P := Dst.PixelPtr[R.Left, J];
for I := R.Left to R.Right - 1 do
begin
BlendMemEx(Src[MapX[I - DstX], Y], P^, MstrAlpha);
Inc(P);
end;
end;
end;
end;
finally
EMMS;
MapX := nil;
MapY := nil;
end;
end;
//------------------------------------------------------------------------------
procedure BlockTransfer(Dst: TJclBitmap32; DstX: Integer; DstY: Integer; Src: TJclBitmap32;
SrcRect: TRect; CombineOp: TDrawMode);
var
SrcX, SrcY: Integer;
S, D: TRect;
J, N: Integer;
Ps, Pd: PColor32;
MstrAlpha: TColor32;
begin
CheckBitmaps(Src, Dst);
if CombineOp = dmOpaque then
begin
BitBlt(Dst.Handle, DstX, DstY, SrcRect.Right - SrcRect.Left,
SrcRect.Bottom - SrcRect.Top, Src.Handle, SrcRect.Left, SrcRect.Top,
SRCCOPY);
Exit;
end;
if Src.MasterAlpha = 0 then
Exit;
// clip the rectangles with bitmap boundaries
SrcX := SrcRect.Left;
SrcY := SrcRect.Top;
IntersectRect(S, SrcRect, Rect(0, 0, Src.Width, Src.Height));
OffsetRect(S, DstX - SrcX, DstY - SrcY);
IntersectRect(D, S, Rect(0, 0, Dst.Width, Dst.Height));
if IsRectEmpty(D) then
Exit;
MstrAlpha := Src.MasterAlpha;
N := D.Right - D.Left;
try
if MstrAlpha = 255 then
for J := D.Top to D.Bottom - 1 do
begin
Ps := Src.PixelPtr[D.Left + SrcX - DstX, J + SrcY - DstY];
Pd := Dst.PixelPtr[D.Left, J];
BlendLine(Ps, Pd, N);
end
else
for J := D.Top to D.Bottom - 1 do
begin
Ps := Src.PixelPtr[D.Left + SrcX - DstX, J + SrcY - DstY];
Pd := Dst.PixelPtr[D.Left, J];
BlendLineEx(Ps, Pd, N, MstrAlpha);
end;
finally
EMMS;
end;
end;
//------------------------------------------------------------------------------
procedure StretchTransfer(Dst: TJclBitmap32; DstRect: TRect; Src: TJclBitmap32; SrcRect: TRect;
StretchFilter: TStretchFilter; CombineOp: TDrawMode);
var
SrcW, SrcH, DstW, DstH: Integer;
t: Single;
MapX, MapY: TMappingTable;
DstX, DstY: Integer;
R: TRect;
I, J, X, Y: Integer;
P: PColor32;
ClusterX, ClusterY: TCluster;
C, Wt, Cr, Cg, Cb, Ca: Integer;
MstrAlpha: TColor32;
begin
// make compiler happy
MapX := nil;
MapY := nil;
ClusterX := nil;
ClusterY := nil;
if StretchFilter = sfNearest then
begin
StretchNearest(Dst, DstRect, Src, SrcRect, CombineOp);
Exit;
end;
// check source and destination
CheckBitmaps(Dst, Src);
if not CheckSrcRect(Src, SrcRect) then
Exit;
if IsRectEmpty(DstRect) then
Exit;
IntersectRect(R, DstRect, Rect(0, 0, Dst.Width, Dst.Height));
if IsRectEmpty(R) then
Exit;
if (CombineOp = dmBlend) and (Src.MasterAlpha = 0) then
Exit;
SrcW := SrcRect.Right - SrcRect.Left;
SrcH := SrcRect.Bottom - SrcRect.Top;
DstW := DstRect.Right - DstRect.Left;
DstH := DstRect.Bottom - DstRect.Top;
DstX := DstRect.Left;
DstY := DstRect.Top;
MstrAlpha := Src.MasterAlpha;
// check if we actually have to stretch anything
if (SrcW = DstW) and (SrcH = DstH) then
begin
BlockTransfer(Dst, DstX, DstY, Src, SrcRect, CombineOp);
Exit;
end;
// mapping tables
MapX := BuildMappingTable(DstW, SrcRect.Left, SrcW, StretchFilter);
MapY := BuildMappingTable(DstH, SrcRect.Top, SrcH, StretchFilter);
try
ClusterX := nil; ClusterY := nil;
if (MapX = nil) or (MapY = nil) then
Exit;
// transfer pixels
for J := R.Top to R.Bottom - 1 do
begin
ClusterY := MapY[J - DstY];
P := Dst.PixelPtr[R.Left, J];
for I := R.Left to R.Right - 1 do
begin
ClusterX := MapX[I - DstX];
// reset color accumulators
Ca := 0; Cr := 0; Cg := 0; Cb := 0;
// now iterate through each cluster
for y := 0 to High(ClusterY) do
for x := 0 to High(ClusterX) do
begin
C := Src[ClusterX[x].Pos, ClusterY[y].Pos];
Wt := ClusterX[x].Weight * ClusterY[y].Weight;
Inc(Ca, C shr 24 * Wt);
Inc(Cr, (C and $00FF0000) shr 16 * Wt);
Inc(Cg, (C and $0000FF00) shr 8 * Wt);
Inc(Cb, (C and $000000FF) * Wt);
end;
Ca := Ca and $00FF0000;
Cr := Cr and $00FF0000;
Cg := Cg and $00FF0000;
Cb := Cb and $00FF0000;
C := (Ca shl 8) or Cr or (Cg shr 8) or (Cb shr 16);
// combine it with the background
case CombineOp of
dmOpaque:
P^ := C;
dmBlend:
BlendMemEx(C, P^, MstrAlpha);
end;
Inc(P);
end;
end;
finally
EMMS;
MapX := nil;
MapY := nil;
end;
end;
//------------------------------------------------------------------------------
procedure DrawBitmap(DC: HDC; Bitmap: HBitMap; X, Y, Width, Height: Integer);
var
MemDC: HDC;
OldBitmap: HBitmap;
begin
MemDC := CreateCompatibleDC(DC);
OldBitmap := SelectObject(MemDC, Bitmap);
BitBlt(DC, X, Y, Width, Height, MemDC, 0, 0, SRCCOPY);
SelectObject(MemDC, OldBitmap);
DeleteObject(MemDC);
end;
//------------------------------------------------------------------------------
function GetAntialiasedBitmap(const Bitmap: TBitmap): TBitmap;
type
TByteArray = array [0..MaxLongint - 1] of Byte;
PByteArray = ^TByteArray;
var
Antialias: TBitmap;
X, Y: Integer;
Line1, Line2, Line: PByteArray;
begin
Assert(Bitmap <> nil);
if Bitmap.PixelFormat <> pf24bit then
Bitmap.PixelFormat := pf24bit;
Antialias := TBitmap.Create;
with Bitmap do
begin
Antialias.PixelFormat := pf24bit;
Antialias.Width := Width div 2;
Antialias.Height := Height div 2;
for Y := 0 to Antialias.Height - 1 do
begin
Line1 := ScanLine[Y * 2];
Line2 := ScanLine[Y * 2 + 1];
Line := Antialias.ScanLine[Y];
for X := 0 to Antialias.Width - 1 do
begin
Line[X * 3] := (Integer(Line1[X * 6]) + Integer(Line2[X * 6]) +
Integer(Line1[X * 6 + 3]) + Integer(Line2[X * 6 + 3])) div 4;
Line[X * 3 + 1] := (Integer(Line1[X * 6 + 1]) + Integer(Line2[X * 6 + 1]) +
Integer(Line1[X * 6 + 3 + 1]) + Integer(Line2[X * 6 + 3 + 1])) div 4;
Line[X * 3 + 2] := (Integer(Line1[X * 6 + 2]) + Integer(Line2[X * 6 + 2]) +
Integer(Line1[X * 6 + 3 + 2]) + Integer(Line2[X * 6 + 3 + 2])) div 4;
end;
end;
end;
Result := Antialias;
end;
//------------------------------------------------------------------------------
{$IFDEF COMPILER4_UP}
procedure JPegToBitmap(const FileName: string);
var
Bitmap: TBitmap;
JPeg: TJPegImage;
begin
Bitmap := nil;
JPeg := nil;
try
JPeg := TJPegImage.Create;
JPeg.LoadFromFile(FileName);
Bitmap := TBitmap.Create;
Bitmap.Assign(JPeg);
Bitmap.SaveToFile(ChangeFileExt(FileName, RsBitmapExtension));
finally
FreeAndNil(Bitmap);
FreeAndNil(JPeg);
end;
end;
//------------------------------------------------------------------------------
procedure BitmapToJPeg(const FileName: string);
var
Bitmap: TBitmap;
JPeg: TJPegImage;
begin
Bitmap := nil;
JPeg := nil;
try
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile(FileName);
JPeg := TJPegImage.Create;
JPeg.Assign(Bitmap);
JPeg.SaveToFile(ChangeFileExt(FileName, RsJpegExtension));
finally
FreeAndNil(Bitmap);
FreeAndNil(JPeg);
end;
end;
{$ENDIF COMPILER4_UP}
//------------------------------------------------------------------------------
function ExtractIconCount(const FileName: string): Integer;
begin
Result := ExtractIcon(HInstance, PChar(FileName), $FFFFFFFF);
end;
//------------------------------------------------------------------------------
function BitmapToIcon(Bitmap: HBITMAP; cx, cy: Integer): HICON;
var
ImgList: HIMAGELIST;
I: Integer;
begin
ImgList := ImageList_Create(cx, cy, ILC_COLOR, 1, 1);
try
I := ImageList_Add(ImgList, Bitmap, 0);
Result := ImageList_GetIcon(ImgList, I, ILD_NORMAL);
finally
ImageList_Destroy(ImgList);
end;
end;
//------------------------------------------------------------------------------
function IconToBitmap(Icon: HICON): HBITMAP;
var
IconInfo: TIconInfo;
begin
GetIconInfo(Icon, IconInfo);
Result := IconInfo.hbmColor;
end;
//------------------------------------------------------------------------------
procedure Transform(Dst, Src: TJclBitmap32; SrcRect: TRect;
Transformation: TJclTransformation);
var
SrcBlend: Boolean;
C, SrcAlpha: TColor32;
R, DstRect: TRect;
Pixels: PColor32Array;
I, J, X, Y: Integer;
function GET_S256(X, Y: Integer; out C: TColor32): Boolean;
var
flrx, flry, celx, cely: LongWord;
C1, C2, C3, C4: TColor32;
P: PColor32;
begin
flrx := X and $FF;
flry := Y and $FF;
X := Sar(X,8);
Y := Sar(Y,8);
celx := flrx xor 255;
cely := flry xor 255;
if (X >= SrcRect.Left) and (X < SrcRect.Right - 1) and
(Y >= SrcRect.Top) and (Y < SrcRect.Bottom - 1) then
begin
// everything is ok take the four values and interpolate them
P := Src.PixelPtr[X, Y];
C1 := P^;
Inc(P);
C2 := P^;
Inc(P, Src.Width);
C4 := P^;
Dec(P);
C3 := P^;
C := CombineReg(CombineReg(C1, C2, celx), CombineReg(C3, C4, celx), cely);
Result := True;
end
else
begin
// (X,Y) coordinate is out of the SrcRect, do not interpolate
C := 0; // just write something to disable compilator warnings
Result := False;
end;
end;
begin
SrcBlend := (Src.DrawMode = dmBlend);
SrcAlpha := Src.MasterAlpha; // store it into a local variable
// clip SrcRect
R := SrcRect;
IntersectRect(SrcRect, R, Rect(0, 0, Src.Width, Src.Height));
if IsRectEmpty(SrcRect) then
Exit;
// clip DstRect
R := Transformation.GetTransformedBounds(SrcRect);
IntersectRect(DstRect, R, Rect(0, 0, Dst.Width, Dst.Height));
if IsRectEmpty(DstRect) then
Exit;
try
if Src.StretchFilter <> sfNearest then
for J := DstRect.Top to DstRect.Bottom - 1 do
begin
Pixels := Dst.ScanLine[J];
for I := DstRect.Left to DstRect.Right - 1 do
begin
Transformation.Transform256(I, J, X, Y);
if GET_S256(X, Y, C) then
if SrcBlend then
BlendMemEx(C, Pixels[I], SrcAlpha)
else
Pixels[I] := C;
end;
end
else // nearest filter
for J := DstRect.Top to DstRect.Bottom - 1 do
begin
Pixels := Dst.ScanLine[J];
for I := DstRect.Left to DstRect.Right - 1 do
begin
Transformation.Transform(I, J, X, Y);
if (X >= SrcRect.Left) and (X < SrcRect.Right) and
(Y >= SrcRect.Top) and (Y < SrcRect.Bottom) then
begin
if SrcBlend then
BlendMemEx(Src.Pixel[X, Y], Pixels[I], SrcAlpha)
else
Pixels[I] := Src.Pixel[X, Y];
end;
end;
end;
finally
EMMS;
end;
Dst.Changed;
end;
//------------------------------------------------------------------------------
procedure SetBorderTransparent(ABitmap: TJclBitmap32; ARect: TRect);
var
I: Integer;
begin
if TestClip(ARect.Left, ARect.Right, ABitmap.Width) and
TestClip(ARect.Top, ARect.Bottom, ABitmap.Height) then
begin
ABitmap.Changing;
for I := ARect.Left to ARect.Right do
ABitmap[I, ARect.Top] := ABitmap[I, ARect.Top] and $00FFFFFF;
for I := ARect.Left to ARect.Right do
ABitmap[I, ARect.Bottom] := ABitmap[I, ARect.Bottom] and $00FFFFFF;
if ARect.Bottom > ARect.Top + 1 then
for I := ARect.Top + 1 to ARect.Bottom - 1 do
begin
ABitmap[ARect.Left, I] := ABitmap[ARect.Left, I] and $00FFFFFF;
ABitmap[ARect.Right, I] := ABitmap[ARect.Right, I] and $00FFFFFF;
end;
ABitmap.Changed;
end;
end;
//------------------------------------------------------------------------------
function CreateRegionFromBitmap(Bitmap: TBitmap; RegionColor: TColor;
RegionBitmapMode: TJclRegionBitmapMode): HRGN;
var
FBitmap: TBitmap;
X, Y: Integer;
StartX: Integer;
Region: HRGN;
begin
Result := 0;
if Bitmap = nil then
EJclGraphicsError.CreateResRec(@RsNoBitmapForRegion);
if (Bitmap.Width = 0) or (Bitmap.Height = 0) then
Exit;
FBitmap := TBitmap.Create;
try
FBitmap.Assign(Bitmap);
for Y := 0 to FBitmap.Height - 1 do
begin
X := 0;
while X < FBitmap.Width do
begin
if RegionBitmapMode = rmExclude then
begin
while FBitmap.Canvas.Pixels[X,Y] = RegionColor do
begin
Inc(X);
if X = FBitmap.Width then
break;
end;
end
else
begin
while FBitmap.Canvas.Pixels[X,Y] <> RegionColor do
begin
Inc(X);
if X = FBitmap.Width then
break;
end;
end;
if X = FBitmap.Width then
break;
StartX := X;
if RegionBitmapMode = rmExclude then
begin
while FBitmap.Canvas.Pixels[X,Y] <> RegionColor do
begin
if X = FBitmap.Width then
break;
Inc(X);
end;
end
else
begin
while FBitmap.Canvas.Pixels[X,Y] = RegionColor do
begin
if X = FBitmap.Width then
break;
Inc(X);
end;
end;
if Result = 0 then
Result := CreateRectRgn(StartX, Y, X, Y + 1)
else
begin
Region := CreateRectRgn(StartX, Y, X, Y + 1);
if Region <> 0 then
begin
CombineRgn(Result, Result, Region, RGN_OR);
DeleteObject(Region);
end;
end;
end;
end;
finally
FBitmap.Free;
end;
end;
//------------------------------------------------------------------------------
procedure ScreenShot(bm: TBitmap; Left, Top, Width, Height: Integer; Window: HWND); overload;
var
WinDC: HDC;
Pal: TMaxLogPalette;
begin
bm.Width := Width;
bm.Height := Height;
// Get the HDC of the window...
WinDC := GetDC(Window);
if WinDC = 0 then
raise EJclGraphicsError.CreateResRec(@RsNoDeviceContextForWindow);
// Palette-device?
if (GetDeviceCaps(WinDC, RASTERCAPS) and RC_PALETTE) = RC_PALETTE then
begin
FillChar(Pal, SizeOf(TMaxLogPalette), #0); // fill the structure with zeros
Pal.palVersion := $300; // fill in the palette version
// grab the system palette entries...
Pal.palNumEntries := GetSystemPaletteEntries(WinDC, 0, 256, Pal.palPalEntry);
if Pal.PalNumEntries <> 0 then
bm.Palette := CreatePalette(PLogPalette(@Pal)^);
end;
// copy from the screen to our bitmap...
BitBlt(bm.Canvas.Handle, 0, 0, Width, Height, WinDC, Left, Top, SRCCOPY);
ReleaseDC(0, WinDC); // finally, relase the DC of the window
end;
//------------------------------------------------------------------------------
procedure ScreenShot(bm: TBitmap); overload;
begin
ScreenShot(bm, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN), 0);
end;
//------------------------------------------------------------------------------
function FillGradient(DC: HDC; ARect: TRect; ColorCount: Integer;
StartColor, EndColor: TColor; ADirection: TGradientDirection): Boolean;
var
StartRGB: array [0..2] of Byte;
RGBKoef: array [0..2] of Double;
Brush: HBRUSH;
AreaWidth, AreaHeight, I: Integer;
ColorRect: TRect;
RectOffset: Double;
begin
RectOffset := 0;
Result := False;
if ColorCount < 1 then
Exit;
StartColor := ColorToRGB(StartColor);
EndColor := ColorToRGB(EndColor);
StartRGB[0] := GetRValue(StartColor);
StartRGB[1] := GetGValue(StartColor);
StartRGB[2] := GetBValue(StartColor);
RGBKoef[0] := (GetRValue(EndColor) - StartRGB[0]) / ColorCount;
RGBKoef[1] := (GetGValue(EndColor) - StartRGB[1]) / ColorCount;
RGBKoef[2] := (GetBValue(EndColor) - StartRGB[2]) / ColorCount;
AreaWidth := ARect.Right - ARect.Left;
AreaHeight := ARect.Bottom - ARect.Top;
case ADirection of
gdHorizontal:
RectOffset := AreaWidth / ColorCount;
gdVertical:
RectOffset := AreaHeight / ColorCount;
end;
for I := 0 to ColorCount - 1 do
begin
Brush := CreateSolidBrush(RGB(
StartRGB[0] + Round((I + 1) * RGBKoef[0]),
StartRGB[1] + Round((I + 1) * RGBKoef[1]),
StartRGB[2] + Round((I + 1) * RGBKoef[2])));
case ADirection of
gdHorizontal:
SetRect(ColorRect, Round(RectOffset * I), 0, Round(RectOffset * (I + 1)), AreaHeight);
gdVertical:
SetRect(ColorRect, 0, Round(RectOffset * I), AreaWidth, Round(RectOffset * (I + 1)));
end;
OffsetRect(ColorRect, ARect.Left, ARect.Top);
FillRect(DC, ColorRect, Brush);
DeleteObject(Brush);
end;
Result := True;
end;
//==============================================================================
// TJclDesktopCanvas
//==============================================================================
constructor TJclDesktopCanvas.Create;
begin
inherited Create;
FDesktop := GetDC(0);
Handle := FDesktop;
end;
//------------------------------------------------------------------------------
destructor TJclDesktopCanvas.Destroy;
begin
Handle := 0;
ReleaseDC(0, FDesktop);
inherited Destroy;
end;
//==============================================================================
// TJclRegionInfo
//==============================================================================
constructor TJclRegionInfo.Create(Region: TJclRegion);
begin
inherited Create;
if Region = nil then
raise EJclGraphicsError.CreateResRec(@RsInvalidRegion);
FData := nil;
FDataSize := GetRegionData(Region.Handle, 0, nil);
GetMem(FData, FDataSize);
GetRegionData(Region.Handle, FDataSize, FData);
end;
//------------------------------------------------------------------------------
destructor TJclRegionInfo.Destroy;
begin
if FData <> nil then
FreeMem(FData);
inherited;
end;
//------------------------------------------------------------------------------
function TJclRegionInfo.GetBox: TRect;
begin
Result := RectAssign(TRgnData(FData^).rdh.rcBound.Left, TRgnData(FData^).rdh.rcBound.Top,
TRgnData(FData^).rdh.rcBound.Right, TRgnData(FData^).rdh.rcBound.Bottom);
end;
//------------------------------------------------------------------------------
function TJclRegionInfo.GetCount: Integer;
begin
Result := TRgnData(FData^).rdh.nCount;
end;
//------------------------------------------------------------------------------
function TJclRegionInfo.GetRect(Index: Integer): TRect;
var RectP: PRect;
begin
if (Index < 0) or (DWORD(Index) >= TRgnData(FData^).rdh.nCount) then
raise EJclGraphicsError.CreateResRec(@RsRegionDataOutOfBound);
RectP := PRect(PChar(@TRgnData(FData^).Buffer) + (SizeOf(TRect)*Index));
Result := RectAssign(RectP^.Left, RectP.Top, RectP^.Right, RectP^.Bottom);
end;
//==============================================================================
// TJclRegion
//==============================================================================
procedure TJclRegion.CheckHandle;
begin
if FHandle = 0 then
raise EJclWin32Error.CreateResRec(@RsRegionCouldNotCreated);
end;
//------------------------------------------------------------------------------
procedure TJclRegion.Combine(DestRegion, SrcRegion: TJclRegion;
CombineOp: TJclRegionCombineOperator);
begin
case CombineOp of
coAnd:
FRegionType := CombineRgn(DestRegion.Handle, SrcRegion.Handle, FHandle, RGN_AND);
coOr:
FRegionType := CombineRgn(DestRegion.Handle, SrcRegion.Handle, FHandle, RGN_OR);
coDiff:
FRegionType := CombineRgn(DestRegion.Handle, SrcRegion.Handle, FHandle, RGN_DIFF);
coXor:
FRegionType := CombineRgn(DestRegion.Handle, SrcRegion.Handle, FHandle, RGN_XOR);
end;
end;
//------------------------------------------------------------------------------
procedure TJclRegion.Combine(SrcRegion: TJclRegion; CombineOp: TJclRegionCombineOperator);
begin
case CombineOp of
coAnd:
FRegionType := CombineRgn(FHandle, SrcRegion.Handle, FHandle, RGN_AND);
coOr:
FRegionType := CombineRgn(FHandle, SrcRegion.Handle, FHandle, RGN_OR);
coDiff:
FRegionType := CombineRgn(FHandle, SrcRegion.Handle, FHandle, RGN_DIFF);
coXor:
FRegionType := CombineRgn(FHandle, SrcRegion.Handle, FHandle, RGN_XOR);
end;
end;
//------------------------------------------------------------------------------
procedure TJclRegion.Clip(Canvas: TCanvas);
begin
FRegionType := SelectClipRgn(Canvas.Handle, FHandle);
end;
//------------------------------------------------------------------------------
destructor TJclRegion.Destroy;
begin
if FHandle <> 0 then
DeleteObject(FHandle);
inherited;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.Create(RegionHandle: HRGN);
begin
inherited Create;
if FHandle = 0 then
raise EJclGraphicsError.CreateResRec(@RsInvalidHandleForRegion);
FHandle := RegionHandle;
GetBox;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreateBitmap(Bitmap: TBitmap; RegionColor: TColor;
RegionBitmapMode: TJclRegionBitmapMode);
begin
inherited Create;
FHandle := CreateRegionFromBitmap(Bitmap, RegionColor, RegionBitmapMode);
CheckHandle;
GetBox;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreateElliptic(const ARect: TRect);
begin
inherited Create;
FHandle := CreateEllipticRgnIndirect(ARect);
CheckHandle;
GetBox;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreateElliptic(Top, Left, Bottom, Right: Integer);
begin
inherited Create;
FHandle := CreateEllipticRgn(Top, Left, Bottom, Right);
CheckHandle;
GetBox;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreatePoly(const Points: TDynPointArray; Count: Integer;
FillMode: TPolyFillMode);
begin
inherited Create;
case FillMode of
fmAlternate:
FHandle := CreatePolygonRgn(Points, Count, ALTERNATE);
fmWinding:
FHandle := CreatePolygonRgn(Points, Count, WINDING);
end;
CheckHandle;
GetBox;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreatePolyPolygon(const Points: TDynPointArray;
const Vertex: TDynIntegerArray; Count: Integer; FillMode: TPolyFillMode);
begin
inherited Create;
case FillMode of
fmAlternate:
FHandle := CreatePolyPolygonRgn(Points, Vertex, Count, ALTERNATE);
fmWinding:
FHandle := CreatePolyPolygonRgn(Points, Vertex, Count, WINDING);
end;
CheckHandle;
GetBox;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreateRect(const Top, Left, Bottom, Right: Integer);
begin
inherited Create;
FHandle := CreateRectRgn(Top, Left, Bottom, Right);
CheckHandle;
GetBox;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreateRect(ARect: TRect);
begin
inherited Create;
FHandle := CreateRectRgnIndirect(ARect);
CheckHandle;
GetBox;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreateRoundRect(const ARect: TRect; CornerWidth,
CornerHeight: Integer);
begin
inherited Create;
FHandle := CreateRoundRectRgn(ARect.Top, ARect.Left, ARect.Bottom, ARect.Right,
CornerWidth, CornerHeight);
CheckHandle;
GetBox;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreateRoundRect(Top, Left, Bottom, Right, CornerWidth,
CornerHeight: Integer);
begin
inherited Create;
FHandle := CreateRoundRectRgn(Top, Left, Bottom, Right, CornerWidth, CornerHeight);
CheckHandle;
GetBox;
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreatePath(Canvas: TCanvas);
begin
inherited Create;
FHandle := PathToRegion(Canvas.Handle);
CheckHandle;
GetBox;
end;
//------------------------------------------------------------------------------
function TJclRegion.Equals(CompareRegion: TJclRegion): Boolean;
begin
Result := EqualRgn(CompareRegion.Handle, FHandle);
end;
//------------------------------------------------------------------------------
function TJclRegion.GetHandle: HRGN;
begin
Result := FHandle;
end;
//------------------------------------------------------------------------------
procedure TJclRegion.Fill(Canvas: TCanvas);
begin
FillRgn(Canvas.Handle, FHandle, Canvas.Brush.Handle);
end;
//------------------------------------------------------------------------------
procedure TJclRegion.FillGradient(Canvas: TCanvas; ColorCount: Integer;
StartColor, EndColor: TColor; ADirection: TGradientDirection);
begin
SelectClipRgn(Canvas.Handle,FHandle);
JclGraphics.FillGradient(Canvas.Handle, Box, ColorCount, StartColor, EndColor, ADirection);
end;
//------------------------------------------------------------------------------
procedure TJclRegion.Frame(Canvas: TCanvas; FrameWidth, FrameHeight: Integer);
begin
FrameRgn(Canvas.Handle, FHandle, Canvas.Brush.Handle, FrameWidth, FrameHeight);
end;
//------------------------------------------------------------------------------
function TJclRegion.GetBox: TRect;
begin
FRegionType := GetRgnBox(FHandle, FBoxRect);
Result := FBoxRect;
end;
//------------------------------------------------------------------------------
function TJclRegion.GetRegionType: TJclRegionKind;
begin
case FRegionType of
NULLREGION:
Result := rkNull;
SIMPLEREGION:
Result := rkSimple;
COMPLEXREGION:
Result := rkComplex;
else
Result := rkError;
end;
end;
//------------------------------------------------------------------------------
procedure TJclRegion.Invert(Canvas: TCanvas);
begin
InvertRgn(Canvas.Handle, FHandle);
end;
//------------------------------------------------------------------------------
procedure TJclRegion.Offset(X, Y: Integer);
begin
FRegionType := OffsetRgn(FHandle, X, Y);
end;
//------------------------------------------------------------------------------
procedure TJclRegion.Paint(Canvas: TCanvas);
begin
PaintRgn(Canvas.Handle, FHandle);
end;
//------------------------------------------------------------------------------
function TJclRegion.PointIn(X, Y: Integer): Boolean;
begin
Result := PtInRegion(FHandle, X, Y);
end;
//------------------------------------------------------------------------------
function TJclRegion.PointIn(const Point: TPoint): Boolean;
begin
Result := PtInRegion(FHandle, Point.X, Point.Y);
end;
//------------------------------------------------------------------------------
function TJclRegion.RectIn(const ARect: TRect): Boolean;
begin
Result := RectInRegion(FHandle, ARect);
end;
//------------------------------------------------------------------------------
function TJclRegion.RectIn(Top, Left, Bottom, Right: Integer): Boolean;
begin
Result := RectInRegion(FHandle, RectAssign(Left, Top, Right, Bottom));
end;
//------------------------------------------------------------------------------
procedure TJclRegion.SetWindow(Window: HWND; Redraw: Boolean);
begin
SetWindowRgn(Window, FHandle, Redraw);
end;
//------------------------------------------------------------------------------
function TJclRegion.Copy: TJclRegion;
begin
Result := TJclRegion.CreateRect(0,0,0,0);
CombineRgn(Result.Handle, FHandle, 0, RGN_COPY);
Result.GetBox;
end;
//------------------------------------------------------------------------------
function TJclRegion.GetRegionInfo: TJclRegionInfo;
begin
Result := TJclRegionInfo.Create(Self);
end;
//------------------------------------------------------------------------------
constructor TJclRegion.CreateRegionInfo(RegionInfo: TJclRegionInfo);
begin
inherited Create;
if RegionInfo = nil then
raise EJclGraphicsError.CreateResRec(@RsInvalidRegionInfo);
FHandle := ExtCreateRegion(nil,RegionInfo.FDataSize,TRgnData(RegionInfo.FData^));
CheckHandle;
GetBox;
end;
//==============================================================================
// TJclThreadPersistent
//==============================================================================
constructor TJclThreadPersistent.Create;
begin
FLock := TJclCriticalSection.Create;
end;
//------------------------------------------------------------------------------
destructor TJclThreadPersistent.Destroy;
begin
FLock.Free;
inherited;
end;
//------------------------------------------------------------------------------
procedure TJclThreadPersistent.BeginUpdate;
begin
Inc(FUpdateCount);
end;
//------------------------------------------------------------------------------
procedure TJclThreadPersistent.Changing;
begin
if (FUpdateCount = 0) and Assigned(FOnChanging) then
FOnChanging(Self);
end;
//------------------------------------------------------------------------------
procedure TJclThreadPersistent.Changed;
begin
if (FUpdateCount = 0) and Assigned(FOnChange) then
FOnChange(Self);
end;
//------------------------------------------------------------------------------
procedure TJclThreadPersistent.EndUpdate;
begin
Assert(FUpdateCount > 0, RsAssertUnpairedEndUpdate);
Dec(FUpdateCount);
end;
//------------------------------------------------------------------------------
procedure TJclThreadPersistent.Lock;
begin
LockedInc(FLockCount);
FLock.Enter;
end;
//------------------------------------------------------------------------------
procedure TJclThreadPersistent.Unlock;
begin
FLock.Leave;
LockedDec(FLockCount);
end;
//==============================================================================
// TJclCustomMap
//==============================================================================
procedure TJclCustomMap.Delete;
begin
SetSize(0, 0);
end;
//------------------------------------------------------------------------------
function TJclCustomMap.Empty: Boolean;
begin
Result := (Width = 0) or (Height = 0);
end;
//------------------------------------------------------------------------------
procedure TJclCustomMap.SetHeight(NewHeight: Integer);
begin
SetSize(Width, NewHeight);
end;
//------------------------------------------------------------------------------
procedure TJclCustomMap.SetSize(NewWidth, NewHeight: Integer);
begin
FWidth := NewWidth;
FHeight := NewHeight;
end;
//------------------------------------------------------------------------------
procedure TJclCustomMap.SetSize(Source: TPersistent);
begin
if Source is TJclCustomMap then
SetSize(TJclCustomMap(Source).Width, TJclCustomMap(Source).Height)
else
if Source is TGraphic then
SetSize(TGraphic(Source).Width, TGraphic(Source).Height)
else
if Source is TControl then
SetSize(TControl(Source).Width, TControl(Source).Height)
else
if Source = nil then
SetSize(0, 0)
else
raise EJclGraphicsError.CreateResRecFmt(@RsMapSizeFmt,[Source.ClassName]);
end;
//------------------------------------------------------------------------------
procedure TJclCustomMap.SetWidth(NewWidth: Integer);
begin
SetSize(NewWidth, Height);
end;
//==============================================================================
// TJclBitmap32
//==============================================================================
constructor TJclBitmap32.Create;
begin
inherited;
FillChar(FBitmapInfo, SizeOf(TBitmapInfo), #0);
with FBitmapInfo.bmiHeader do
begin
biSize := SizeOf(TBitmapInfoHeader);
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
end;
FOuterColor := $00000000; // by default as full transparency black
FFont := TFont.Create;
FFont.OnChange := FontChanged;
FFont.OwnerCriticalSection := @FLock;
FMasterAlpha := $FF;
FPenColor := clWhite32;
FStippleStep := 1;
end;
//------------------------------------------------------------------------------
destructor TJclBitmap32.Destroy;
begin
Lock;
try
FFont.Free;
SetSize(0, 0);
finally
Unlock;
end;
inherited;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetSize(NewWidth, NewHeight: Integer);
begin
if NewWidth <= 0 then
NewWidth := 0;
if NewHeight <= 0 then
NewHeight := 0;
if (NewWidth = Width) and (NewHeight = Height) then
Exit;
Changing;
try
if FHDC <> 0 then
DeleteDC(FHDC);
if FHandle <> 0 then
DeleteObject(FHandle);
FBits := nil;
FWidth := 0;
FHeight := 0;
if (NewWidth > 0) and (NewHeight > 0) then
begin
with FBitmapInfo.bmiHeader do
begin
biWidth := NewWidth;
biHeight := -NewHeight;
end;
FHandle := CreateDIBSection(0, FBitmapInfo, DIB_RGB_COLORS, Pointer(FBits), 0, 0);
if FBits = nil then
raise EJclGraphicsError.CreateResRec(@RsDibHandleAllocation);
FHDC := CreateCompatibleDC(0);
if FHDC = 0 then
begin
DeleteObject(FHandle);
FHandle := 0;
FBits := nil;
raise EJclGraphicsError.CreateResRec(@RsCreateCompatibleDc);
end;
if SelectObject(FHDC, FHandle) = 0 then
begin
DeleteDC(FHDC);
DeleteObject(FHandle);
FHDC := 0;
FHandle := 0;
FBits := nil;
raise EJclGraphicsError.CreateResRec(@RsSelectObjectInDc);
end;
FWidth := NewWidth;
FHeight := NewHeight;
end;
finally
Changed;
end;
end;
//------------------------------------------------------------------------------
function TJclBitmap32.Empty: Boolean;
begin
Result := (FHandle = 0);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.Clear;
begin
Clear(clBlack32);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.Clear(FillColor: TColor32);
begin
if Empty then
Exit;
Changing;
FillLongword(Bits[0], Width * Height, FillColor);
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.Delete;
begin
Changing;
SetSize(0, 0);
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.Assign(Source: TPersistent);
var
Canvas: TCanvas;
Picture: TPicture;
procedure AssignFromBitmap(SrcBmp: TBitmap);
begin
SetSize(SrcBmp.Width, SrcBmp.Height);
if Empty then
Exit;
BitBlt(Handle, 0, 0, Width, Height, SrcBmp.Canvas.Handle, 0, 0, SRCCOPY);
ResetAlpha;
end;
begin
Changing;
BeginUpdate;
try
if Source = nil then
begin
SetSize(0, 0);
Exit;
end
else
if Source is TJclBitmap32 then
begin
SetSize(TJclBitmap32(Source).Width, TJclBitmap32(Source).Height);
Move(TJclBitmap32(Source).Bits[0], Bits[0], Width * Height * 4);
Exit;
end
else
if Source is TBitmap then
begin
AssignFromBitmap(TBitmap(Source));
Exit;
end
else
if Source is TPicture then
begin
with TPicture(Source) do
begin
if TPicture(Source).Graphic is TBitmap then
AssignFromBitmap(TBitmap(TPicture(Source).Graphic))
else
begin
// icons, metafiles etc...
SetSize(TPicture(Source).Graphic.Width, TPicture(Source).Graphic.Height);
if Empty then
Exit;
Canvas := TCanvas.Create;
try
Canvas.Handle := Self.Handle;
TJclGraphicAccess(Graphic).Draw(Canvas, Rect(0, 0, Width, Height));
ResetAlpha;
finally
Canvas.Free;
end;
end;
end;
Exit;
end
else
if Source is TClipboard then
begin
Picture := TPicture.Create;
try
Picture.Assign(TClipboard(Source));
SetSize(Picture.Width, Picture.Height);
if Empty then
Exit;
Canvas := TCanvas.Create;
try
Canvas.Handle := Self.Handle;
TJclGraphicAccess(Picture.Graphic).Draw(Canvas, Rect(0, 0, Width, Height));
ResetAlpha;
finally
Canvas.Free;
end;
finally
Picture.Free;
end;
Exit;
end
else
inherited; // default handler
finally;
EndUpdate;
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.AssignTo(Dst: TPersistent);
var
Bmp: TBitmap;
begin
if Dst is TPicture then
begin
Bmp := TPicture(Dst).Bitmap;
Bmp.HandleType := bmDIB;
Bmp.PixelFormat := pf32Bit;
Bmp.Width := Width;
Bmp.Height := Height;
DrawTo(Bmp.Canvas.Handle, 0, 0);
end
else
if Dst is TBitmap then
begin
Bmp := TBitmap(Dst);
Bmp.HandleType := bmDIB;
Bmp.PixelFormat := pf32Bit;
Bmp.Width := Width;
Bmp.Height := Height;
DrawTo(Bmp.Canvas.Handle, 0, 0);
end
else
if Dst is TClipboard then
begin
Bmp := TBitmap.Create;
try
Bmp.HandleType := bmDIB;
Bmp.PixelFormat := pf32Bit;
Bmp.Width := Width;
Bmp.Height := Height;
DrawTo(Bmp.Canvas.Handle, 0, 0);
TClipboard(Dst).Assign(Bmp);
finally
Bmp.Free;
end;
end
else
inherited;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetPixel(X, Y: Integer; Value: TColor32);
begin
Bits[X + Y * Width] := Value;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetPixelS(X, Y: Integer; Value: TColor32);
begin
if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then
Bits[X + Y * Width] := Value;
end;
//------------------------------------------------------------------------------
function TJclBitmap32.GetScanLine(Y: Integer): PColor32Array;
begin
Result := @Bits[Y * FWidth];
end;
//------------------------------------------------------------------------------
function TJclBitmap32.GetPixel(X, Y: Integer): TColor32;
begin
Result := Bits[X + Y * Width];
end;
//------------------------------------------------------------------------------
function TJclBitmap32.GetPixelS(X, Y: Integer): TColor32;
begin
if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Height) then
Result := Bits[X + Y * Width]
else
Result := OuterColor;
end;
//------------------------------------------------------------------------------
function TJclBitmap32.GetPixelPtr(X, Y: Integer): PColor32;
begin
Result := @Bits[X + Y * Width];
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.Draw(DstX, DstY: Integer; Src: TJclBitmap32);
begin
Changing;
if Src <> nil then
Src.DrawTo(Self, DstX, DstY);
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.Draw(DstRect, SrcRect: TRect; Src: TJclBitmap32);
begin
Changing;
if Src <> nil then
Src.DrawTo(Self, DstRect, SrcRect);
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.Draw(DstRect, SrcRect: TRect; hSrc: HDC);
begin
if Empty then
Exit;
Changing;
StretchBlt(Handle, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
DstRect.Bottom - DstRect.Top, hSrc, SrcRect.Left, SrcRect.Top,
SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, SRCCOPY);
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawTo(Dst: TJclBitmap32);
begin
if Empty or Dst.Empty then
Exit;
Dst.Changing;
BlockTransfer(Dst, 0, 0, Self, Rect(0, 0, Width, Height), DrawMode);
Dst.Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawTo(Dst: TJclBitmap32; DstX, DstY: Integer);
begin
if Empty or Dst.Empty then
Exit;
Dst.Changing;
BlockTransfer(Dst, DstX, DstY, Self, Rect(0, 0, Width, Height), DrawMode);
Dst.Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawTo(Dst: TJclBitmap32; DstRect: TRect);
begin
if Empty or Dst.Empty then
Exit;
Dst.Changing;
StretchTransfer(Dst, DstRect, Self, Rect(0, 0, Width, Height), StretchFilter, DrawMode);
Dst.Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawTo(Dst: TJclBitmap32; DstRect, SrcRect: TRect);
begin
if Empty or Dst.Empty then
Exit;
Dst.Changing;
StretchTransfer(Dst, DstRect, Self, SrcRect, StretchFilter, DrawMode);
Dst.Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawTo(hDst: HDC; DstX, DstY: Integer);
begin
if Empty then
Exit;
BitBlt(hDst, DstX, DstY, Width, Height, Handle, 0, 0, SRCCOPY);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawTo(hDst: HDC; DstRect, SrcRect: TRect);
begin
if Empty then
Exit;
StretchDIBits(hDst,
DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top,
SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top,
Bits, FBitmapInfo, DIB_RGB_COLORS, SRCCOPY);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.ResetAlpha;
var
I: Integer;
P: PByte;
begin
Changing;
P := Pointer(FBits);
Inc(P, 3);
for I := 0 to Width * Height - 1 do
begin
P^ := $FF;
Inc(P, 4)
end;
Changed;
end;
//------------------------------------------------------------------------------
function TJclBitmap32.GetPixelB(X, Y: Integer): TColor32;
begin
// this function should never be used on empty bitmaps !!!
if X < 0 then
X := 0
else
if X >= Width then
X := Width - 1;
if Y < 0 then
Y := 0
else
if Y >= Height then
Y := Height - 1;
Result := Bits[X + Y * Width];
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetPixelT(X, Y: Integer; Value: TColor32);
begin
BlendMem(Value, Bits[X + Y * Width]);
EMMS;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetPixelT(var Ptr: PColor32; Value: TColor32);
begin
BlendMem(Value, Ptr^);
EMMS;
Inc(Ptr);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetPixelTS(X, Y: Integer; Value: TColor32);
begin
if (X >= 0) and (X < Width) and (Y >= 0) and (Y < Width) then
begin
BlendMem(Value, Bits[X + Y * Width]);
EMMS;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SET_T256(X, Y: Integer; C: TColor32);
var
flrx, flry, celx, cely: LongWord;
P: PColor32;
A: TColor32;
begin
A := C shr 24; // opacity
flrx := X and $FF;
flry := Y and $FF;
X := Sar(X,8);
Y := Sar(Y,8);
celx := A * GAMMA_TABLE[flrx xor 255];
cely := GAMMA_TABLE[flry xor 255];
flrx := A * GAMMA_TABLE[flrx];
flry := GAMMA_TABLE[flry];
P := @FBits[X + Y * FWidth];
CombineMem(C, P^, celx * cely shr 16);
Inc(P);
CombineMem(C, P^, flrx * cely shr 16);
Inc(P, FWidth);
CombineMem(C, P^, flrx * flry shr 16);
Dec(P);
CombineMem(C, P^, celx * flry shr 16);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SET_TS256(X, Y: Integer; C: TColor32);
var
flrx, flry, celx, cely: LongWord;
P: PColor32;
A: TColor32;
begin
if (X < -256) or (Y < -256) then
Exit;
flrx := X and $FF;
flry := Y and $FF;
X := Sar(X,8);
Y := Sar(Y,8);
if (X >= FWidth) or (Y >= FHeight) then
Exit;
A := C shr 24; // opacity
celx := A * GAMMA_TABLE[flrx xor 255];
cely := GAMMA_TABLE[flry xor 255];
flrx := A * GAMMA_TABLE[flrx];
flry := GAMMA_TABLE[flry];
P := @FBits[X + Y * FWidth];
if (X >= 0) and (Y >= 0) and (X < FWidth - 1) and (Height < FHeight - 1) then
begin
CombineMem(C, P^, celx * cely shr 16);
Inc(P);
CombineMem(C, P^, flrx * cely shr 16);
Inc(P, FWidth);
CombineMem(C, P^, flrx * flry shr 16);
Dec(P);
CombineMem(C, P^, celx * flry shr 16);
end
else
begin
if (X >= 0) and (Y >= 0) then
CombineMem(C, P^, celx * cely shr 16);
Inc(P);
if (X < FWidth - 1) and (Y >= 0) then
CombineMem(C, P^, flrx * cely shr 16);
Inc(P, FWidth);
if (X < FWidth - 1) and (Y < FHeight - 1) then
CombineMem(C, P^, flrx * flry shr 16);
Dec(P);
if (X >= 0) and (Y < FHeight - 1) then
CombineMem(C, P^, celx * flry shr 16);
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetPixelF(X, Y: Single; Value: TColor32);
begin
SET_T256(Round(X * 256), Round(Y * 256), Value);
EMMS;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetPixelFS(X, Y: Single; Value: TColor32);
begin
SET_TS256(Round(X * 256), Round(Y * 256), Value);
EMMS;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetStipple(NewStipple: TArrayOfColor32);
begin
FStippleCounter := 0;
FStipplePattern := Copy(NewStipple, 0, Length(NewStipple));
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetStipple(NewStipple: array of TColor32);
var
L: Integer;
begin
FStippleCounter := 0;
L := High(NewStipple) - Low(NewStipple) + 1;
SetLength(FStipplePattern, L);
Move(NewStipple[Low(NewStipple)], FStipplePattern[0], L * SizeOf(TColor32));
end;
//------------------------------------------------------------------------------
function TJclBitmap32.GetStippleColor: TColor32;
var
L: Integer;
NextIndex, PrevIndex: Integer;
PrevWeight: Integer;
begin
L := Length(FStipplePattern);
if L = 0 then
begin
// no pattern defined, just return something and exit
Result := clBlack32;
Exit;
end;
while FStippleCounter >= L do
FStippleCounter := FStippleCounter - L;
while FStippleCounter < 0 do
FStippleCounter := FStippleCounter + L;
PrevIndex := Round(FStippleCounter - 0.5);
PrevWeight := 255 - Round(255 * (FStippleCounter - PrevIndex));
if PrevIndex < 0 then
FStippleCounter := L - 1;
NextIndex := PrevIndex + 1;
if NextIndex >= L then
NextIndex := 0;
if PrevWeight = 255 then
Result := FStipplePattern[PrevIndex]
else
begin
Result := CombineReg(
FStipplePattern[PrevIndex],
FStipplePattern[NextIndex],
PrevWeight);
EMMS;
end;
FStippleCounter := FStippleCounter + FStippleStep;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetStippleStep(Value: Single);
begin
FStippleStep := Value;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.ResetStippleCounter;
begin
FStippleCounter := 0;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawHorzLine(X1, Y, X2: Integer; Value: TColor32);
begin
FillLongword(Bits[X1 + Y * Width], X2 - X1 + 1, Value);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawHorzLineS(X1, Y, X2: Integer; Value: TColor32);
begin
if (Y >= 0) and (Y < Height) and TestClip(X1, X2, Width) then
DrawHorzLine(X1, Y, X2, Value);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawHorzLineT(X1, Y, X2: Integer; Value: TColor32);
var
i: Integer;
P: PColor32;
begin
if X2 < X1 then
Exit;
P := PixelPtr[X1, Y];
for i := X1 to X2 do
begin
BlendMem(Value, P^);
Inc(P);
end;
EMMS;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawHorzLineTS(X1, Y, X2: Integer; Value: TColor32);
begin
if (Y >= 0) and (Y < Height) and TestClip(X1, X2, Width) then
DrawHorzLineT(X1, Y, X2, Value);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawHorzLineTSP(X1, Y, X2: Integer);
var
I: Integer;
begin
if Empty then
Exit;
if (Y >= 0) and (Y < Height) then
begin
if ((X1 < 0) and (X2 < 0)) or ((X1 >= Width) and (X2 >= Width)) then
Exit;
if X1 < 0 then
X1 := 0
else
if X1 >= Width then
X1 := Width - 1;
if X2 < 0 then
X2 := 0
else
if X2 >= Width then
X2 := Width - 1;
if X2 >= X1 then
for I := X1 to X2 do
SetPixelT(I, Y, GetStippleColor)
else
for I := X2 downto X1 do
SetPixelT(I, Y, GetStippleColor);
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawVertLine(X, Y1, Y2: Integer; Value: TColor32);
var
i: Integer;
P: PColor32;
begin
if Y2 < Y1 then
Exit;
P := PixelPtr[X, Y1];
for i := 0 to Y2 - Y1 do
begin
P^ := Value;
Inc(P, Width);
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawVertLineS(X, Y1, Y2: Integer; Value: TColor32);
begin
if (X >= 0) and (X < Width) and TestClip(Y1, Y2, Height) then
DrawVertLine(X, Y1, Y2, Value);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawVertLineT(X, Y1, Y2: Integer; Value: TColor32);
var
i: Integer;
P: PColor32;
begin
P := PixelPtr[X, Y1];
for i := Y1 to Y2 do
begin
BlendMem(Value, P^);
Inc(P, Width);
end;
EMMS;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawVertLineTS(X, Y1, Y2: Integer; Value: TColor32);
begin
if (X >= 0) and (X < Width) and TestClip(Y1, Y2, Height) then
DrawVertLineT(X, Y1, Y2, Value);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawVertLineTSP(X, Y1, Y2: Integer);
var
I: Integer;
begin
if Empty then
Exit;
if (X >= 0) and (X < Width) then
begin
if ((Y1 < 0) and (Y2 < 0)) or ((Y1 >= Height) and (Y2 >= Height)) then
Exit;
if Y1 < 0 then
Y1 := 0
else
if Y1 >= Height then
Y1 := Height - 1;
if Y2 < 0 then
Y2 := 0
else
if Y2 >= Height then
Y2 := Height - 1;
if Y2 >= Y1 then
for I := Y1 to Y2 do
SetPixelT(X, I, GetStippleColor)
else
for I := Y2 downto Y1 do
SetPixelT(X, I, GetStippleColor);
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawLine(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
var
Dy, Dx, Sy, Sx, I, Delta: Integer;
P: PColor32;
begin
Changing;
try
Dx := X2 - X1;
Dy := Y2 - Y1;
if Dx > 0 then
Sx := 1
else
if Dx < 0 then
begin
Dx := -Dx;
Sx := -1;
end
else // Dx = 0
begin
if Dy > 0 then
DrawVertLine(X1, Y1, Y2 - 1, Value)
else
if Dy < 0 then
DrawVertLine(X1, Y2, Y1 - 1, Value);
if L then
Pixel[X2, Y2] := Value;
Exit;
end;
if Dy > 0 then
Sy := 1
else
if Dy < 0 then
begin
Dy := -Dy;
Sy := -1;
end
else // Dy = 0
begin
if Dx > 0 then
DrawHorzLine(X1, Y1, X2 - 1, Value)
else
DrawHorzLine(X2, Y1, X1 - 1, Value);
if L then
Pixel[X2, Y2] := Value;
Exit;
end;
P := PixelPtr[X1, Y1];
Sy := Sy * Width;
if Dx > Dy then
begin
Delta := Dx shr 1;
for I := 0 to Dx - 1 do
begin
P^ := Value;
Inc(P, Sx);
Delta := Delta + Dy;
if Delta > Dx then
begin
Inc(P, Sy);
Delta := Delta - Dx;
end;
end;
end
else // Dx < Dy
begin
Delta := Dy shr 1;
for I := 0 to Dy - 1 do
begin
P^ := Value;
Inc(P, Sy);
Delta := Delta + Dx;
if Delta > Dy then
begin
Inc(P, Sx);
Delta := Delta - Dy;
end;
end;
end;
if L then
P^ := Value;
finally
Changed;
end;
end;
//------------------------------------------------------------------------------
function TJclBitmap32.ClipLine(var X0, Y0, X1, Y1: Integer): Boolean;
type
Edge = (Left, Right, Top, Bottom);
OutCode = set of Edge;
var
Accept, AllDone: Boolean;
OutCode0, OutCode1, OutCodeOut: OutCode;
X, Y: Integer;
procedure CompOutCode(X, Y: Integer; var Code: OutCode);
begin
Code := [];
if X < 0 then
Code := Code + [Left];
if X >= Width then
Code := Code + [Right];
if Y < 0 then
Code := Code + [Top];
if Y >= Height then
Code := Code + [Bottom];
end;
begin
Accept := False;
AllDone := False;
CompOutCode(X0, Y0, OutCode0);
CompOutCode(X1, Y1, OutCode1);
repeat
if (OutCode0 = []) and (OutCode1 = []) then // trivial accept and exit
begin
Accept := True;
AllDone := True;
end
else
if (OutCode0 * OutCode1) <> [] then
AllDone := True // trivial reject
else // calculate intersections
begin
if OutCode0 <> [] then
OutCodeOut := OutCode0
else
OutCodeOut := OutCode1;
X := 0;
Y := 0;
if Left in OutCodeOut then
Y := Y0 + (Y1 - Y0) * (-X0) div (X1 - X0)
else
if Right in OutCodeOut then
begin
Y := Y0 + (Y1 - Y0) * (Width - 1 - X0) div (X1 - X0);
X := Width - 1;
end
else
if Top in OutCodeOut then
X := X0 + (X1 - X0) * (-Y0) div (Y1 - Y0)
else
if Bottom in OutCodeOut then
begin
X := X0 + (X1 - X0) * (Height - 1 - Y0) div (Y1 - Y0);
Y := Height - 1;
end;
if OutCodeOut = OutCode0 then
begin
X0 := X;
Y0 := Y;
CompOutCode(X0, Y0, OutCode0);
end
else
begin
X1 := X;
Y1 := Y;
CompOutCode(X1, Y1, OutCode1);
end;
end;
until AllDone;
Result := Accept;
end;
//------------------------------------------------------------------------------
function TJclBitmap32.ClipLineF(var X0, Y0, X1, Y1: Single;
MinX, MaxX, MinY, MaxY: Single): Boolean;
type
Edge = (Left, Right, Top, Bottom);
OutCode = set of Edge;
var
Accept, AllDone: Boolean;
OutCode0, OutCode1, OutCodeOut: OutCode;
X, Y: Single;
procedure CompOutCode(X, Y: Single; var Code: OutCode);
begin
Code := [];
if X < MinX then
Code := Code + [Left];
if X > MaxX then
Code := Code + [Right];
if Y < MinY then
Code := Code + [Top];
if Y > MaxY then
Code := Code + [Bottom];
end;
begin
Accept := False;
AllDone := False;
CompOutCode(X0, Y0, OutCode0);
CompOutCode(X1, Y1, OutCode1);
repeat
if (OutCode0 = []) and (OutCode1 = []) then // trivial accept and exit
begin
Accept := True;
AllDone := True;
end
else
if (OutCode0 * OutCode1) <> [] then
AllDone := True // trivial reject
else // calculate intersections
begin
if OutCode0 <> [] then
OutCodeOut := OutCode0
else
OutCodeOut := OutCode1;
X := 0;
Y := 0;
if Left in OutCodeOut then
begin
Y := Y0 + (Y1 - Y0) * (MinX - X0) / (X1 - X0);
X := MinX;
end
else
if Right in OutCodeOut then
begin
Y := Y0 + (Y1 - Y0) * (MaxX - X0) / (X1 - X0);
X := MaxX - 1;
end
else
if Top in OutCodeOut then
begin
X := X0 + (X1 - X0) * (MinY - Y0) / (Y1 - Y0);
Y := MinY;
end
else
if Bottom in OutCodeOut then
begin
X := X0 + (X1 - X0) * (MaxY - Y0) / (Y1 - Y0);
Y := MaxY;
end;
if OutCodeOut = OutCode0 then
begin
X0 := X;
Y0 := Y;
CompOutCode(X0, Y0, OutCode0);
end
else
begin
X1 := X;
Y1 := Y;
CompOutCode(X1, Y1, OutCode1);
end;
end;
until AllDone;
Result := Accept;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawLineS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
begin
if ClipLine(X1, Y1, X2, Y2) then
DrawLine(X1, Y1, X2, Y2, Value, L);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawLineT(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
var
Dy, Dx, Sy, Sx, I, Delta: Integer;
P: PColor32;
begin
Changing;
try
Dx := X2 - X1;
Dy := Y2 - Y1;
if Dx > 0 then
Sx := 1
else
if Dx < 0 then
begin
Dx := -Dx;
Sx := -1;
end
else // Dx = 0
begin
if Dy > 0 then
DrawVertLineT(X1, Y1, Y2 - 1, Value)
else
if Dy < 0 then
DrawVertLineT(X1, Y2, Y1 - 1, Value);
if L then
SetPixelT(X2, Y2, Value);
Exit;
end;
if Dy > 0 then
Sy := 1
else
if Dy < 0 then
begin
Dy := -Dy;
Sy := -1;
end
else // Dy = 0
begin
if Dx > 0 then
DrawHorzLineT(X1, Y1, X2 - 1, Value)
else
DrawHorzLineT(X2, Y1, X1 - 1, Value);
if L then
SetPixelT(X2, Y2, Value);
Exit;
end;
P := PixelPtr[X1, Y1];
Sy := Sy * Width;
try
if Dx > Dy then
begin
Delta := Dx shr 1;
for I := 0 to Dx - 1 do
begin
BlendMem(Value, P^);
Inc(P, Sx);
Delta := Delta + Dy;
if Delta > Dx then
begin
Inc(P, Sy);
Delta := Delta - Dx;
end;
end;
end
else // Dx < Dy
begin
Delta := Dy shr 1;
for I := 0 to Dy - 1 do
begin
BlendMem(Value, P^);
Inc(P, Sy);
Delta := Delta + Dx;
if Delta > Dy then
begin
Inc(P, Sx);
Delta := Delta - Dy;
end;
end;
end;
if L then
BlendMem(Value, P^);
finally
EMMS;
end;
finally
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawLineTS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
begin
if ClipLine(X1, Y1, X2, Y2) then
DrawLineT(X1, Y1, X2, Y2, Value, L);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawLineF(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean);
var
n, i: Integer;
px, py, ex, ey, nx, ny, hyp: Integer;
A: TColor32;
begin
Changing;
try
px := Round(x1 * 65536); py := Round(y1 * 65536);
ex := Round(x2 * 65536); ey := Round(y2 * 65536);
nx := ex - px; ny := ey - py;
hyp := Round(Hypot(nx, ny));
if L then
Inc(hyp, 65536);
if hyp < 256 then
Exit;
n := hyp shr 16;
if n > 0 then
begin
nx := Round(nx / hyp * 65536); ny := Round(ny / hyp * 65536);
for i := 0 to n - 1 do
begin
SET_T256(px shr 8, py shr 8, Value);
px := px + nx;
py := py + ny;
end;
end;
A := Value shr 24;
hyp := hyp - n shl 16;
A := A * LongWord(hyp) shl 8 and $FF000000;
SET_T256((px + ex - nx) shr 9, (py + ey - ny) shr 9, Value and _RGB + A);
finally
EMMS;
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawLineFS(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean);
var
n, i: Integer;
px, py, ex, ey, nx, ny, hyp: Integer;
A: TColor32;
begin
if ClipLineF(X1, Y1, X2, Y2, 0, FWidth, 0, FHeight) then
if (X1 < FWidth - 1) and (X2 < FWidth - 1) and
(Y1 < FHeight - 1) and (Y2 < FHeight - 1) then
DrawLineF(X1, Y1, X2, Y2, Value, False)
else // check every pixel
begin
Changing;
try
px := Round(x1 * 65536); py := Round(y1 * 65536);
ex := Round(x2 * 65536); ey := Round(y2 * 65536);
nx := ex - px; ny := ey - py;
hyp := Round(Hypot(nx, ny));
if L then
Inc(Hyp, 65536);
if hyp < 256 then
Exit;
n := hyp shr 16;
if n > 0 then
begin
nx := Round(nx / hyp * 65536); ny := Round(ny / hyp * 65536);
for i := 0 to n - 1 do
begin
SET_TS256(px div 256, py div 256, Value);
px := px + nx;
py := py + ny;
end;
end;
A := Value shr 24;
hyp := hyp - n shl 16;
A := A * LongWord(hyp) shl 8 and $FF000000;
SET_TS256(Sar(px + ex - nx,9), Sar(py + ey - ny,9), Value and _RGB + A);
finally
EMMS;
Changed;
end;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawLineFP(X1, Y1, X2, Y2: Single; L: Boolean);
var
n, i: Integer;
px, py, ex, ey, nx, ny, hyp: Integer;
A, C: TColor32;
begin
Changing;
try
px := Round(x1 * 65536); py := Round(y1 * 65536);
ex := Round(x2 * 65536); ey := Round(y2 * 65536);
nx := ex - px; ny := ey - py;
hyp := Round(Hypot(nx, ny));
if L then
Inc(hyp, 65536);
if hyp < 256 then
Exit;
n := hyp shr 16;
if n > 0 then
begin
nx := Round(nx / hyp * 65536);
ny := Round(ny / hyp * 65536);
for i := 0 to n - 1 do
begin
C := GetStippleColor;
SET_T256(px shr 8, py shr 8, C);
EMMS;
px := px + nx;
py := py + ny;
end;
end;
C := GetStippleColor;
A := C shr 24;
hyp := hyp - n shl 16;
A := A * LongWord(hyp) shl 8 and $FF000000;
SET_T256((px + ex - nx) shr 9, (py + ey - ny) shr 9, C and _RGB + A);
EMMS;
finally
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawLineFSP(X1, Y1, X2, Y2: Single; L: Boolean);
var
n, i: Integer;
px, py, ex, ey, nx, ny, hyp: Integer;
A, C: TColor32;
begin
if ClipLineF(X1, Y1, X2, Y2, 0, FWidth, 0, FHeight) then
if (X1 < FWidth - 1) and (X2 < FWidth - 1) and
(Y1 < FHeight - 1) and (Y2 < FHeight - 1) then
DrawLineFP(X1, Y1, X2, Y2, False)
else // check every pixel
begin
Changing;
try
px := Round(x1 * 65536); py := Round(y1 * 65536);
ex := Round(x2 * 65536); ey := Round(y2 * 65536);
nx := ex - px; ny := ey - py;
hyp := Round(Hypot(nx, ny));
if L then
Inc(hyp, 65536);
if hyp < 256 then
Exit;
n := hyp shr 16;
if n > 0 then
begin
nx := Round(nx / hyp * 65536); ny := Round(ny / hyp * 65536);
for i := 0 to n - 1 do
begin
C := GetStippleColor;
SET_TS256(px div 256, py div 256, C);
EMMS;
px := px + nx;
py := py + ny;
end;
end;
C := GetStippleColor;
A := C shr 24;
hyp := hyp - n shl 16;
A := A * LongWord(hyp) shl 8 and $FF000000;
SET_TS256(Sar(px + ex - nx,9), Sar(py + ey - ny,9), C and _RGB + A);
EMMS;
finally
Changed;
end;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawLineA(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
var
Dx, Dy, Sx, Sy, D: Integer;
EC, EA: Word;
CI: Byte;
P: PColor32;
begin
if (X1 = X2) or (Y1 = Y2) then
begin
DrawLineT(X1, Y1, X2, Y2, Value, L);
Exit;
end;
Dx := X2 - X1;
Dy := Y2 - Y1;
if Dx > 0 then
Sx := 1
else
begin
Sx := -1;
Dx := -Dx;
end;
if Dy > 0 then
Sy := 1
else
begin
Sy := -1;
Dy := -Dy;
end;
Changing;
try
EC := 0;
BlendMem(Value, Bits[X1 + Y1 * Width]);
if Dy > Dx then
begin
EA := Dx shl 16 div Dy;
if not L then
Dec(Dy);
while Dy > 0 do
begin
Dec(Dy);
D := EC;
Inc(EC, EA);
if EC <= D then
Inc(X1, Sx);
Inc(Y1, Sy);
CI := EC shr 8;
P := @Bits[X1 + Y1 * Width];
BlendMemEx(Value, P^, GAMMA_TABLE[CI xor 255]);
Inc(P, Sx);
BlendMemEx(Value, P^, GAMMA_TABLE[CI]);
end;
end
else // DY <= DX
begin
EA := Dy shl 16 div Dx;
if not L then
Dec(Dx);
while Dx > 0 do
begin
Dec(Dx);
D := EC;
Inc(EC, EA);
if EC <= D then
Inc(Y1, Sy);
Inc(X1, Sx);
CI := EC shr 8;
P := @Bits[X1 + Y1 * Width];
BlendMemEx(Value, P^, GAMMA_TABLE[CI xor 255]);
if Sy = 1 then
Inc(P, Width)
else
Dec(P, Width);
BlendMemEx(Value, P^, GAMMA_TABLE[CI]);
end;
end;
finally
EMMS;
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DrawLineAS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean);
begin
if ClipLine(X1, Y1, X2, Y2) then
DrawLineA(X1, Y1, X2, Y2, Value, L);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.MoveTo(X, Y: Integer);
begin
RasterX := X;
RasterY := Y;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.LineToS(X, Y: Integer);
begin
DrawLineS(RasterX, RasterY, X, Y, PenColor, False);
RasterX := X;
RasterY := Y;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.LineToTS(X, Y: Integer);
begin
DrawLineTS(RasterX, RasterY, X, Y, PenColor, False);
RasterX := X;
RasterY := Y;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.LineToAS(X, Y: Integer);
begin
DrawLineAS(RasterX, RasterY, X, Y, PenColor, False);
RasterX := X;
RasterY := Y;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.MoveToF(X, Y: Single);
begin
RasterXF := X;
RasterYF := Y;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.LineToFS(X, Y: Single);
begin
DrawLineFS(RasterXF, RasterYF, X, Y, PenColor, False);
RasterXF := X;
RasterYF := Y;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32);
var
j: Integer;
P: PColor32Array;
begin
Changing;
for j := Y1 to Y2 do
begin
P := Pointer(GetScanLine(j));
FillLongword(P[X1], X2 - X1 + 1, Value);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.FillRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
begin
if TestClip(X1, X2, Width) and TestClip(Y1, Y2, Height) then
FillRect(X1, Y1, X2, Y2, Value);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.FillRectT(X1, Y1, X2, Y2: Integer; Value: TColor32);
var
i, j: Integer;
P: PColor32;
A: Integer;
begin
A := Value shr 24;
if A = $FF then
FillRect(X1, Y1, X2, Y2, Value)
else
begin
Changing;
try
for j := Y1 to Y2 do
begin
P := GetPixelPtr(X1, j);
for i := X1 to X2 do
begin
CombineMem(Value, P^, A);
Inc(P);
end;
end;
finally
EMMS;
Changed;
end;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.FillRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32);
begin
if TestClip(X1, X2, Width) and TestClip(Y1, Y2, Height) then
FillRectT(X1, Y1, X2, Y2, Value);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.FrameRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
begin
Changing;
TestSwap(X1, X2);
TestSwap(Y1, Y2);
DrawHorzLineS(X1, Y1, X2, Value);
if Y2 > Y1 then
DrawHorzLineS(X1, Y2, X2, Value);
if Y2 > Y1 + 1 then
begin
DrawVertLineS(X1, Y1 + 1, Y2 - 1, Value);
if X2 > X1 then
DrawVertLineS(X2, Y1 + 1, Y2 - 1, Value);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.FrameRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32);
begin
Changing;
TestSwap(X1, X2);
TestSwap(Y1, Y2);
DrawHorzLineTS(X1, Y1, X2, Value);
if Y2 > Y1 then
DrawHorzLineTS(X1, Y2, X2, Value);
if Y2 > Y1 + 1 then
begin
DrawVertLineTS(X1, Y1 + 1, Y2 - 1, Value);
if X2 > X1 then
DrawVertLineTS(X2, Y1 + 1, Y2 - 1, Value);
end;
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.FrameRectTSP(X1, Y1, X2, Y2: Integer);
begin
Changing;
TestSwap(X1, X2);
TestSwap(Y1, Y2);
DrawHorzLineTSP(X1, Y1, X2);
if Y2 > Y1 + 1 then
begin
DrawVertLineTSP(X2, Y1 + 1, Y2 - 1);
if X2 > X1 then
DrawVertLineTSP(X1, Y1 + 1, Y2 - 1);
end;
if Y2 > Y1 then
DrawHorzLineTSP(X1, Y2, X2);
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.RaiseRectTS(X1, Y1, X2, Y2: Integer; Contrast: Integer);
var
C1, C2: TColor32;
begin
Changing;
try
if Contrast > 0 then
begin
C1 := clWhite32;
C2 := clBlack32;
end
else
if Contrast < 0 then
begin
C1 := clBlack32;
C2 := clWhite32;
Contrast := -Contrast;
end
else
Exit;
Contrast := Clamp(Contrast * 255 div 100);
C1 := SetAlpha(C1, Contrast);
C2 := SetAlpha(C2, Contrast);
TestSwap(X1, X2);
TestSwap(Y1, Y2);
DrawHorzLineTS(X1, Y1, X2 - 1, C1);
DrawHorzLineTS(X1 + 1, Y2, X2, C2);
DrawVertLineTS(X1, Y1, Y2 - 1, C1);
DrawVertLineTS(X2, Y1 + 1, Y2, C2);
finally
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.LoadFromStream(Stream: TStream);
var
B: TBitmap;
begin
Changing;
B := TBitmap.Create;
try
B.LoadFromStream(Stream);
Assign(B);
finally
B.Free;
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SaveToStream(Stream: TStream);
var
B: TBitmap;
begin
B := TBitmap.Create;
try
AssignTo(B);
B.SaveToStream(Stream);
finally
B.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.DefineProperties(Filer: TFiler);
{}function DoWrite: Boolean;
begin
if Filer.Ancestor <> nil then
Result := not (Filer.Ancestor is TGraphic)
else
Result := not Empty;
end;
begin
Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.ReadData(Stream: TStream);
var
w, h: Integer;
begin
Changing;
try
Stream.ReadBuffer(w, 4);
Stream.ReadBuffer(h, 4);
SetSize(w, h);
Stream.ReadBuffer(FBits[0], FWidth * FHeight * 4);
finally
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.WriteData(Stream: TStream);
begin
Stream.WriteBuffer(FWidth, 4);
Stream.WriteBuffer(FHeight, 4);
Stream.WriteBuffer(FBits[0], FWidth * FHeight * 4);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.LoadFromFile(const FileName: string);
var
P: TPicture;
begin
P := TPicture.Create;
try
P.LoadFromFile(FileName);
Assign(P);
finally
P.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SaveToFile(const FileName: string);
var
B: TBitmap;
begin
B := TBitmap.Create;
try
AssignTo(B);
B.SaveToFile(FileName);
finally
B.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetFont(Value: TFont);
begin
FFont.Assign(Value);
FontChanged(Self);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.FontChanged(Sender: TObject);
begin
if FontHandle > 0 then
begin
SelectObject(Handle, GetStockObject(SYSTEM_FONT));
FontHandle := 0;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.UpdateFont;
begin
if FontHandle = 0 then
begin
SelectObject(Handle, Font.Handle);
SetTextColor(Handle, ColorToRGB(Font.Color));
SetBkMode(Handle, Windows.TRANSPARENT);
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetDrawMode(Value: TDrawMode);
begin
if FDrawMode <> Value then
begin
Changing;
FDrawMode := Value;
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetMasterAlpha(Value: Byte);
begin
if FMasterAlpha <> Value then
begin
Changing;
FMasterAlpha := Value;
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.SetStretchFilter(Value: TStretchFilter);
begin
if FStretchFilter <> Value then
begin
Changing;
FStretchFilter := Value;
Changed;
end;
end;
//------------------------------------------------------------------------------
function TJclBitmap32.TextExtent(const Text: string): TSize;
begin
UpdateFont;
Result.cX := 0;
Result.cY := 0;
Windows.GetTextExtentPoint32(Handle, PChar(Text), Length(Text), Result);
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.TextOut(X, Y: Integer; const Text: string);
begin
Changing;
UpdateFont;
ExtTextOut(Handle, X, Y, 0, nil, PChar(Text), Length(Text), nil);
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.TextOut(X, Y: Integer; const ClipRect: TRect;
const Text: string);
begin
Changing;
UpdateFont;
ExtTextOut(Handle, X, Y, ETO_CLIPPED, @ClipRect, PChar(Text), Length(Text), nil);
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.TextOut(ClipRect: TRect; const Flags: Cardinal;
const Text: string);
begin
Changing;
UpdateFont;
DrawText(Handle, PChar(Text), Length(Text), ClipRect, Flags);
Changed;
end;
//------------------------------------------------------------------------------
function TJclBitmap32.TextHeight(const Text: string): Integer;
begin
Result := TextExtent(Text).cY;
end;
//------------------------------------------------------------------------------
function TJclBitmap32.TextWidth(const Text: string): Integer;
begin
Result := TextExtent(Text).cX;
end;
//------------------------------------------------------------------------------
procedure TJclBitmap32.RenderText(X, Y: Integer; const Text: string; AALevel: Integer; Color: TColor32);
var
B, B2: TJclBitmap32;
Sz: TSize;
C: TColor32;
I: Integer;
P: PColor32;
begin
AALevel := Constrain(AALevel, 0, 4);
B := TJclBitmap32.Create;
try
if AALevel = 0 then
begin
Sz := TextExtent(Text + ' ');
B.SetSize(Sz.cX, Sz.cY);
B.Font := Font;
B.Clear(0);
B.Font.Color := clWhite;
B.TextOut(0, 0, Text);
end
else
begin
B2 := TJclBitmap32.Create;
try
B2.SetSize(1, 1); // just need some DC here
B2.Font := Font;
B2.Font.Size := Font.Size shl AALevel;
Sz := B2.TextExtent(Text + ' ');
Sz.cx := (Sz.cx shr AALevel + 1) shl AALevel;
B2.SetSize(Sz.cx, Sz.cy);
B2.Clear(0);
B2.Font.Color := clWhite;
B2.TextOut(0, 0, Text);
B2.StretchFilter := sfLinear;
B.SetSize(Sz.cx shr AALevel, Sz.cy shr AALevel);
B.Draw(Rect(0, 0, B.Width, B.Height), Rect(0, 0, B2.Width, B2.Height), B2);
finally
B2.Free;
end;
end;
// convert intensity and color to alpha
B.MasterAlpha := Color shr 24;
Color := Color and $00FFFFFF;
P := @B.Bits[0];
for I := 0 to B.Width * B.Height - 1 do
begin
C := P^;
if C <> 0 then
begin
C := P^ shl 24; // transfer blue channel to alpha
C := C + Color;
P^ := C;
end;
Inc(P);
end;
B.DrawMode := dmBlend;
B.DrawTo(Self, X, Y);
finally
B.Free;
end;
end;
//==============================================================================
// TJclByteMap
//==============================================================================
procedure TJclByteMap.Assign(Source: TPersistent);
begin
Changing;
BeginUpdate;
try
if Source is TJclByteMap then
begin
FWidth := TJclByteMap(Source).Width;
FHeight := TJclByteMap(Source).Height;
{$IFDEF SUPPORTS_DYNAMICARRAYS}
FBytes := Copy(TJclByteMap(Source).Bytes, 0, FWidth * FHeight);
{$ELSE}
// TODO implement
// FBytes := Copy(TJclByteMap(Source).Bytes, 0, FWidth * FHeight);
{$ENDIF SUPPORTS_DYNAMICARRAYS}
end
else
if Source is TJclBitmap32 then
ReadFrom(TJclBitmap32(Source), ckWeightedRGB)
else
inherited;
finally
EndUpdate;
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclByteMap.AssignTo(Dst: TPersistent);
begin
if Dst is TJclBitmap32 then
WriteTo(TJclBitmap32(Dst), ckUniformRGB)
else
inherited;
end;
//------------------------------------------------------------------------------
procedure TJclByteMap.Clear(FillValue: Byte);
begin
Changing;
FillChar(Bytes[0], Width * Height, FillValue);
Changed;
end;
//------------------------------------------------------------------------------
destructor TJclByteMap.Destroy;
begin
FBytes := nil;
inherited;
end;
//------------------------------------------------------------------------------
function TJclByteMap.Empty: Boolean;
begin
Result := Bytes = nil;
end;
//------------------------------------------------------------------------------
function TJclByteMap.GetValPtr(X, Y: Integer): PByte;
begin
Result := @Bytes[X + Y * Width];
end;
//------------------------------------------------------------------------------
function TJclByteMap.GetValue(X, Y: Integer): Byte;
begin
Result := Bytes[X + Y * Width];
end;
//------------------------------------------------------------------------------
procedure TJclByteMap.ReadFrom(Source: TJclBitmap32; Conversion: TConversionKind);
var
W, H, I, N: Integer;
SrcC: PColor32;
SrcB, DstB: PByte;
Value: TColor32;
begin
Changing;
BeginUpdate;
try
SetSize(Source.Width, Source.Height);
if Empty then
Exit;
W := Source.Width;
H := Source.Height;
N := W * H - 1;
SrcC := Source.PixelPtr[0, 0];
SrcB := Pointer(SrcC);
DstB := @Bytes[0];
case Conversion of
ckRed:
begin
Inc(SrcB, 2);
for I := 0 to N do
begin
DstB^ := SrcB^;
Inc(DstB);
Inc(SrcB, 4);
end;
end;
ckGreen:
begin
Inc(SrcB, 1);
for I := 0 to N do
begin
DstB^ := SrcB^;
Inc(DstB);
Inc(SrcB, 4);
end;
end;
ckBlue:
begin
for I := 0 to N do
begin
DstB^ := SrcB^;
Inc(DstB);
Inc(SrcB, 4);
end;
end;
ckAlpha:
begin
Inc(SrcB, 3);
for I := 0 to N do
begin
DstB^ := SrcB^;
Inc(DstB);
Inc(SrcB, 4);
end;
end;
ckUniformRGB:
begin
for I := 0 to N do
begin
Value := SrcC^;
Value := (Value and $00FF0000) shr 16 + (Value and $0000FF00) shr 8 +
(Value and $000000FF);
Value := Value div 3;
DstB^ := Value;
Inc(DstB);
Inc(SrcC);
end;
end;
ckWeightedRGB:
begin
for I := 0 to N do
begin
DstB^ := Intensity(SrcC^);
Inc(DstB);
Inc(SrcC);
end;
end;
end;
finally
EndUpdate;
Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclByteMap.SetValue(X, Y: Integer; Value: Byte);
begin
Bytes[X + Y * Width] := Value;
end;
//------------------------------------------------------------------------------
procedure TJclByteMap.SetSize(NewWidth, NewHeight: Integer);
begin
Changing;
inherited;
{$IFDEF SUPPORTS_DYNAMICARRAYS}
SetLength(FBytes, Width * Height);
{$ELSE}
// TODO implement
// SetLength(FBytes, Width * Height);
{$ENDIF SUPPORTS_DYNAMICARRAYS}
Changed;
end;
//------------------------------------------------------------------------------
procedure TJclByteMap.WriteTo(Dest: TJclBitmap32; Conversion: TConversionKind);
var
W, H, I, N: Integer;
DstC: PColor32;
DstB, SrcB: PByte;
begin
Dest.Changing;
Dest.BeginUpdate;
try
Dest.SetSize(Width, Height);
if Empty then
Exit;
W := Width;
H := Height;
N := W * H - 1;
DstC := Dest.PixelPtr[0, 0];
DstB := Pointer(DstC);
SrcB := @Bytes[0];
case Conversion of
ckRed:
begin
Inc(DstB, 2);
for I := 0 to N do
begin
DstB^ := SrcB^;
Inc(DstB, 4);
Inc(SrcB);
end;
end;
ckGreen:
begin
Inc(DstB, 1);
for I := 0 to N do
begin
DstB^ := SrcB^;
Inc(DstB, 4);
Inc(SrcB);
end;
end;
ckBlue:
begin
for I := 0 to N do
begin
DstB^ := SrcB^;
Inc(DstB, 4);
Inc(SrcB);
end;
end;
ckAlpha:
begin
Inc(DstB, 3);
for I := 0 to N do
begin
DstB^ := SrcB^;
Inc(DstB, 4);
Inc(SrcB);
end;
end;
ckUniformRGB, ckWeightedRGB:
begin
for I := 0 to N do
begin
DstC^ := Gray32(SrcB^, $FF);
Inc(DstC);
Inc(SrcB);
end;
end;
end;
finally
Dest.EndUpdate;
Dest.Changed;
end;
end;
//------------------------------------------------------------------------------
procedure TJclByteMap.WriteTo(Dest: TJclBitmap32; const Palette: TPalette32);
var
W, H, I, N: Integer;
DstC: PColor32;
SrcB: PByte;
begin
Dest.Changing;
Dest.BeginUpdate;
try
Dest.SetSize(Width, Height);
if Empty then
Exit;
W := Width;
H := Height;
N := W * H - 1;
DstC := Dest.PixelPtr[0, 0];
SrcB := @Bytes[0];
for I := 0 to N do
begin
DstC^ := Palette[SrcB^];
Inc(DstC);
Inc(SrcB);
end;
finally
Dest.EndUpdate;
Dest.Changed;
end;
end;
//==============================================================================
// Matrices
//==============================================================================
{ TODO -oWIMDC -cReplace : Insert JclMatrix support }
function _DET(a1, a2, b1, b2: Extended): Extended; overload;
begin
Result := a1 * b2 - a2 * b1;
end;
//------------------------------------------------------------------------------
function _DET(a1, a2, a3, b1, b2, b3, c1, c2, c3: Extended): Extended; overload;
begin
Result :=
a1 * (b2 * c3 - b3 * c2) -
b1 * (a2 * c3 - a3 * c2) +
c1 * (a2 * b3 - a3 * b2);
end;
//------------------------------------------------------------------------------
procedure Adjoint(var M: TMatrix3d);
var
a1, a2, a3: Extended;
b1, b2, b3: Extended;
c1, c2, c3: Extended;
begin
a1 := M.A[0,0]; a2:= M.A[0,1]; a3 := M.A[0,2];
b1 := M.A[1,0]; b2:= M.A[1,1]; b3 := M.A[1,2];
c1 := M.A[2,0]; c2:= M.A[2,1]; c3 := M.A[2,2];
M.A[0,0]:= _DET(b2, b3, c2, c3);
M.A[0,1]:= -_DET(a2, a3, c2, c3);
M.A[0,2]:= _DET(a2, a3, b2, b3);
M.A[1,0]:= -_DET(b1, b3, c1, c3);
M.A[1,1]:= _DET(a1, a3, c1, c3);
M.A[1,2]:= -_DET(a1, a3, b1, b3);
M.A[2,0]:= _DET(b1, b2, c1, c2);
M.A[2,1]:= -_DET(a1, a2, c1, c2);
M.A[2,2]:= _DET(a1, a2, b1, b2);
end;
//------------------------------------------------------------------------------
function Determinant(const M: TMatrix3d): Extended;
begin
Result := _DET(M.A[0,0], M.A[1,0], M.A[2,0],
M.A[0,1], M.A[1,1], M.A[2,1],
M.A[0,2], M.A[1,2], M.A[2,2]);
end;
//------------------------------------------------------------------------------
procedure Scale(var M: TMatrix3d; Factor: Extended);
var
i, j: Integer;
begin
for i := 0 to 2 do
for j := 0 to 2 do
M.A[i,j] := M.A[i,j] * Factor;
end;
//------------------------------------------------------------------------------
procedure InvertMatrix(var M: TMatrix3d);
var
Det: Extended;
begin
Det := Determinant(M);
if Abs(Det) < 1E-5 then
M := IdentityMatrix
else
begin
Adjoint(M);
Scale(M, 1 / Det);
end;
end;
//------------------------------------------------------------------------------
function Mult(const M1, M2: TMatrix3d): TMatrix3d;
var
i, j: Integer;
begin
for i := 0 to 2 do
for j := 0 to 2 do
Result.A[i, j] :=
M1.A[0, j] * M2.A[i, 0] +
M1.A[1, j] * M2.A[i, 1] +
M1.A[2, j] * M2.A[i, 2];
end;
//------------------------------------------------------------------------------
type
TVector3d = array [0..2] of Extended;
TVector3i = array [0..2] of Integer;
//------------------------------------------------------------------------------
function VectorTransform(const M: TMatrix3d; const V: TVector3d): TVector3d;
begin
Result[0] := M.A[0,0] * V[0] + M.A[1,0] * V[1] + M.A[2,0] * V[2];
Result[1] := M.A[0,1] * V[0] + M.A[1,1] * V[1] + M.A[2,1] * V[2];
Result[2] := M.A[0,2] * V[0] + M.A[1,2] * V[1] + M.A[2,2] * V[2];
end;
//==============================================================================
// TJclLinearTransformation
//==============================================================================
procedure TJclLinearTransformation.Clear;
begin
FMatrix := IdentityMatrix;
end;
//------------------------------------------------------------------------------
constructor TJclLinearTransformation.Create;
begin
Clear;
end;
//------------------------------------------------------------------------------
function TJclLinearTransformation.GetTransformedBounds(const Src: TRect): TRect;
var
V1, V2, V3, V4: TVector3d;
begin
V1[0] := Src.Left; V1[1] := Src.Top; V1[2] := 1;
V2[0] := Src.Right - 1; V2[1] := V1[1]; V2[2] := 1;
V3[0] := V1[0]; V3[1] := Src.Bottom - 1; V3[2] := 1;
V4[0] := V2[0]; V4[1] := V3[1]; V4[2] := 1;
V1 := VectorTransform(Matrix, V1);
V2 := VectorTransform(Matrix, V2);
V3 := VectorTransform(Matrix, V3);
V4 := VectorTransform(Matrix, V4);
Result.Left := Round(Min(Min(V1[0], V2[0]), Min(V3[0], V4[0])) - 0.5);
Result.Right := Round(Max(Max(V1[0], V2[0]), Max(V3[0], V4[0])) + 0.5);
Result.Top := Round(Min(Min(V1[1], V2[1]), Min(V3[1], V4[1])) - 0.5);
Result.Bottom := Round(Max(Max(V1[1], V2[1]), Max(V3[1], V4[1])) + 0.5);
end;
//------------------------------------------------------------------------------
procedure TJclLinearTransformation.PrepareTransform;
var
M: TMatrix3d;
begin
M := Matrix;
InvertMatrix(M);
// calculate a fixed point (4096) factors
A := Round(M.A[0,0] * 4096); B := Round(M.A[1,0] * 4096); C := Round(M.A[2,0] * 4096);
D := Round(M.A[0,1] * 4096); E := Round(M.A[1,1] * 4096); F := Round(M.A[2,1] * 4096);
end;
//------------------------------------------------------------------------------
procedure TJclLinearTransformation.Rotate(Cx, Cy, Alpha: Extended);
var
S, C: Extended;
M: TMatrix3d;
begin
if (Cx <> 0) and (Cy <> 0) then
Translate(-Cx, -Cy);
SinCos(DegToRad(Alpha), S, C);
M := IdentityMatrix;
M.A[0,0] := C; M.A[1,0] := S;
M.A[0,1] := -S; M.A[1,1] := C;
FMatrix := Mult(M, FMatrix);
if (Cx <> 0) and (Cy <> 0) then
Translate(Cx, Cy);
end;
//------------------------------------------------------------------------------
procedure TJclLinearTransformation.Scale(Sx, Sy: Extended);
var
M: TMatrix3d;
begin
M := IdentityMatrix;
M.A[0,0] := Sx;
M.A[1,1] := Sy;
FMatrix := Mult(M, FMatrix);
end;
//------------------------------------------------------------------------------
procedure TJclLinearTransformation.Skew(Fx, Fy: Extended);
var
M: TMatrix3d;
begin
M := IdentityMatrix;
M.A[1, 0] := Fx;
M.A[0, 1] := Fy;
FMatrix := Mult(M, FMatrix);
end;
//------------------------------------------------------------------------------
procedure TJclLinearTransformation.Transform(DstX, DstY: Integer;
out SrcX, SrcY: Integer);
begin
SrcX := Sar(DstX * A + DstY * B + C,12);
SrcY := Sar(DstX * D + DstY * E + F,12);
end;
//------------------------------------------------------------------------------
procedure TJclLinearTransformation.Transform256(DstX, DstY: Integer;
out SrcX256, SrcY256: Integer);
begin
SrcX256 := Sar(DstX * A + DstY * B + C,4);
SrcY256 := Sar(DstX * D + DstY * E + F,4);
end;
//------------------------------------------------------------------------------
procedure TJclLinearTransformation.Translate(Dx, Dy: Extended);
var
M: TMatrix3d;
begin
M := IdentityMatrix;
M.A[2,0] := Dx;
M.A[2,1] := Dy;
FMatrix := Mult(M, FMatrix);
end;
//==============================================================================
// PolyLines and Polygons
//==============================================================================
procedure PolylineTS(Bitmap: TJclBitmap32; const Points: TDynPointArray;
Color: TColor32);
var
I, L: Integer;
DoAlpha: Boolean;
begin
DoAlpha := Color and $FF000000 <> $FF000000;
L := Length(Points);
if L < 2 then
Exit;
Bitmap.Changing;
Bitmap.BeginUpdate;
with Points[L - 1] do
Bitmap.MoveTo(X, Y);
Bitmap.PenColor := Color;
if DoAlpha then
for I := 0 to L - 1 do
with Points[I] do
Bitmap.LineToTS(X, Y)
else
for I := 0 to L - 1 do
with Points[I] do
Bitmap.LineToS(X, Y);
Bitmap.EndUpdate;
Bitmap.Changed;
end;
//------------------------------------------------------------------------------
procedure PolyLineAS(Bitmap: TJclBitmap32; const Points: TDynPointArray;
Color: TColor32);
var
I, L: Integer;
begin
L := Length(Points);
if L < 2 then
Exit;
Bitmap.Changing;
Bitmap.BeginUpdate;
with Points[L - 1] do
Bitmap.MoveTo(X, Y);
Bitmap.PenColor := Color;
for I := 0 to L - 1 do
with Points[I] do
Bitmap.LineToAS(X, Y);
Bitmap.EndUpdate;
Bitmap.Changed;
end;
//------------------------------------------------------------------------------
procedure PolylineFS(Bitmap: TJclBitmap32; const Points: TDynPointArrayF;
Color: TColor32);
var
I, L: Integer;
begin
L := Length(Points);
if L < 2 then
Exit;
Bitmap.Changing;
Bitmap.BeginUpdate;
with Points[L - 1] do
Bitmap.MoveToF(X, Y);
Bitmap.PenColor := Color;
for I := 0 to L - 1 do
with Points[I] do
Bitmap.LineToFS(X, Y);
Bitmap.EndUpdate;
Bitmap.Changed;
end;
//------------------------------------------------------------------------------
procedure QSortLine(const ALine: TScanLine; L, R: Integer);
var
I, J, P: Integer;
begin
repeat
I := L;
J := R;
P := ALine[(L + R) shr 1];
repeat
while ALine[I] < P do
Inc(I);
while ALine[J] > P do
Dec(J);
if I <= J then
begin
SwapOrd(ALine[I], ALine[J]);
Inc(I);
Dec(J);
end;
until I > J;
if L < J then
QSortLine(ALine, L, J);
L := I;
until I >= R;
end;
//------------------------------------------------------------------------------
procedure SortLine(const ALine: TScanLine);
var
L: Integer;
begin
L := Length(ALine);
Assert(not Odd(L));
if L = 2 then
TestSwap(ALine[0], ALine[1])
else
if L > 2 then
QSortLine(ALine, 0, L - 1);
end;
//------------------------------------------------------------------------------
procedure SortLines(const ScanLines: TScanLines);
var
I: Integer;
begin
for I := 0 to High(ScanLines) do
SortLine(ScanLines[I]);
end;
//------------------------------------------------------------------------------
procedure AddPolygon(const Points: TDynPointArray; BaseY: Integer;
MaxX, MaxY: Integer; var ScanLines: TScanLines; SubSampleX: Boolean);
var
I, X1, Y1, X2, Y2: Integer;
Direction, PrevDirection: Integer; // up = 1 or down = -1
{}procedure AddEdgePoint(X, Y: Integer);
var
L: Integer;
begin
if (Y < 0) or (Y > MaxY) then
Exit;
X := Constrain(X, 0, MaxX);
L := Length(ScanLines[Y - BaseY]);
SetLength(ScanLines[Y - BaseY], L + 1);
ScanLines[Y - BaseY][L] := X;
end;
{}procedure DrawEdge(X1, Y1, X2, Y2: Integer);
var
X, Y, I: Integer;
Dx, Dy, Sx, Sy: Integer;
Delta: Integer;
begin
// this function 'renders' a line into the edge (ScanLines) buffer
if Y2 = Y1 then
Exit;
Dx := X2 - X1;
Dy := Y2 - Y1;
if Dy > 0 then
Sy := 1
else
begin
Sy := -1;
Dy := -Dy;
end;
if Dx > 0 then
Sx := 1
else
begin
Sx := -1;
Dx := -Dx;
end;
Delta := (Dx mod Dy) shr 1;
X := X1; Y := Y1;
for I := 0 to Dy - 1 do
begin
AddEdgePoint(X, Y);
Inc(Y, Sy);
Inc(Delta, Dx);
while Delta > Dy do
begin
Inc(X, Sx);
Dec(Delta, Dy);
end;
end;
end;
begin
X1 := Points[0].X;
Y1 := Points[0].Y;
if SubSampleX then
X1 := X1 shl 8;
// find the last Y different from Y1 and assign it to Y0
PrevDirection := 0;
for I := High(Points) downto 1 do
begin
if Points[I].Y > Y1 then
PrevDirection := -1
else
if Points[I].Y < Y1 then
PrevDirection := 1
else
Continue;
Break;
end;
Assert(PrevDirection <> 0);
for I := 1 to High(Points) do
begin
X2 := Points[I].X;
Y2 := Points[I].Y;
if SubSampleX then
X2 := X2 shl 8;
if Y1 <> Y2 then
begin
DrawEdge(X1, Y1, X2, Y2);
if Y2 > Y1 then
Direction := 1 // up
else
Direction := -1; // down
if Direction <> PrevDirection then
begin
AddEdgePoint(X1, Y1);
PrevDirection := Direction;
end;
end;
X1 := X2; Y1 := Y2;
end;
X2 := Points[0].X;
Y2 := Points[0].Y;
if SubSampleX then
X2 := X2 shl 8;
if Y1 <> Y2 then
begin
DrawEdge(X1, Y1, X2, Y2);
if Y2 > Y1 then
Direction := 1
else
Direction := -1;
if Direction <> PrevDirection then
AddEdgePoint(X1, Y1);
end;
end;
//------------------------------------------------------------------------------
procedure FillLines(Bitmap: TJclBitmap32; BaseY: Integer;
const ScanLines: TScanLines; Color: TColor32);
var
I, J, L: Integer;
Left, Right: Integer;
DoAlpha: Boolean;
begin
DoAlpha := Color and $FF000000 <> $FF000000;
for J := 0 to High(ScanLines) do
begin
L := Length(ScanLines[J]); // assuming length is even
I := 0;
while I < L do
begin
Left := ScanLines[J][I];
Inc(I);
Right := ScanLines[J][I];
if Right > Left then
begin
if (Left and $FF) < $80 then
Left := Left shr 8
else
Left := Left shr 8 + 1;
if (Right and $FF) < $80 then
Right := Right shr 8
else
Right := Right shr 8 + 1;
if DoAlpha then
Bitmap.DrawHorzLineT(Left, BaseY + J, Right, Color)
else
Bitmap.DrawHorzLine(Left, BaseY + J, Right, Color);
end;
Inc(I);
end;
end;
end;
//------------------------------------------------------------------------------
procedure FillLines2(Bitmap: TJclBitmap32; BaseY: Integer;
const ScanLines: TScanLines; Color: TColor32);
var
I, J, L, N: Integer;
MinY, MaxY, Y, Top, Bottom: Integer;
MinX, MaxX, X, Dx: Integer;
Left, Right: Integer;
Buffer: array of Integer;
P: PColor32;
DoAlpha: Boolean;
begin
DoAlpha := Color and $FF000000 <> $FF000000;
// find the range of Y screen coordinates
MinY := BaseY shr 4;
MaxY := (BaseY + Length(ScanLines) + 15) shr 4;
Y := MinY;
while Y < MaxY do
begin
Top := Y shl 4 - BaseY;
Bottom := Top + 15;
if Top < 0 then
Top := 0;
if Bottom > High(ScanLines) then
Bottom := High(ScanLines);
// find left and right edges of the screen scanline
MinX := 1000000;
MaxX := -1000000;
for J := Top to Bottom do
begin
L := High(ScanLines[J]);
Left := ScanLines[J][0] shr 4;
Right := (ScanLines[J][L] + 15) shr 4;
if Left < MinX then
MinX := Left;
if Right > MaxX then
MaxX := Right;
end;
// allocate the buffer for a screen scanline
SetLength(Buffer, MaxX - MinX + 2);
FillLongword(Buffer[0], Length(Buffer), 0);
// and fill it
for J := Top to Bottom do
begin
I := 0;
L := Length(ScanLines[J]);
while I < L do
begin
// Left edge
X := ScanLines[J][I];
Dx := X and $0F;
X := X shr 4 - MinX;
Inc(Buffer[X], Dx xor $0F);
Inc(Buffer[X + 1], Dx);
Inc(I);
// Right edge
X := ScanLines[J][I];
Dx := X and $0F;
X := X shr 4 - MinX;
Dec(Buffer[X], Dx xor $0F);
Dec(Buffer[X + 1], Dx);
Inc(I);
end;
end;
// integrate the buffer
N := 0;
for I := 0 to High(Buffer) do
begin
Inc(N, Buffer[I]);
Buffer[I] := N * 273 shr 8; // some bias
end;
// draw it to the screen
P := Bitmap.PixelPtr[MinX, Y];
try
if DoAlpha then
for I := 0 to High(Buffer) do
begin
BlendMemEx(Color, P^, Buffer[I]);
Inc(P);
end
else
for I := 0 to High(Buffer) do
begin
N := Buffer[I];
if N = 255 then
P^ := Color
else
BlendMemEx(Color, P^, Buffer[I]);
Inc(P);
end;
finally
EMMS;
end;
Inc(Y);
end;
end;
//------------------------------------------------------------------------------
procedure GetMinMax(const Points: TDynPointArray; out MinY, MaxY: Integer);
var
I, Y: Integer;
begin
MinY := 100000;
MaxY := -100000;
for I := 0 to High(Points) do
begin
Y := Points[I].Y;
if Y < MinY then
MinY := Y;
if Y > MaxY then
MaxY := Y;
end;
end;
//------------------------------------------------------------------------------
procedure PolygonTS(Bitmap: TJclBitmap32; const Points: TDynPointArray; Color: TColor32);
var
L, MinY, MaxY: Integer;
ScanLines: TScanLines;
begin
L := Length(Points);
if L < 3 then
Exit;
GetMinMax(Points, MinY, MaxY);
MinY := Constrain(MinY, 0, Bitmap.Height);
MaxY := Constrain(MaxY, 0, Bitmap.Height);
if MinY >= MaxY then
Exit;
SetLength(ScanLines, MaxY - MinY + 1);
AddPolygon(Points, MinY, Bitmap.Width shl 8 - 1, Bitmap.Height - 1,
ScanLines, True);
SortLines(ScanLines);
Bitmap.Changing;
Bitmap.BeginUpdate;
try
FillLines(Bitmap, MinY, ScanLines, Color);
finally
Bitmap.EndUpdate;
Bitmap.Changed;
end;
end;
//------------------------------------------------------------------------------
procedure PolygonAS(Bitmap: TJclBitmap32; const Points: TDynPointArray; Color: TColor32);
var
L, I, MinY, MaxY: Integer;
ScanLines: TScanLines;
PP: TDynPointArray;
begin
L := Length(Points);
if L < 3 then
Exit;
SetLength(PP, L);
for I := 0 to L - 1 do
begin
PP[I].X := Points[I].X shl 4 + 7;
PP[I].Y := Points[I].Y shl 4 + 7;
end;
GetMinMax(PP, MinY, MaxY);
MinY := Constrain(MinY, 0, Bitmap.Height shl 4 - 1);
MaxY := Constrain(MaxY, 0, Bitmap.Height shl 4 - 1);
if MinY >= MaxY then
Exit;
SetLength(ScanLines, MaxY - MinY + 1);
AddPolygon(PP, MinY, Bitmap.Width shl 4 - 1, Bitmap.Height shl 4 - 1,
ScanLines, False);
SortLines(ScanLines);
Bitmap.Changing;
Bitmap.BeginUpdate;
try
FillLines2(Bitmap, MinY, ScanLines, Color);
finally
Bitmap.EndUpdate;
Bitmap.Changed;
end;
end;
//------------------------------------------------------------------------------
procedure PolygonFS(Bitmap: TJclBitmap32; const Points: TDynPointArrayF; Color: TColor32);
var
L, I, MinY, MaxY: Integer;
ScanLines: TScanLines;
PP: TDynPointArray;
begin
L := Length(Points);
if L < 3 then
Exit;
SetLength(PP, L);
for I := 0 to L - 1 do
begin
PP[I].X := Round(Points[I].X * 16) + 7;
PP[I].Y := Round(Points[I].Y * 16) + 7;
end;
GetMinMax(PP, MinY, MaxY);
MinY := Constrain(MinY, 0, Bitmap.Height shl 4 - 1);
MaxY := Constrain(MaxY, 0, Bitmap.Height shl 4 - 1);
if MinY >= MaxY then
Exit;
SetLength(ScanLines, MaxY - MinY + 1);
AddPolygon(PP, MinY, Bitmap.Width shl 4 - 1, Bitmap.Height shl 4 - 1,
ScanLines, False);
SortLines(ScanLines);
Bitmap.Changing;
Bitmap.BeginUpdate;
try
FillLines2(Bitmap, MinY, ScanLines, Color);
finally
Bitmap.EndUpdate;
Bitmap.Changed;
end;
end;
//------------------------------------------------------------------------------
procedure PolyPolygonTS(Bitmap: TJclBitmap32; const Points: TDynDynPointArrayArray;
Color: TColor32);
var
N, L, min, max, MinY, MaxY: Integer;
ScanLines: TScanLines;
begin
MinY := 100000;
MaxY := -100000;
for N := 0 to High(Points) do
begin
L := Length(Points[N]);
if L < 3 then
Exit;
GetMinMax(Points[N], min, max);
if min < MinY then
MinY := min;
if max > MaxY then
MaxY := max;
end;
MinY := Constrain(MinY, 0, Bitmap.Height - 1);
MaxY := Constrain(MaxY, 0, Bitmap.Height - 1);
if MinY >= MaxY then
Exit;
SetLength(ScanLines, MaxY - MinY + 1);
for N := 0 to High(Points) do
begin
AddPolygon(Points[N], MinY, Bitmap.Width shl 8 - 1 , Bitmap.Height - 1,
ScanLines, True);
end;
SortLines(ScanLines);
Bitmap.Changing;
FillLines(Bitmap, MinY, ScanLines, Color);
Bitmap.Changed;
end;
//------------------------------------------------------------------------------
procedure PolyPolygonAS(Bitmap: TJclBitmap32; const Points: TDynDynPointArrayArray;
Color: TColor32);
var
N, L, I, min, max, MinY, MaxY: Integer;
ScanLines: TScanLines;
PPP: TDynDynPointArrayArray;
begin
MinY := 100000;
MaxY := -100000;
SetLength(PPP, Length(Points));
for N := 0 to High(Points) do
begin
L := Length(Points);
SetLength(PPP[N], Length(Points[N]));
for I := 0 to L - 1 do
begin
PPP[N][I].X := Points[N][I].X shl 4 + 7;
PPP[N][I].Y := Points[N][I].Y shl 4 + 7;
end;
if L < 3 then
Continue;
GetMinMax(PPP[N], min, max);
if min < MinY then
MinY := min;
if max > MaxY then
MaxY := max;
end;
MinY := Constrain(MinY, 0, Bitmap.Height shl 4 - 1);
MaxY := Constrain(MaxY, 0, Bitmap.Height shl 4 - 1);
if MinY >= MaxY then
Exit;
SetLength(ScanLines, MaxY - MinY + 1);
for N := 0 to High(PPP) do
begin
AddPolygon(PPP[N], MinY, Bitmap.Width shl 4 - 1, Bitmap.Height shl 4 - 1,
ScanLines, False);
end;
SortLines(ScanLines);
Bitmap.Changing;
FillLines2(Bitmap, MinY, ScanLines, Color);
Bitmap.Changed;
end;
//------------------------------------------------------------------------------
procedure PolyPolygonFS(Bitmap: TJclBitmap32; const Points: TDynDynPointArrayArrayF;
Color: TColor32);
var
N, L, I, min, max, MinY, MaxY: Integer;
ScanLines: TScanLines;
PPP: TDynDynPointArrayArray;
begin
MinY := 100000;
MaxY := -100000;
SetLength(PPP, Length(Points));
for N := 0 to High(Points) do
begin
L := Length(Points);
SetLength(PPP[N], Length(Points[N]));
for I := 0 to L - 1 do
begin
PPP[N][I].X := Round(Points[N][I].X * 16) + 7;
PPP[N][I].Y := Round(Points[N][I].Y * 16) + 7;
end;
if L < 3 then
Continue;
GetMinMax(PPP[N], min, max);
if min < MinY then
MinY := min;
if max > MaxY then
MaxY := max;
end;
MinY := Constrain(MinY, 0, Bitmap.Height shl 4 - 1);
MaxY := Constrain(MaxY, 0, Bitmap.Height shl 4 - 1);
if MinY >= MaxY then
Exit;
SetLength(ScanLines, MaxY - MinY + 1);
for N := 0 to High(PPP) do
begin
AddPolygon(PPP[N], MinY, Bitmap.Width shl 4 - 1, Bitmap.Height shl 4 - 1,
ScanLines, False);
end;
SortLines(ScanLines);
Bitmap.Changing;
FillLines2(Bitmap, MinY, ScanLines, Color);
Bitmap.Changed;
end;
//==============================================================================
// Filters
//==============================================================================
procedure CheckParams(Dst, Src: TJclBitmap32);
begin
if Src = nil then
raise EJclGraphicsError.CreateResRec(@RsSourceBitmapEmpty);
if Dst = nil then
raise EJclGraphicsError.CreateResRec(@RsDestinationBitmapEmpty);
Dst.SetSize(Src.Width, Src.Height);
end;
//------------------------------------------------------------------------------
procedure AlphaToGrayscale(Dst, Src: TJclBitmap32);
var
I: Integer;
D, S: PColor32;
begin
CheckParams(Dst, Src);
Dst.Changing;
Dst.SetSize(Src.Width, Src.Height);
D := @Dst.Bits[0];
S := @Src.Bits[0];
for I := 0 to Src.Width * Src.Height - 1 do
begin
D^ := Gray32(AlphaComponent(S^), $FF);
Inc(S); Inc(D);
end;
Dst.Changed;
end;
//------------------------------------------------------------------------------
procedure IntensityToAlpha(Dst, Src: TJclBitmap32);
var
I: Integer;
D, S: PColor32;
begin
CheckParams(Dst, Src);
Dst.Changing;
Dst.SetSize(Src.Width, Src.Height);
D := @Dst.Bits[0];
S := @Src.Bits[0];
for I := 0 to Src.Width * Src.Height - 1 do
begin
D^ := SetAlpha(D^, Intensity(S^));
Inc(S); Inc(D);
end;
Dst.Changed;
end;
//------------------------------------------------------------------------------
procedure Invert(Dst, Src: TJclBitmap32);
var
I: Integer;
D, S: PColor32;
begin
CheckParams(Dst, Src);
Dst.Changing;
Dst.SetSize(Src.Width, Src.Height);
D := @Dst.Bits[0];
S := @Src.Bits[0];
for I := 0 to Src.Width * Src.Height - 1 do
begin
D^ := S^ xor $FFFFFFFF;
Inc(S); Inc(D);
end;
Dst.Changed;
end;
//------------------------------------------------------------------------------
procedure InvertRGB(Dst, Src: TJclBitmap32);
var
I: Integer;
D, S: PColor32;
begin
CheckParams(Dst, Src);
Dst.Changing;
Dst.SetSize(Src.Width, Src.Height);
D := @Dst.Bits[0];
S := @Src.Bits[0];
for I := 0 to Src.Width * Src.Height - 1 do
begin
D^ := S^ xor $00FFFFFF;
Inc(S); Inc(D);
end;
Dst.Changed;
end;
//------------------------------------------------------------------------------
procedure ColorToGrayscale(Dst, Src: TJclBitmap32);
var
I: Integer;
D, S: PColor32;
begin
CheckParams(Dst, Src);
Dst.Changing;
Dst.SetSize(Src.Width, Src.Height);
D := @Dst.Bits[0];
S := @Src.Bits[0];
for I := 0 to Src.Width * Src.Height - 1 do
begin
D^ := Gray32(Intensity(S^), $FF);
Inc(S); Inc(D);
end;
Dst.Changed;
end;
//------------------------------------------------------------------------------
procedure ApplyLUT(Dst, Src: TJclBitmap32; const LUT: TLUT8);
var
I: Integer;
D, S: PColor32;
r, g, b: TColor32;
C: TColor32;
begin
CheckParams(Src, Dst);
Dst.Changing;
Dst.SetSize(Src.Width, Src.Height);
D := @Dst.Bits[0];
S := @Src.Bits[0];
for I := 0 to Src.Width * Src.Height - 1 do
begin
C := S^;
r := C and $00FF0000;
g := C and $0000FF00;
r := r shr 16;
b := C and $000000FF;
g := g shr 8;
r := LUT[r];
g := LUT[g];
b := LUT[b];
D^ := $FF000000 or r shl 16 or g shl 8 or b;
Inc(S);
Inc(D);
end;
Dst.Changed;
end;
//==============================================================================
// Gamma table support for opacities
//==============================================================================
procedure SetGamma(Gamma: Single);
var
i: Integer;
begin
for i := 0 to 255 do
GAMMA_TABLE[i] := Round(255 * Power(i / 255, Gamma));
end;
// modify Jan 28, 2001 for use under BCB5
// the compiler show error 245 "language feature ist not available"
// wie must take a record and under this we can use the static array
procedure SetIdentityMatrix;
begin
IdentityMatrix.A[0,0] := 1.0; IdentityMatrix.A[0,1] := 0.0; IdentityMatrix.A[0,2] := 0.0;
IdentityMatrix.A[1,0] := 0.0; IdentityMatrix.A[1,1] := 1.0; IdentityMatrix.A[1,2] := 0.0;
IdentityMatrix.A[2,0] := 0.0; IdentityMatrix.A[2,1] := 0.0; IdentityMatrix.A[2,2] := 1.0;
end;
//==============================================================================
// Initialization and Finalization
//==============================================================================
initialization
SetIdentityMatrix;
SetGamma(0.7);
end.
