doublecmd/components/Image32/source/Img32.Draw.pas
2022-12-10 12:06:55 +03:00

2162 lines
66 KiB
ObjectPascal

unit Img32.Draw;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.3 *
* Date : 27 September 2022 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2021 *
* *
* Purpose : Polygon renderer for TImage32 *
* *
* License : Use, modification & distribution is subject to *
* Boost Software License Ver 1 *
* http://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
{.$DEFINE MemCheck} //for debugging only (adds a minimal cost to performance)
uses
SysUtils, Classes, Types, Math, Img32, Img32.Vector;
type
TFillRule = Img32.Vector.TFillRule;
//TGradientColor: used internally by both
//TLinearGradientRenderer and TRadialGradientRenderer
TGradientColor = record
offset: double;
color: TColor32;
end;
TArrayOfGradientColor = array of TGradientColor;
TGradientFillStyle = (gfsClamp, gfsMirror, gfsRepeat);
//TBoundsProc: Function template for TCustomRenderer.
TBoundsProc = function(dist, colorsCnt: integer): integer;
TBoundsProcD = function(dist: double; colorsCnt: integer): integer;
TImage32ChangeProc = procedure of object;
//TCustomRenderer: can accommodate pixels of any size
TCustomRenderer = class {$IFDEF ABSTRACT_CLASSES} abstract {$ENDIF}
private
fImgWidth : integer;
fImgHeight : integer;
fImgBase : Pointer;
fCurrY : integer;
fCurrLinePtr : Pointer;
fPixelSize : integer;
fChangeProc : TImage32ChangeProc;
protected
procedure NotifyChange;
function Initialize(imgBase: Pointer;
imgWidth, imgHeight, pixelSize: integer): Boolean; overload; virtual;
function Initialize(targetImage: TImage32): Boolean; overload; virtual;
function GetDstPixel(x,y: integer): Pointer;
//RenderProc: x & y refer to pixel coords in the destination image and
//where x1 is the start (and left) and x2 is the end of the render
procedure RenderProc(x1, x2, y: integer; alpha: PByte); virtual; abstract;
property ImgWidth: integer read fImgWidth;
property ImgHeight: integer read fImgHeight;
property ImgBase: Pointer read fImgBase;
property PixelSize: integer read fPixelSize;
end;
TColorRenderer = class(TCustomRenderer)
private
fAlpha: Byte;
fColor: TColor32;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
constructor Create(color: TColor32 = clNone32);
procedure SetColor(value: TColor32);
end;
TAliasedColorRenderer = class(TCustomRenderer)
private
fColor: TColor32;
protected
function Initialize(targetImage: TImage32): Boolean; override;
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
public
constructor Create(color: TColor32 = clNone32);
end;
TEraseRenderer = class(TCustomRenderer)
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
end;
TInverseRenderer = class(TCustomRenderer)
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
end;
TImageRenderer = class(TCustomRenderer)
private
fImage : TImage32;
fOffset : TPoint;
fBrushPixel : PARGB;
fLastYY : integer;
fMirrorY : Boolean;
fBoundsProc : TBoundsProc;
function GetFirstBrushPixel(x, y: integer): PARGB;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
constructor Create(tileFillStyle: TTileFillStyle = tfsRepeat;
brushImage: TImage32 = nil);
destructor Destroy; override;
procedure SetTileFillStyle(value: TTileFillStyle);
property Image: TImage32 read fImage;
property Offset: TPoint read fOffset write fOffset;
end;
//TCustomGradientRenderer is also an abstract class
TCustomGradientRenderer = class(TCustomRenderer)
private
fBoundsProc : TBoundsProc;
fGradientColors : TArrayOfGradientColor;
protected
fColors : TArrayOfColor32;
fColorsCnt : integer;
procedure SetGradientFillStyle(value: TGradientFillStyle); virtual;
public
constructor Create;
procedure SetParameters(startColor, endColor: TColor32;
gradFillStyle: TGradientFillStyle = gfsClamp); virtual;
procedure InsertColorStop(offsetFrac: double; color: TColor32);
procedure Clear;
end;
TLinearGradientRenderer = class(TCustomGradientRenderer)
private
fStartPt : TPointD;
fEndPt : TPointD;
fPerpendicOffsets: TArrayOfInteger;
fIsVert : Boolean;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
procedure SetParameters(const startPt, endPt: TPointD;
startColor, endColor: TColor32;
gradFillStyle: TGradientFillStyle = gfsClamp); reintroduce;
end;
TRadialGradientRenderer = class(TCustomGradientRenderer)
private
fCenterPt : TPointD;
fScaleX : double;
fScaleY : double;
fColors : TArrayOfColor32;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
procedure SetParameters(const focalRect: TRect;
innerColor, outerColor: TColor32;
gradientFillStyle: TGradientFillStyle = gfsClamp); reintroduce;
end;
TSvgRadialGradientRenderer = class(TCustomGradientRenderer)
private
fA, fB : double;
fAA, fBB : double;
fCenterPt : TPointD;
fFocusPt : TPointD;
fBoundsProcD : TBoundsProcD;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
procedure SetParameters(const ellipseRect: TRect;
const focus: TPoint; innerColor, outerColor: TColor32;
gradientFillStyle: TGradientFillStyle = gfsClamp); reintroduce;
end;
//Barycentric rendering colorizes inside triangles
TBarycentricRenderer = class(TCustomRenderer)
private
a: TPointD;
c1, c2, c3: TARGB;
v0, v1: TPointD;
d00, d01, d11, invDenom: double;
function GetColor(const pt: TPointD): TColor32;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
public
procedure SetParameters(const a, b, c: TPointD; c1, c2, c3: TColor32);
end;
///////////////////////////////////////////////////////////////////////////
// DRAWING FUNCTIONS
///////////////////////////////////////////////////////////////////////////
procedure DrawPoint(img: TImage32; const pt: TPointD;
radius: double; color: TColor32); overload;
procedure DrawPoint(img: TImage32; const pt: TPointD;
radius: double; renderer: TCustomRenderer); overload;
procedure DrawPoint(img: TImage32; const points: TPathD;
radius: double; color: TColor32); overload;
procedure DrawPoint(img: TImage32; const paths: TPathsD;
radius: double; color: TColor32); overload;
procedure DrawLine(img: TImage32;
const pt1, pt2: TPointD; lineWidth: double; color: TColor32); overload;
procedure DrawLine(img: TImage32;
const line: TPathD; lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
miterLimit: double = 2); overload;
procedure DrawLine(img: TImage32;
const line: TPathD; lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
miterLimit: double = 2); overload;
procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
miterLimit: double = 2); overload;
procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
miterLimit: double = 2); overload;
procedure DrawInvertedLine(img: TImage32;
const line: TPathD; lineWidth: double;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawInvertedLine(img: TImage32;
const lines: TPathsD; lineWidth: double;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawDashedLine(img: TImage32; const line: TPathD;
dashPattern: TArrayOfInteger; patternOffset: PDouble;
lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
dashPattern: TArrayOfInteger; patternOffset: PDouble;
lineWidth: double; color: TColor32; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawDashedLine(img: TImage32; const line: TPathD;
dashPattern: TArrayOfInteger; patternOffset: PDouble;
lineWidth: double; renderer: TCustomRenderer; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
dashPattern: TArrayOfInteger; patternOffset: PDouble;
lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawInvertedDashedLine(img: TImage32;
const line: TPathD; dashPattern: TArrayOfInteger;
patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawInvertedDashedLine(img: TImage32;
const lines: TPathsD; dashPattern: TArrayOfInteger;
patternOffset: PDouble; lineWidth: double;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawPolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; color: TColor32); overload;
procedure DrawPolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; renderer: TCustomRenderer); overload;
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32); overload;
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; renderer: TCustomRenderer); overload;
// 'Clear Type' text rendering is quite useful for low resolution
// displays (96 ppi). However it's of little to no benefit on higher
// resolution displays and becomes unnecessary overhead. See also:
// https://en.wikipedia.org/wiki/Subpixel_rendering
// https://www.grc.com/ctwhat.htm
// https://www.grc.com/cttech.htm
procedure DrawPolygon_ClearType(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32; backColor: TColor32 = clWhite32);
///////////////////////////////////////////////////////////////////////////
// MISCELLANEOUS FUNCTIONS
///////////////////////////////////////////////////////////////////////////
procedure ErasePolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule); overload;
procedure ErasePolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule); overload;
//Both DrawBoolMask and DrawAlphaMask require
//'mask' length to equal 'img' width * height
procedure DrawBoolMask(img: TImage32;
const mask: TArrayOfByte; color: TColor32 = clBlack32);
procedure DrawAlphaMask(img: TImage32;
const mask: TArrayOfByte; color: TColor32 = clBlack32);
procedure Rasterize(const paths: TPathsD;
const clipRec: TRect; fillRule: TFillRule; renderer: TCustomRenderer);
implementation
{$IFDEF MemCheck}
resourcestring
sMemCheckError = 'Img32.Draw: Memory allocation error';
{$ENDIF}
type
//A horizontal scanline contains any number of line fragments. A fragment
//can be a number of pixels wide but it can't be more than one pixel high.
TFragment = record
botX, topX, dy, dydx: double;
end;
TFragmentArray = array[0 .. (Maxint div SizeOf(TFragment)) -1] of TFragment;
PFragments = ^TFragmentArray;
PFragment = ^TFragment;
TScanLine = record
Y: integer;
minX, maxX: integer;
fragCnt: integer;
{$IFDEF MemCheck} total: integer; {$ENDIF}
fragments: PFragments;
end;
PScanline = ^TScanline;
TArrayOfScanline = array of TScanline;
//------------------------------------------------------------------------------
// ApplyClearType (see DrawPolygon_ClearType below)
//------------------------------------------------------------------------------
type
PArgbs = ^TArgbs;
TArgbs = array [0.. (Maxint div SizeOf(TARGB)) -1] of TARGB;
procedure ApplyClearType(img: TImage32; textColor: TColor32 = clBlack32;
bkColor: TColor32 = clWhite32);
const
centerWeighting = 5; //0 <= centerWeighting <= 25
var
h, w: integer;
src, dst: PARGB;
srcArr: PArgbs;
fgColor: TARGB absolute textColor;
bgColor: TARGB absolute bkColor;
diff_R, diff_G, diff_B: integer;
bg8_R, bg8_G, bg8_B: integer;
rowBuffer: TArrayOfARGB;
primeTbl, nearTbl, FarTbl: PByteArray;
begin
// Precondition: the background to text drawn onto 'img' must be transparent
// 85 + (2 * 57) + (2 * 28) == 255
primeTbl := PByteArray(@MulTable[85 + centerWeighting *2]);
nearTbl := PByteArray(@MulTable[57]);
farTbl := PByteArray(@MulTable[28 - centerWeighting]);
SetLength(rowBuffer, img.Width +4);
for h := 0 to img.Height -1 do
begin
//each row of the image is copied into a temporary buffer ...
//noting that while 'dst' (img.Pixels) is initially the source
//it will later be destination (during image compression).
dst := PARGB(@img.Pixels[h * img.Width]);
src := PARGB(@rowBuffer[2]);
Move(dst^, src^, img.Width * SizeOf(TColor32));
srcArr := PArgbs(rowBuffer);
//using this buffer compress the image ...
w := 2;
while w < img.Width do
begin
dst.R := primeTbl[srcArr[w].A] +
nearTbl[srcArr[w-1].A] + farTbl[srcArr[w-2].A] +
nearTbl[srcArr[w+1].A] + farTbl[srcArr[w+2].A];
inc(w);
dst.G := primeTbl[srcArr[w].A] +
nearTbl[srcArr[w-1].A] + farTbl[srcArr[w-2].A] +
nearTbl[srcArr[w+1].A] + farTbl[srcArr[w+2].A];
inc(w);
dst.B := primeTbl[srcArr[w].A] +
nearTbl[srcArr[w-1].A] + farTbl[srcArr[w-2].A] +
nearTbl[srcArr[w+1].A] + farTbl[srcArr[w+2].A];
inc(w);
dst.A := 255;
inc(dst);
end;
end;
//Following compression the right 2/3 of the image is redundant
img.Crop(Types.Rect(0,0, img.Width div 3, img.Height));
//currently text is white and the background is black
//so blend in the text and background colors ...
diff_R := fgColor.R - bgColor.R;
diff_G := fgColor.G - bgColor.G;
diff_B := fgColor.B - bgColor.B;
bg8_R := bgColor.R shl 8;
bg8_G := bgColor.G shl 8;
bg8_B := bgColor.B shl 8;
dst := PARGB(img.PixelBase);
for h := 0 to img.Width * img.Height -1 do
begin
if dst.R = 0 then
dst.Color := bkColor
else
begin
//blend front (text) and background colors ...
dst.R := (bg8_R + diff_R * dst.R) shr 8;
dst.G := (bg8_G + diff_G * dst.G) shr 8;
dst.B := (bg8_B + diff_B * dst.B) shr 8;
end;
inc(dst);
end;
end;
//------------------------------------------------------------------------------
// Other miscellaneous functions
//------------------------------------------------------------------------------
////__Trunc: An efficient Trunc() algorithm (ie rounds toward zero)
//function __Trunc(val: double): integer; {$IFDEF INLINE} inline; {$ENDIF}
//var
// exp: integer;
// i64: UInt64 absolute val;
//begin
// //https://en.wikipedia.org/wiki/Double-precision_floating-point_format
// Result := 0;
// if i64 = 0 then Exit;
// exp := Integer(Cardinal(i64 shr 52) and $7FF) - 1023;
// //nb: when exp == 1024 then val == INF or NAN.
// if exp < 0 then Exit;
// Result := ((i64 and $1FFFFFFFFFFFFF) shr (52-exp)) or (1 shl exp);
// if val < 0 then Result := -Result;
//end;
//------------------------------------------------------------------------------
function ClampByte(val: double): byte; {$IFDEF INLINE} inline; {$ENDIF}
begin
if val < 0 then result := 0
else if val > 255 then result := 255
else result := Round(val);
end;
//------------------------------------------------------------------------------
function GetPixel(current: PARGB; delta: integer): PARGB;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result := current;
inc(Result, delta);
end;
//------------------------------------------------------------------------------
function ReverseColors(const colors: TArrayOfGradientColor): TArrayOfGradientColor;
var
i, highI: integer;
begin
highI := High(colors);
SetLength(result, highI +1);
for i := 0 to highI do
begin
result[i].color := colors[highI -i].color;
result[i].offset := 1 - colors[highI -i].offset;
end;
end;
//------------------------------------------------------------------------------
procedure SwapColors(var color1, color2: TColor32);
var
c: TColor32;
begin
c := color1;
color1 := color2;
color2 := c;
end;
//------------------------------------------------------------------------------
procedure SwapPoints(var point1, point2: TPoint); overload;
var
pt: TPoint;
begin
pt := point1;
point1 := point2;
point2 := pt;
end;
//------------------------------------------------------------------------------
procedure SwapPoints(var point1, point2: TPointD); overload;
var
pt: TPointD;
begin
pt := point1;
point1 := point2;
point2 := pt;
end;
//------------------------------------------------------------------------------
function ClampQ(q, endQ: integer): integer;
begin
if q < 0 then result := 0
else if q >= endQ then result := endQ -1
else result := q;
end;
//------------------------------------------------------------------------------
function ClampD(d: double; colorCnt: integer): integer;
begin
dec(colorCnt);
if d < 0 then result := 0
else if d >= 1 then result := colorCnt
else result := Round(d * colorCnt);
end;
//------------------------------------------------------------------------------
function MirrorQ(q, endQ: integer): integer;
begin
result := q mod endQ;
if (result < 0) then result := -result;
if Odd(q div endQ) then
result := (endQ -1) - result;
end;
//------------------------------------------------------------------------------
function MirrorD(d: double; colorCnt: integer): integer;
begin
dec(colorCnt);
if Odd(Round(d)) then
result := Round((1 - frac(d)) * colorCnt) else
result := Round(frac(d) * colorCnt);
end;
//------------------------------------------------------------------------------
function RepeatQ(q, endQ: integer): integer;
begin
if (q < 0) or (q >= endQ) then
begin
endQ := Abs(endQ);
result := q mod endQ;
if result < 0 then inc(result, endQ);
end
else result := q;
end;
//------------------------------------------------------------------------------
function SoftRptQ(q, endQ: integer): integer;
begin
if (q < 0) then
result := endQ + (q mod endQ) else
result := (q mod endQ);
if result = 0 then result := endQ div 2;
end;
//------------------------------------------------------------------------------
function RepeatD(d: double; colorCnt: integer): integer;
begin
dec(colorCnt);
if (d < 0) then
result := Round((1 + frac(d)) * colorCnt) else
result := Round(frac(d) * colorCnt);
end;
//------------------------------------------------------------------------------
function BlendColorUsingMask(bgColor, fgColor: TColor32; mask: Byte): TColor32;
var
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
res: TARGB absolute Result;
R, invR: PByteArray;
begin
if fg.A = 0 then
begin
Result := bgColor;
res.A := MulBytes(res.A, not mask);
end
else if bg.A = 0 then
begin
Result := fgColor;
res.A := MulBytes(res.A, mask);
end
else if (mask = 0) then
Result := bgColor
else if (mask = 255) then
Result := fgColor
else
begin
R := PByteArray(@MulTable[mask]);
InvR := PByteArray(@MulTable[not mask]);
res.A := R[fg.A] + InvR[bg.A];
res.R := R[fg.R] + InvR[bg.R];
res.G := R[fg.G] + InvR[bg.G];
res.B := R[fg.B] + InvR[bg.B];
end;
end;
//------------------------------------------------------------------------------
//MakeColorGradient: using the supplied array of TGradientColor,
//create an array of TColor32 of the specified length
function MakeColorGradient(const gradColors: TArrayOfGradientColor;
len: integer): TArrayOfColor32;
var
i,j, lenC: integer;
dist, offset1, offset2, step, pos: double;
color1, color2: TColor32;
begin
lenC := length(gradColors);
if (len = 0) or (lenC < 2) then Exit;
SetLength(result, len);
color2 := gradColors[0].color;
result[0] := color2;
if len = 1 then Exit;
step := 1/(len-1);
pos := step;
offset2 := 0;
i := 1; j := 1;
repeat
offset1 := offset2;
offset2 := gradColors[i].offset;
dist := offset2 - offset1;
color1 := color2;
color2 := gradColors[i].color;
while (pos <= dist) and (j < len) do
begin
result[j] := BlendColorUsingMask(color1, color2, Round(pos/dist * 255));
inc(j);
pos := pos + step;
end;
pos := pos - dist;
inc(i);
until i = lenC;
if j < len then result[j] := result[j-1];
end;
//------------------------------------------------------------------------------
// Rasterize() support functions
//------------------------------------------------------------------------------
procedure AllocateScanlines(const polygons: TPathsD;
var scanlines: TArrayOfScanline; clipBottom, clipRight: integer);
var
i,j, highI, highJ: integer;
y1, y2: integer;
psl: PScanline;
begin
//first count how often each edge intersects with each horizontal scanline
for i := 0 to high(polygons) do
begin
highJ := high(polygons[i]);
if highJ < 2 then continue;
y1 := Round(polygons[i][highJ].Y);
for j := 0 to highJ do
begin
y2 := Round(polygons[i][j].Y);
if y1 < y2 then
begin
//descending (but ignore edges outside the clipping range)
if (y2 >= 0) and (y1 <= clipBottom) then
begin
if (y1 > 0) and (y1 <= clipBottom) then
dec(scanlines[y1 -1].fragCnt);
if y2 >= clipBottom then
inc(scanlines[clipBottom].fragCnt) else
inc(scanlines[y2].fragCnt);
end;
end else
begin
//ascending (but ignore edges outside the clipping range)
if (y1 >= 0) and (y2 <= clipBottom) then
begin
if (y2 > 0) then
dec(scanlines[y2 -1].fragCnt);
if y1 >= clipBottom then
inc(scanlines[clipBottom].fragCnt) else
inc(scanlines[y1].fragCnt);
end;
end;
y1 := y2;
end;
end;
//convert 'count' accumulators into real counts and allocate storage
j := 0;
highI := high(scanlines);
psl := @scanlines[highI];
//'fragments' is a pointer and not a dynamic array because
//dynamic arrays are zero initialized (hence slower than GetMem).
for i := highI downto 0 do
begin
inc(j, psl.fragCnt); //nb: psl.fragCnt may be < 0 here!
if j > 0 then
GetMem(psl.fragments, j * SizeOf(TFragment));
{$IFDEF MemCheck} psl.total := j; {$ENDIF}
psl.fragCnt := 0; //reset for later
psl.minX := clipRight;
psl.maxX := 0;
psl.Y := i;
dec(psl);
end;
end;
//------------------------------------------------------------------------------
procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD;
const scanlines: TArrayOfScanline; const clipRec: TRect);
var
x,y, dx,dy, absDx, dydx, dxdy: double;
i, scanlineY, maxY, maxX: integer;
psl: PScanLine;
pFrag: PFragment;
bot, top: TPointD;
begin
dy := pt1.Y - pt2.Y;
dx := pt2.X - pt1.X;
RectWidthHeight(clipRec, maxX, maxY);
absDx := abs(dx);
if dy > 0 then
begin
//ASCENDING EDGE (+VE WINDING DIR)
if dy < 0.0001 then Exit; //ignore near horizontals
bot := pt1; top := pt2;
//exclude edges that are completely outside the top or bottom clip region
if (top.Y >= maxY) or (bot.Y <= 0) then Exit;
end else
begin
//DESCENDING EDGE (-VE WINDING DIR)
if dy > -0.0001 then Exit; //ignore near horizontals
bot := pt2; top := pt1;
//exclude edges that are completely outside the top or bottom clip region
if (top.Y >= maxY) or (bot.Y <= 0) then Exit;
end;
if absDx < 0.000001 then
begin
//VERTICAL EDGE
top.X := bot.X; //this circumvents v. rare rounding issues.
//exclude vertical edges that are outside the right clip region
//but still update maxX for each scanline the edge passes
if bot.X > maxX then
begin
for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(top.Y)) do
scanlines[i].maxX := maxX;
Exit;
end;
dxdy := 0;
if dy > 0 then dydx := 1 else dydx := -1;
end else
begin
dxdy := dx/dy;
dydx := dy/absDx;
end;
//TRIM EDGES THAT CROSS CLIPPING BOUNDARIES (EXCEPT THE LEFT BOUNDARY)
if bot.X >= maxX then
begin
if top.X >= maxX then
begin
for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(top.Y)) do
scanlines[i].maxX := maxX;
Exit;
end;
//here the edge must be oriented bottom-right to top-left
y := bot.Y - (bot.X - maxX) * Abs(dydx);
for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(y)) do
scanlines[i].maxX := maxX;
bot.Y := y;
if bot.Y <= 0 then Exit;
bot.X := maxX;
end
else if top.X > maxX then
begin
//here the edge must be oriented bottom-left to top-right
y := top.Y + (top.X - maxX) * Abs(dydx);
for i := Min(maxY, Round(y)) downto Max(0, Round(top.Y)) do
scanlines[i].maxX := maxX;
top.Y := y;
if top.Y >= maxY then Exit;
top.X := maxX;
end;
if bot.Y > maxY then
begin
bot.X := bot.X + dxdy * (bot.Y - maxY);
if (bot.X > maxX) then Exit; //nb: no clipping on the left
bot.Y := maxY;
end;
if top.Y < 0 then
begin
top.X := top.X + (dxdy * top.Y);
if (top.X > maxX) then Exit; //nb: no clipping on the left
top.Y := 0;
end;
//SPLIT THE EDGE INTO MULTIPLE SCANLINE FRAGMENTS
scanlineY := Round(bot.Y);
if bot.Y = scanlineY then dec(scanlineY);
//at the lower-most extent of the edge 'split' the first fragment
if scanlineY < 0 then Exit;
psl := @scanlines[scanlineY];
if not assigned(psl.fragments) then Exit; //a very rare event
{$IFDEF MemCheck}
if psl.fragCnt = psl.total then raise Exception.Create(sMemCheckError);
{$ENDIF}
pFrag := @psl.fragments[psl.fragCnt];
inc(psl.fragCnt);
pFrag.botX := bot.X;
if scanlineY <= top.Y then
begin
//the whole edge is within 1 scanline
pFrag.topX := top.X;
pFrag.dy := bot.Y - top.Y;
pFrag.dydx := dydx;
Exit;
end;
x := bot.X + (bot.Y - scanlineY) * dxdy;
pFrag.topX := x;
pFrag.dy := bot.Y - scanlineY;
pFrag.dydx := dydx;
//'split' subsequent fragments until the top fragment
dec(psl);
while psl.Y > top.Y do
begin
{$IFDEF MemCheck}
if psl.fragCnt = psl.total then raise Exception.Create(sMemCheckError);
{$ENDIF}
pFrag := @psl.fragments[psl.fragCnt];
inc(psl.fragCnt);
pFrag.botX := x;
x := x + dxdy;
pFrag.topX := x;
pFrag.dy := 1;
pFrag.dydx := dydx;
dec(psl);
end;
//and finally the top fragment
{$IFDEF MemCheck}
if psl.fragCnt = psl.total then raise Exception.Create(sMemCheckError);
{$ENDIF}
pFrag := @psl.fragments[psl.fragCnt];
inc(psl.fragCnt);
pFrag.botX := x;
pFrag.topX := top.X;
pFrag.dy := psl.Y + 1 - top.Y;
pFrag.dydx := dydx;
end;
//------------------------------------------------------------------------------
procedure InitializeScanlines(var polygons: TPathsD;
const scanlines: TArrayOfScanline; const clipRec: TRect);
var
i,j, highJ: integer;
pt1, pt2: PPointD;
begin
for i := 0 to high(polygons) do
begin
highJ := high(polygons[i]);
if highJ < 2 then continue;
pt1 := @polygons[i][highJ];
pt2 := @polygons[i][0];
for j := 0 to highJ do
begin
SplitEdgeIntoFragments(pt1^, pt2^, scanlines, clipRec);
pt1 := pt2;
inc(pt2);
end;
end;
end;
//------------------------------------------------------------------------------
procedure ProcessScanlineFragments(var scanline: TScanLine;
var buffer: TArrayOfDouble);
var
i,j, leftXi,rightXi: integer;
fracX, yy, q, windDir: double;
pd: PDouble;
frag: PFragment;
begin
frag := @scanline.fragments[0];
for i := 1 to scanline.fragCnt do
begin
if frag.botX > frag.topX then
begin
//just swapping botX and topX simplifies code
q := frag.botX;
frag.botX := frag.topX;
frag.topX := q;
end;
leftXi := Max(0, Round(frag.botX));
rightXi := Max(0, Round(frag.topX));
if (leftXi = rightXi) then
begin
if frag.dydx < 0 then windDir := -1.0 else windDir := 1.0;
//the fragment is only one pixel wide
if leftXi < scanline.minX then
scanline.minX := leftXi;
if rightXi > scanline.maxX then
scanline.maxX := rightXi;
pd := @buffer[leftXi];
if (frag.botX <= 0) then
begin
pd^ := pd^ + frag.dy * windDir;
end else
begin
q := (frag.botX + frag.topX) * 0.5 - leftXi;
pd^ := pd^ + (1-q) * frag.dy * windDir;
inc(pd);
pd^ := pd^ + q * frag.dy * windDir;
end;
end else
begin
if leftXi < scanline.minX then
scanline.minX := leftXi;
if rightXi > scanline.maxX then
scanline.maxX := rightXi;
pd := @buffer[leftXi];
//left pixel
fracX := leftXi + 1 - frag.botX;
yy := frag.dydx * fracX;
q := fracX * yy * 0.5;
pd^ := pd^ + q;
q := yy - q;
inc(pd);
//middle pixels
for j := leftXi +1 to rightXi -1 do
begin
pd^ := pd^ + q + frag.dydx * 0.5;
q := frag.dydx * 0.5;
inc(pd);
end;
//right pixel
fracX := frag.topX - rightXi;
yy := fracX * frag.dydx;
pd^ := pd^ + q + (1 - fracX * 0.5) * yy;
inc(pd);
//overflow
pd^ := pd^ + fracX * 0.5 * yy;
end;
inc(frag);
end;
end;
//------------------------------------------------------------------------------
{$IFNDEF TROUNDINGMODE}
type
TRoundingMode = {$IFNDEF FPC}Math.{$ENDIF}TFPURoundingMode;
{$ENDIF}
procedure Rasterize(const paths: TPathsD; const clipRec: TRect;
fillRule: TFillRule; renderer: TCustomRenderer);
var
i,j, xli,xri, maxW, maxH, aa: integer;
clipRec2: TRect;
paths2: TPathsD;
accum: double;
windingAccum: TArrayOfDouble;
byteBuffer: TArrayOfByte;
scanlines: TArrayOfScanline;
scanline: PScanline;
savedRoundMode: TRoundingMode;
begin
//See also https://nothings.org/gamedev/rasterize/
if not assigned(renderer) then Exit;
Types.IntersectRect(clipRec2, clipRec, GetBounds(paths));
if IsEmptyRect(clipRec2) then Exit;
paths2 := OffsetPath(paths, -clipRec2.Left, -clipRec2.Top);
//Delphi's Round() function is *much* faster than its Trunc function, and
//it's even a little faster than the __Trunc function above (except when
//the FastMM4 memory manager is enabled.)
savedRoundMode := SetRoundMode(rmDown);
RectWidthHeight(clipRec2, maxW, maxH);
SetLength(scanlines, maxH +1);
SetLength(windingAccum, maxW +2);
AllocateScanlines(paths2, scanlines, maxH, maxW-1);
InitializeScanlines(paths2, scanlines, clipRec2);
SetLength(byteBuffer, maxW);
if byteBuffer = nil then Exit;
scanline := @scanlines[0];
for i := 0 to high(scanlines) do
begin
if scanline.fragCnt = 0 then
begin
FreeMem(scanline.fragments);
inc(scanline);
Continue;
end;
//process each scanline to fill the winding count accumulation buffer
ProcessScanlineFragments(scanline^, windingAccum);
//it's faster to process only the modified sub-array of windingAccum
xli := scanline.minX;
xri := Min(maxW -1, scanline.maxX +1);
FillChar(byteBuffer[xli], xri - xli +1, 0);
//a 25% weighting has been added to the alpha channel to minimize any
//background bleed-through where polygons join with a common edge.
accum := 0; //winding count accumulator
for j := xli to xri do
begin
accum := accum + windingAccum[j];
case fillRule of
frEvenOdd:
begin
aa := Round(Abs(accum) * 1275) mod 2550; // *5
if aa > 1275 then
byteBuffer[j] := Min(255, (2550 - aa) shr 2) else // /4
byteBuffer[j] := Min(255, aa shr 2); // /4
end;
frNonZero:
begin
byteBuffer[j] := Min(255, Round(Abs(accum) * 318));
end;
{$IFDEF REVERSE_ORIENTATION}
frPositive:
{$ELSE}
frNegative:
{$ENDIF}
begin
if accum > 0.002 then
byteBuffer[j] := Min(255, Round(accum * 318));
end;
{$IFDEF REVERSE_ORIENTATION}
frNegative:
{$ELSE}
frPositive:
{$ENDIF}
begin
if accum < -0.002 then
byteBuffer[j] := Min(255, Round(-accum * 318));
end;
end;
end;
renderer.RenderProc(clipRec2.Left + xli, clipRec2.Left + xri,
clipRec2.Top + i, @byteBuffer[xli]);
//cleanup and deallocate memory
FillChar(windingAccum[xli], (xri - xli +1) * sizeOf(Double), 0);
FreeMem(scanline.fragments);
inc(scanline);
end;
SetRoundMode(savedRoundMode);
end;
//------------------------------------------------------------------------------
// TAbstractRenderer
//------------------------------------------------------------------------------
function TCustomRenderer.Initialize(imgBase: Pointer;
imgWidth, imgHeight, pixelSize: integer): Boolean;
begin
fImgBase := imgBase;
fImgWidth := ImgWidth;
fImgHeight := ImgHeight;
fPixelSize := pixelSize;
fCurrLinePtr := fImgBase;
fCurrY := 0;
result := true;
end;
//------------------------------------------------------------------------------
procedure TCustomRenderer.NotifyChange;
begin
if assigned(fChangeProc) then fChangeProc;
end;
//------------------------------------------------------------------------------
type THackedImage32 = class(TImage32); //exposes protected Changed method.
function TCustomRenderer.Initialize(targetImage: TImage32): Boolean;
begin
fChangeProc := THackedImage32(targetImage).Changed;
with targetImage do
result := Initialize(PixelBase, Width, Height, SizeOf(TColor32));
end;
//------------------------------------------------------------------------------
function TCustomRenderer.GetDstPixel(x, y: integer): Pointer;
begin
if (y <> fCurrY) then
begin
fCurrY := y;
fCurrLinePtr := fImgBase;
inc(PByte(fCurrLinePtr), fCurrY * fImgWidth * fPixelSize);
end;
Result := fCurrLinePtr;
inc(PByte(Result), x * fPixelSize);
end;
//------------------------------------------------------------------------------
// TColorRenderer
//------------------------------------------------------------------------------
constructor TColorRenderer.Create(color: TColor32 = clNone32);
begin
if color <> clNone32 then SetColor(color);
end;
//------------------------------------------------------------------------------
function TColorRenderer.Initialize(targetImage: TImage32): Boolean;
begin
//there's no point rendering if the color is fully transparent
result := (fAlpha > 0) and inherited Initialize(targetImage);
end;
//------------------------------------------------------------------------------
procedure TColorRenderer.SetColor(value: TColor32);
begin
fColor := value and $FFFFFF;
fAlpha := GetAlpha(value);
end;
//------------------------------------------------------------------------------
procedure TColorRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dst: PColor32;
begin
dst := GetDstPixel(x1,y);
for i := x1 to x2 do
begin
//BlendToAlpha is marginally slower than BlendToOpaque but it's used
//here because it's universally applicable.
//Ord() is used here because very old compilers define PByte as a PChar
if Ord(alpha^) > 1 then
dst^ := BlendToAlpha(dst^, ((Ord(alpha^) * fAlpha) shr 8) shl 24 or fColor);
inc(dst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TAliasedColorRenderer
//------------------------------------------------------------------------------
constructor TAliasedColorRenderer.Create(color: TColor32 = clNone32);
begin
fColor := color;
end;
//------------------------------------------------------------------------------
function TAliasedColorRenderer.Initialize(targetImage: TImage32): Boolean;
begin
//there's no point rendering if the color is fully transparent
result := (GetAlpha(fColor) > 0) and
inherited Initialize(targetImage);
end;
//------------------------------------------------------------------------------
procedure TAliasedColorRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dst: PColor32;
begin
dst := GetDstPixel(x1,y);
for i := x1 to x2 do
begin
if Ord(alpha^) > 127 then dst^ := fColor; //ie no blending
inc(dst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TBrushImageRenderer
//------------------------------------------------------------------------------
constructor TImageRenderer.Create(tileFillStyle: TTileFillStyle;
brushImage: TImage32);
begin
fImage := TImage32.Create(brushImage);
SetTileFillStyle(tileFillStyle);
end;
//------------------------------------------------------------------------------
destructor TImageRenderer.Destroy;
begin
fImage.Free;
inherited;
end;
//------------------------------------------------------------------------------
procedure TImageRenderer.SetTileFillStyle(value: TTileFillStyle);
begin
case value of
tfsRepeat: fBoundsProc := RepeatQ;
tfsMirrorHorz: fBoundsProc := MirrorQ;
tfsMirrorVert: fBoundsProc := RepeatQ;
tfsRotate180 : fBoundsProc := MirrorQ;
end;
fMirrorY := value in [tfsMirrorVert, tfsRotate180];
end;
//------------------------------------------------------------------------------
function TImageRenderer.Initialize(targetImage: TImage32): Boolean;
begin
result := inherited Initialize(targetImage) and (not fImage.IsEmpty);
if not result then Exit;
fLastYY := 0;
fBrushPixel := PARGB(fImage.PixelBase);
end;
//------------------------------------------------------------------------------
procedure TImageRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
pDst: PColor32;
pBrush: PARGB;
begin
pDst := GetDstPixel(x1,y);
dec(x1, fOffset.X);
dec(x2, fOffset.X);
dec(y, fOffset.Y);
pBrush := GetFirstBrushPixel(x1, y);
for i := x1 to x2 do
begin
pDst^ := BlendToAlpha(pDst^,
MulBytes(pBrush.A, Ord(alpha^)) shl 24 or (pBrush.Color and $FFFFFF));
inc(pDst); inc(alpha);
pBrush := GetPixel(fBrushPixel, fBoundsProc(i, fImage.Width));
end;
end;
//------------------------------------------------------------------------------
function TImageRenderer.GetFirstBrushPixel(x, y: integer): PARGB;
begin
if fMirrorY then
y := MirrorQ(y, fImage.Height) else
y := RepeatQ(y, fImage.Height);
if y <> fLastYY then
begin
fBrushPixel := PARGB(fImage.PixelRow[y]);
fLastYY := y;
end;
x := fBoundsProc(x, fImage.Width);
result := GetPixel(fBrushPixel, x);
end;
//------------------------------------------------------------------------------
// TGradientRenderer
//------------------------------------------------------------------------------
constructor TCustomGradientRenderer.Create;
begin
fBoundsProc := ClampQ; //default proc
end;
//------------------------------------------------------------------------------
procedure TCustomGradientRenderer.Clear;
begin
fGradientColors := nil;
fColors := nil;
end;
//------------------------------------------------------------------------------
procedure TCustomGradientRenderer.SetGradientFillStyle(value: TGradientFillStyle);
begin
case value of
gfsClamp: fBoundsProc := ClampQ;
gfsMirror: fBoundsProc := MirrorQ;
else fBoundsProc := RepeatQ;
end;
end;
//------------------------------------------------------------------------------
procedure TCustomGradientRenderer.SetParameters(startColor, endColor: TColor32;
gradFillStyle: TGradientFillStyle = gfsClamp);
begin
SetGradientFillStyle(gradFillStyle);
//reset gradient colors if perviously set
SetLength(fGradientColors, 2);
fGradientColors[0].offset := 0;
fGradientColors[0].color := startColor;
fGradientColors[1].offset := 1;
fGradientColors[1].color := endColor;
end;
//------------------------------------------------------------------------------
procedure TCustomGradientRenderer.InsertColorStop(offsetFrac: double; color: TColor32);
var
i, len: integer;
gradColor: TGradientColor;
begin
len := Length(fGradientColors);
//colorstops can only be inserted after calling SetParameters
if len = 0 then Exit;
if offsetFrac < 0 then offsetFrac := 0
else if offsetFrac > 1 then offsetFrac := 1;
if offsetFrac = 0 then
begin
fGradientColors[0].color := color;
Exit;
end
else if offsetFrac = 1 then
begin
fGradientColors[len -1].color := color;
Exit;
end;
gradColor.offset := offsetFrac;
gradColor.color := color;
i := 1;
while (i < len-1) and
(fGradientColors[i].offset <= offsetFrac) do inc(i);
SetLength(fGradientColors, len +1);
Move(fGradientColors[i],
fGradientColors[i+1], (len -i) * SizeOf(TGradientColor));
fGradientColors[i] := gradColor;
end;
//------------------------------------------------------------------------------
// TLinearGradientRenderer
//------------------------------------------------------------------------------
procedure TLinearGradientRenderer.SetParameters(const startPt, endPt: TPointD;
startColor, endColor: TColor32; gradFillStyle: TGradientFillStyle);
begin
inherited SetParameters(startColor, endColor, gradFillStyle);
fStartPt := startPt;
fEndPt := endPt;
end;
//------------------------------------------------------------------------------
function TLinearGradientRenderer.Initialize(targetImage: TImage32): Boolean;
var
i: integer;
dx,dy, dxdy,dydx: double;
begin
result := inherited Initialize(targetImage) and assigned(fGradientColors);
if not result then Exit;
if abs(fEndPt.Y - fStartPt.Y) > abs(fEndPt.X - fStartPt.X) then
begin
//gradient > 45 degrees
if (fEndPt.Y < fStartPt.Y) then
begin
fGradientColors := ReverseColors(fGradientColors);
SwapPoints(fStartPt, fEndPt);
end;
fIsVert := true;
dx := (fEndPt.X - fStartPt.X);
dy := (fEndPt.Y - fStartPt.Y);
dxdy := dx/dy;
fColorsCnt := Ceil(dy + dxdy * (fEndPt.X - fStartPt.X));
fColors := MakeColorGradient(fGradientColors, fColorsCnt);
//get a list of perpendicular offsets for each
SetLength(fPerpendicOffsets, ImgWidth);
//from an imaginary line that's through fStartPt and perpendicular to
//the gradient line, get a list of Y offsets for each X in image width
for i := 0 to ImgWidth -1 do
fPerpendicOffsets[i] := Round(dxdy * (fStartPt.X - i) + fStartPt.Y);
end
else //gradient <= 45 degrees
begin
if (fEndPt.X = fStartPt.X) then
begin
Result := false;
Exit;
end;
if (fEndPt.X < fStartPt.X) then
begin
fGradientColors := ReverseColors(fGradientColors);
SwapPoints(fStartPt, fEndPt);
end;
fIsVert := false;
dx := (fEndPt.X - fStartPt.X);
dy := (fEndPt.Y - fStartPt.Y);
dydx := dy/dx; //perpendicular slope
fColorsCnt := Ceil(dx + dydx * (fEndPt.Y - fStartPt.Y));
fColors := MakeColorGradient(fGradientColors, fColorsCnt);
SetLength(fPerpendicOffsets, ImgHeight);
//from an imaginary line that's through fStartPt and perpendicular to
//the gradient line, get a list of X offsets for each Y in image height
for i := 0 to ImgHeight -1 do
fPerpendicOffsets[i] := Round(dydx * (fStartPt.Y - i) + fStartPt.X);
end;
end;
//------------------------------------------------------------------------------
procedure TLinearGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i, off: integer;
pDst: PColor32;
color: TARGB;
begin
pDst := GetDstPixel(x1,y);
for i := x1 to x2 do
begin
if fIsVert then
begin
//when fIsVert = true, fPerpendicOffsets is an array of Y for each X
off := fPerpendicOffsets[i];
color.Color := fColors[fBoundsProc(y - off, fColorsCnt)];
end else
begin
//when fIsVert = false, fPerpendicOffsets is an array of X for each Y
off := fPerpendicOffsets[y];
color.Color := fColors[fBoundsProc(i - off, fColorsCnt)];
end;
pDst^ := BlendToAlpha(pDst^,
MulBytes(color.A, Ord(alpha^)) shl 24 or (color.Color and $FFFFFF));
inc(pDst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TRadialGradientRenderer
//------------------------------------------------------------------------------
function TRadialGradientRenderer.Initialize(targetImage: TImage32): Boolean;
begin
result := inherited Initialize(targetImage) and (fColorsCnt > 1);
if result then
fColors := MakeColorGradient(fGradientColors, fColorsCnt);
end;
//------------------------------------------------------------------------------
procedure TRadialGradientRenderer.SetParameters(const focalRect: TRect;
innerColor, outerColor: TColor32;
gradientFillStyle: TGradientFillStyle);
var
w,h: integer;
radX,radY: double;
begin
inherited SetParameters(innerColor, outerColor, gradientFillStyle);
fColorsCnt := 0;
if IsEmptyRect(focalRect) then Exit;
fCenterPt.X := (focalRect.Left + focalRect.Right) * 0.5;
fCenterPt.Y := (focalRect.Top + focalRect.Bottom) * 0.5;
RectWidthHeight(focalRect, w, h);
radX := w * 0.5;
radY := h * 0.5;
if radX >= radY then
begin
fScaleX := 1;
fScaleY := radX/radY;
fColorsCnt := Ceil(radX) +1;
end else
begin
fScaleX := radY/radX;
fScaleY := 1;
fColorsCnt := Ceil(radY) +1;
end;
end;
//------------------------------------------------------------------------------
procedure TRadialGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dist: double;
color: TARGB;
pDst: PColor32;
begin
pDst := GetDstPixel(x1,y);
for i := x1 to x2 do
begin
dist := Hypot((y - fCenterPt.Y) *fScaleY, (i - fCenterPt.X) *fScaleX);
color.Color := fColors[fBoundsProc(Round(dist), fColorsCnt)];
pDst^ := BlendToAlpha(pDst^,
MulBytes(color.A, Ord(alpha^)) shl 24 or (color.Color and $FFFFFF));
inc(pDst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TSvgRadialGradientRenderer
//------------------------------------------------------------------------------
function TSvgRadialGradientRenderer.Initialize(targetImage: TImage32): Boolean;
begin
result := inherited Initialize(targetImage) and (fColorsCnt > 1);
if result then
fColors := MakeColorGradient(fGradientColors, fColorsCnt);
end;
//------------------------------------------------------------------------------
procedure TSvgRadialGradientRenderer.SetParameters(const ellipseRect: TRect;
const focus: TPoint; innerColor, outerColor: TColor32;
gradientFillStyle: TGradientFillStyle = gfsClamp);
var
w, h : integer;
begin
inherited SetParameters(innerColor, outerColor);
case gradientFillStyle of
gfsMirror: fBoundsProcD := MirrorD;
gfsRepeat: fBoundsProcD := RepeatD;
else fBoundsProcD := ClampD;
end;
fColorsCnt := 0;
if IsEmptyRect(ellipseRect) then Exit;
fCenterPt := RectD(ellipseRect).MidPoint;
RectWidthHeight(ellipseRect, w, h);
fA := w * 0.5;
fB := h * 0.5;
fFocusPt.X := focus.X - fCenterPt.X;
fFocusPt.Y := focus.Y - fCenterPt.Y;
fColorsCnt := Ceil(Hypot(fA*2, fB*2)) +1;
fAA := fA * fA;
fBB := fB * fB;
end;
//------------------------------------------------------------------------------
procedure TSvgRadialGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
q,m,c, qa,qb,qc,qs: double;
dist, dist2: double;
color: TARGB;
pDst: PColor32;
pt, ellipsePt: TPointD;
begin
//get the left-most pixel to render
pDst := GetDstPixel(x1,y);
pt.X := x1 - fCenterPt.X; pt.Y := y - fCenterPt.Y;
for i := x1 to x2 do
begin
//equation of ellipse = (x*x)/aa + (y*y)/bb = 1
//equation of line = y = mx + c;
if (pt.X = fFocusPt.X) then //vertical line
begin
//let x = pt.X, then y*y = b*b(1 - Sqr(pt.X)/aa)
q := Sqrt(fBB*(1 - Sqr(pt.X)/fAA));
ellipsePt.X := pt.X;
if pt.Y >= fFocusPt.Y then
ellipsePt.Y := q else
ellipsePt.Y := -q;
dist := abs(pt.Y - fFocusPt.Y);
dist2 := abs(ellipsePt.Y - fFocusPt.Y);
if dist2 = 0 then
q := 1 else
q := dist/ dist2;
end else
begin
//using simultaneous equations and substitution
//given y = mx + c
m := (pt.Y - fFocusPt.Y)/(pt.X - fFocusPt.X);
c := pt.Y - m * pt.X;
//given (x*x)/aa + (y*y)/bb = 1
//(x*x)/aa*bb + (y*y) = bb
//bb/aa *(x*x) + Sqr(m*x +c) = bb
//bb/aa *(x*x) + (m*m)*(x*x) + 2*m*x*c +c*c = b*b
//(bb/aa +(m*m)) *(x*x) + 2*m*c*(x) + (c*c) - bb = 0
//solving quadratic equation
qa := (fBB/fAA +(m*m));
qb := 2*m*c;
qc := (c*c) - fBB;
qs := (qb*qb) - 4*qa*qc;
if qs >= 0 then
begin
qs := Sqrt(qs);
if pt.X <= fFocusPt.X then
ellipsePt.X := (-qb -qs)/(2 * qa) else
ellipsePt.X := (-qb +qs)/(2 * qa);
ellipsePt.Y := m * ellipsePt.X + c;
dist := Hypot(pt.X - fFocusPt.X, pt.Y - fFocusPt.Y);
dist2 := Hypot(ellipsePt.X - fFocusPt.X, ellipsePt.Y - fFocusPt.Y);
if dist2 = 0 then
q := 1 else
q := dist/ dist2;
end else
q := 1; //shouldn't happen :)
end;
color.Color := fColors[fBoundsProcD(Abs(q), fColorsCnt)];
pDst^ := BlendToAlpha(pDst^,
MulBytes(color.A, Ord(alpha^)) shl 24 or (color.Color and $FFFFFF));
inc(pDst); pt.X := pt.X + 1; inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TEraseRenderer
//------------------------------------------------------------------------------
procedure TEraseRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dst: PARGB;
begin
dst := PARGB(GetDstPixel(x1,y));
for i := x1 to x2 do
begin
{$IFDEF PBYTE}
dst.A := MulBytes(dst.A, not alpha^);
{$ELSE}
dst.A := MulBytes(dst.A, not Ord(alpha^));
{$ENDIF}
inc(dst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// TInverseRenderer
//------------------------------------------------------------------------------
procedure TInverseRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dst: PARGB;
c: TARGB;
begin
dst := PARGB(GetDstPixel(x1,y));
for i := x1 to x2 do
begin
c.Color := not dst.Color;
c.A := MulBytes(dst.A, Ord(alpha^));
dst.Color := BlendToAlpha(dst.Color, c.Color);
inc(dst); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
procedure TBarycentricRenderer.SetParameters(const a, b, c: TPointD;
c1, c2, c3: TColor32);
begin
self.a := a;
self.c1.Color := c1;
self.c2.Color := c2;
self.c3.Color := c3;
v0.X := b.X - a.X;
v0.Y := b.Y - a.Y;
v1.X := c.X - a.X;
v1.Y := c.Y - a.Y;
d00 := (v0.X * v0.X + v0.Y * v0.Y);
d01 := (v0.X * v1.X + v0.Y * v1.Y);
d11 := (v1.X * v1.X + v1.Y * v1.Y);
invDenom := 1/(d00 * d11 - d01 * d01);
end;
//------------------------------------------------------------------------------
function TBarycentricRenderer.GetColor(const pt: TPointD): TColor32;
var
v2: TPointD;
d20, d21, v, w, u: Double;
res: TARGB absolute Result;
begin
Result := 0;
v2.X := pt.X - a.X;
v2.Y := pt.Y - a.Y;
d20 := (v2.X * v0.X + v2.Y * v0.Y);
d21 := (v2.X * v1.X + v2.Y * v1.Y);
v := (d11 * d20 - d01 * d21) * invDenom;
w := (d00 * d21 - d01 * d20) * invDenom;
u := 1.0 - v - w;
Res.A := ClampByte(c1.A * u + c2.A * v + c3.A * w);
Res.R := ClampByte(c1.R * u + c2.R * v + c3.R * w);
Res.G := ClampByte(c1.G * u + c2.G * v + c3.G * w);
Res.B := ClampByte(c1.B * u + c2.B * v + c3.B * w);
end;
//------------------------------------------------------------------------------
procedure TBarycentricRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
x: integer;
p: PARGB;
c: TARGB;
begin
p := PARGB(fImgBase);
inc(p, y * ImgWidth + x1);
for x := x1 to x2 do
begin
c.Color := GetColor(PointD(x, y));
c.A := c.A * Ord(alpha^) shr 8;
p.Color := BlendToAlpha(p.Color, c.Color);
inc(p); inc(alpha);
end;
end;
//------------------------------------------------------------------------------
// Draw functions
//------------------------------------------------------------------------------
procedure DrawPoint(img: TImage32;
const pt: TPointD; radius: double; color: TColor32);
var
path: TPathD;
begin
if radius <= 1 then
path := Rectangle(pt.X-radius, pt.Y-radius, pt.X+radius, pt.Y+radius) else
path := Ellipse(RectD(pt.X-radius, pt.Y-radius, pt.X+radius, pt.Y+radius));
DrawPolygon(img, path, frEvenOdd, color);
end;
//------------------------------------------------------------------------------
procedure DrawPoint(img: TImage32; const pt: TPointD;
radius: double; renderer: TCustomRenderer);
var
path: TPathD;
begin
path := Ellipse(RectD(pt.X -radius, pt.Y -radius, pt.X +radius, pt.Y +radius));
DrawPolygon(img, path, frEvenOdd, renderer);
end;
//------------------------------------------------------------------------------
procedure DrawPoint(img: TImage32; const points: TPathD;
radius: double; color: TColor32);
var
i: integer;
begin
for i := 0 to high(points) do
DrawPoint(img, points[i], radius, color);
end;
//------------------------------------------------------------------------------
procedure DrawPoint(img: TImage32; const paths: TPathsD;
radius: double; color: TColor32);
var
i: integer;
begin
for i := 0 to high(paths) do
DrawPoint(img, paths[i], radius, color);
end;
//------------------------------------------------------------------------------
procedure DrawLine(img: TImage32;
const pt1, pt2: TPointD; lineWidth: double; color: TColor32);
var
lines: TPathsD;
begin
setLength(lines, 1);
setLength(lines[0], 2);
lines[0][0] := pt1;
lines[0][1] := pt2;
DrawLine(img, lines, lineWidth, color, esRound);
end;
//------------------------------------------------------------------------------
procedure DrawLine(img: TImage32; const line: TPathD; lineWidth: double;
color: TColor32; endStyle: TEndStyle; joinStyle: TJoinStyle;
miterLimit: double);
var
lines: TPathsD;
begin
setLength(lines, 1);
lines[0] := line;
DrawLine(img, lines, lineWidth, color, endStyle, joinStyle, miterLimit);
end;
//------------------------------------------------------------------------------
procedure DrawLine(img: TImage32; const line: TPathD; lineWidth: double;
renderer: TCustomRenderer; endStyle: TEndStyle; joinStyle: TJoinStyle;
miterLimit: double);
var
lines: TPathsD;
begin
setLength(lines, 1);
lines[0] := line;
DrawLine(img, lines, lineWidth, renderer, endStyle, joinStyle, miterLimit);
end;
//------------------------------------------------------------------------------
procedure DrawInvertedLine(img: TImage32; const line: TPathD;
lineWidth: double; endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto);
var
lines: TPathsD;
begin
setLength(lines, 1);
lines[0] := line;
DrawInvertedLine(img, lines, lineWidth, endStyle, joinStyle);
end;
//------------------------------------------------------------------------------
procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle; miterLimit: double);
var
lines2: TPathsD;
cr: TCustomRenderer;
begin
if not assigned(lines) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
lines2 := Outline(lines, lineWidth, joinStyle, endStyle, miterLimit);
if img.AntiAliased then
cr := TColorRenderer.Create(color) else
cr := TAliasedColorRenderer.Create(color);
try
if cr.Initialize(img) then
begin
Rasterize(lines2, img.bounds, frNonZero, cr);
cr.NotifyChange;
end;
finally
cr.free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle;
miterLimit: double);
var
lines2: TPathsD;
begin
if (not assigned(lines)) or (not assigned(renderer)) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
lines2 := Outline(lines, lineWidth, joinStyle, endStyle, miterLimit);
if renderer.Initialize(img) then
begin
Rasterize(lines2, img.bounds, frNonZero, renderer);
renderer.NotifyChange;
end;
end;
//------------------------------------------------------------------------------
procedure DrawInvertedLine(img: TImage32;
const lines: TPathsD; lineWidth: double;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto);
var
lines2: TPathsD;
ir: TInverseRenderer;
begin
if not assigned(lines) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
lines2 := Outline(lines, lineWidth, joinStyle, endStyle, 2);
ir := TInverseRenderer.Create;
try
if ir.Initialize(img) then
begin
Rasterize(lines2, img.bounds, frNonZero, ir);
ir.NotifyChange;
end;
finally
ir.free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const line: TPathD;
dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
color: TColor32; endStyle: TEndStyle; joinStyle: TJoinStyle);
var
lines: TPathsD;
cr: TColorRenderer;
i: integer;
begin
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
if not assigned(line) then exit;
for i := 0 to High(dashPattern) do
if dashPattern[i] <= 0 then dashPattern[i] := 1;
lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset);
if Length(lines) = 0 then Exit;
case joinStyle of
jsSquare, jsMiter:
endStyle := esSquare;
jsRound:
endStyle := esRound;
else
endStyle := esButt;
end;
lines := Outline(lines, lineWidth, joinStyle, endStyle);
cr := TColorRenderer.Create(color);
try
if cr.Initialize(img) then
begin
Rasterize(lines, img.bounds, frNonZero, cr);
cr.NotifyChange;
end;
finally
cr.free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
color: TColor32; endStyle: TEndStyle; joinStyle: TJoinStyle);
var
i: integer;
begin
if not assigned(lines) then exit;
for i := 0 to high(lines) do
DrawDashedLine(img, lines[i],
dashPattern, patternOffset, lineWidth, color, endStyle, joinStyle);
end;
//------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const line: TPathD;
dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
renderer: TCustomRenderer; endStyle: TEndStyle; joinStyle: TJoinStyle);
var
i: integer;
lines: TPathsD;
begin
if (not assigned(line)) or (not assigned(renderer)) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
for i := 0 to High(dashPattern) do
if dashPattern[i] <= 0 then dashPattern[i] := 1;
lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset);
if Length(lines) = 0 then Exit;
lines := Outline(lines, lineWidth, joinStyle, endStyle);
if renderer.Initialize(img) then
begin
Rasterize(lines, img.bounds, frNonZero, renderer);
renderer.NotifyChange;
end;
end;
//------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
renderer: TCustomRenderer; endStyle: TEndStyle; joinStyle: TJoinStyle);
var
i: integer;
begin
if not assigned(lines) then exit;
for i := 0 to high(lines) do
DrawDashedLine(img, lines[i],
dashPattern, patternOffset, lineWidth, renderer, endStyle, joinStyle);
end;
//------------------------------------------------------------------------------
procedure DrawInvertedDashedLine(img: TImage32;
const line: TPathD; dashPattern: TArrayOfInteger;
patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto);
var
i: integer;
lines: TPathsD;
renderer: TInverseRenderer;
begin
if not assigned(line) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
for i := 0 to High(dashPattern) do
if dashPattern[i] <= 0 then dashPattern[i] := 1;
lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset);
if Length(lines) = 0 then Exit;
lines := Outline(lines, lineWidth, joinStyle, endStyle);
renderer := TInverseRenderer.Create;
try
if renderer.Initialize(img) then
begin
Rasterize(lines, img.bounds, frNonZero, renderer);
renderer.NotifyChange;
end;
finally
renderer.Free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawInvertedDashedLine(img: TImage32;
const lines: TPathsD; dashPattern: TArrayOfInteger;
patternOffset: PDouble; lineWidth: double;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto);
var
i: integer;
begin
if not assigned(lines) then exit;
for i := 0 to high(lines) do
DrawInvertedDashedLine(img, lines[i],
dashPattern, patternOffset, lineWidth, endStyle, joinStyle);
end;
//------------------------------------------------------------------------------
procedure DrawPolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; color: TColor32);
var
polygons: TPathsD;
begin
if not assigned(polygon) then exit;
setLength(polygons, 1);
polygons[0] := polygon;
DrawPolygon(img, polygons, fillRule, color);
end;
//------------------------------------------------------------------------------
procedure DrawPolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; renderer: TCustomRenderer);
var
polygons: TPathsD;
begin
if (not assigned(polygon)) or (not assigned(renderer)) then exit;
setLength(polygons, 1);
polygons[0] := polygon;
if renderer.Initialize(img) then
begin
Rasterize(polygons, img.Bounds, fillRule, renderer);
renderer.NotifyChange;
end;
end;
//------------------------------------------------------------------------------
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32);
var
cr: TCustomRenderer;
begin
if not assigned(polygons) then exit;
if img.AntiAliased then
cr := TColorRenderer.Create(color) else
cr := TAliasedColorRenderer.Create(color);
try
if cr.Initialize(img) then
begin
Rasterize(polygons, img.bounds, fillRule, cr);
cr.NotifyChange;
end;
finally
cr.free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; renderer: TCustomRenderer);
begin
if (not assigned(polygons)) or (not assigned(renderer)) then exit;
if renderer.Initialize(img) then
begin
Rasterize(polygons, img.bounds, fillRule, renderer);
renderer.NotifyChange;
end;
end;
//------------------------------------------------------------------------------
procedure DrawPolygon_ClearType(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32; backColor: TColor32);
var
w, h: integer;
tmpImg: TImage32;
rec: TRect;
tmpPolygons: TPathsD;
cr: TColorRenderer;
begin
if not assigned(polygons) then exit;
rec := GetBounds(polygons);
RectWidthHeight(rec, w, h);
tmpImg := TImage32.Create(w *3, h);
try
tmpPolygons := OffsetPath(polygons, -rec.Left, -rec.Top);
tmpPolygons := ScalePath(tmpPolygons, 3, 1);
cr := TColorRenderer.Create(clBlack32);
try
if cr.Initialize(tmpImg) then
Rasterize(tmpPolygons, tmpImg.bounds, fillRule, cr);
finally
cr.Free;
end;
ApplyClearType(tmpImg, color, backColor);
img.CopyBlend(tmpImg, tmpImg.Bounds, rec, BlendToAlpha);
finally
tmpImg.Free;
end;
end;
//------------------------------------------------------------------------------
procedure ErasePolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule);
var
polygons: TPathsD;
begin
if not assigned(polygon) then exit;
setLength(polygons, 1);
polygons[0] := polygon;
ErasePolygon(img, polygons, fillRule);
end;
//------------------------------------------------------------------------------
procedure ErasePolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule);
var
er: TEraseRenderer;
begin
er := TEraseRenderer.Create;
try
if er.Initialize(img) then
begin
Rasterize(polygons, img.bounds, fillRule, er);
er.NotifyChange;
end;
finally
er.Free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawBoolMask(img: TImage32; const mask: TArrayOfByte; color: TColor32);
var
i, len: integer;
pc: PColor32;
pb: PByte;
begin
len := Length(mask);
if (len = 0) or (len <> img.Width * img.Height) then Exit;
pc := img.PixelBase;
pb := @mask[0];
for i := 0 to len -1 do
begin
{$IFDEF PBYTE}
if pb^ > 0 then
{$ELSE}
if pb^ > #0 then
{$ENDIF}
pc^ := color else
pc^ := clNone32;
inc(pc); inc(pb);
end;
end;
//------------------------------------------------------------------------------
procedure DrawAlphaMask(img: TImage32; const mask: TArrayOfByte; color: TColor32);
var
i, len: integer;
pc: PColor32;
pb: PByte;
begin
len := Length(mask);
if (len = 0) or (len <> img.Width * img.Height) then Exit;
color := color and $FFFFFF; //strip alpha value
pc := img.PixelBase;
pb := @mask[0];
for i := 0 to len -1 do
begin
{$IFDEF PBYTE}
if pb^ > 0 then
pc^ := color or pb^ shl 24 else
pc^ := clNone32;
{$ELSE}
if pb^ > #0 then
pc^ := color or Ord(pb^) shl 24 else
pc^ := clNone32;
{$ENDIF}
inc(pc); inc(pb);
end;
end;
//------------------------------------------------------------------------------
end.