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

3070 lines
93 KiB
ObjectPascal

unit Img32.Extra;
(*******************************************************************************
* Author : Angus Johnson *
* Version : 4.3 *
* Date : 27 September 2022 *
* Website : http://www.angusj.com *
* Copyright : Angus Johnson 2019-2021 *
* *
* Purpose : Miscellaneous routines for TImage32 that *
* : don't obviously belong in other modules. *
* *
* License : Use, modification & distribution is subject to *
* Boost Software License Ver 1 *
* http://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
uses
SysUtils, Classes, Math, Types,
Img32, Img32.Draw, Img32.Vector;
type
TButtonShape = (bsRound, bsSquare, bsDiamond);
TButtonAttribute = (baShadow, ba3D, baEraseBeneath);
TButtonAttributes = set of TButtonAttribute;
type
PPt = ^TPt;
TPt = record
pt : TPointD;
vec : TPointD;
len : double;
next : PPt;
prev : PPt;
end;
TFitCurveContainer = class
private
ppts : PPt;
solution : TPathD;
tolSqrd : double;
function Count(first, last: PPt): integer;
function AddPt(const pt: TPointD): PPt;
procedure Clear;
function ComputeLeftTangent(p: PPt): TPointD;
function ComputeRightTangent(p: PPt): TPointD;
function ComputeCenterTangent(p: PPt): TPointD;
function ChordLengthParameterize(
first: PPt; cnt: integer): TArrayOfDouble;
function GenerateBezier(first, last: PPt; cnt: integer;
const u: TArrayOfDouble; const firstTan, lastTan: TPointD): TPathD;
function Reparameterize(first: PPt; cnt: integer;
const u: TArrayOfDouble; const bezier: TPathD): TArrayOfDouble;
function NewtonRaphsonRootFind(const q: TPathD;
const pt: TPointD; u: double): double;
function ComputeMaxErrorSqrd(first, last: PPt;
const bezier: TPathD; const u: TArrayOfDouble;
out SplitPoint: PPt): double;
function FitCubic(first, last: PPt;
firstTan, lastTan: TPointD): Boolean;
procedure AppendSolution(const bezier: TPathD);
public
function FitCurve(const path: TPathD; closed: Boolean;
tolerance: double; minSegLength: double): TPathD;
end;
procedure DrawEdge(img: TImage32; const rec: TRect;
topLeftColor, bottomRightColor: TColor32; penWidth: double = 1.0); overload;
procedure DrawEdge(img: TImage32; const rec: TRectD;
topLeftColor, bottomRightColor: TColor32; penWidth: double = 1.0); overload;
procedure DrawEdge(img: TImage32; const path: TPathD;
topLeftColor, bottomRightColor: TColor32;
penWidth: double = 1.0; closePath: Boolean = true); overload;
//DrawShadowRect: is **much** faster than DrawShadow
procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double;
angle: double = angle45; color: TColor32 = $80000000);
procedure DrawShadow(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; depth: double; angleRads: double = angle45;
color: TColor32 = $80000000; cutoutInsideShadow: Boolean = false); overload;
procedure DrawShadow(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; depth: double; angleRads: double = angle45;
color: TColor32 = $80000000; cutoutInsideShadow: Boolean = false); overload;
procedure DrawGlow(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; color: TColor32; blurRadius: integer); overload;
procedure DrawGlow(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32; blurRadius: integer); overload;
procedure TileImage(img: TImage32; const rec: TRect; tile: TImage32); overload;
procedure TileImage(img: TImage32; const rec: TRect; tile: TImage32; const tileRec: TRect); overload;
//FloodFill: If no CompareFunc is provided, FloodFill will fill whereever
//adjoining pixels exactly match the starting pixel - Point(x,y).
procedure FloodFill(img: TImage32; x, y: Integer; newColor: TColor32;
tolerance: Byte = 0; compareFunc: TCompareFunctionEx = nil);
procedure FastGaussianBlur(img: TImage32;
const rec: TRect; stdDev: integer; repeats: integer); overload;
procedure FastGaussianBlur(img: TImage32;
const rec: TRect; stdDevX, stdDevY: integer; repeats: integer); overload;
procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer);
//Emboss: A smaller radius is sharper. Increasing depth increases contrast.
//Luminance changes grayscale balance (unless preserveColor = true)
procedure Emboss(img: TImage32; radius: Integer = 1; depth: Integer = 10;
luminance: Integer = 75; preserveColor: Boolean = false);
//Sharpen: Radius range is 1 - 10; amount range is 1 - 50.<br>
//see https://en.wikipedia.org/wiki/Unsharp_masking
procedure Sharpen(img: TImage32; radius: Integer = 2; amount: Integer = 10);
//HatchBackground: Assumes the current image is semi-transparent.
procedure HatchBackground(img: TImage32; color1: TColor32 = clWhite32;
color2: TColor32= $FFE8E8E8; hatchSize: Integer = 10); overload;
procedure HatchBackground(img: TImage32; const rec: TRect;
color1: TColor32 = clWhite32; color2: TColor32= $FFE8E8E8;
hatchSize: Integer = 10); overload;
procedure GridBackground(img: TImage32; majorInterval, minorInterval: integer;
fillColor: TColor32 = clWhite32;
majColor: TColor32 = $30000000; minColor: TColor32 = $20000000);
procedure ReplaceColor(img: TImage32; oldColor, newColor: TColor32);
//EraseColor: Removes the specified color from the image, even from
//pixels that are a blend of colors including the specified color.<br>
//see https://stackoverflow.com/questions/9280902/
procedure EraseColor(img: TImage32; color: TColor32);
//RedEyeRemove: Removes 'red eye' from flash photo images.
procedure RedEyeRemove(img: TImage32; const rect: TRect);
procedure PencilEffect(img: TImage32; intensity: integer = 0);
procedure TraceContours(img: TImage32; intensity: integer);
procedure EraseInsidePath(img: TImage32;
const path: TPathD; fillRule: TFillRule);
procedure EraseInsidePaths(img: TImage32;
const paths: TPathsD; fillRule: TFillRule);
procedure EraseOutsidePath(img: TImage32; const path: TPathD;
fillRule: TFillRule; const outsideBounds: TRect);
procedure EraseOutsidePaths(img: TImage32; const paths: TPathsD;
fillRule: TFillRule; const outsideBounds: TRect);
procedure Draw3D(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; height, blurRadius: double;
colorLt: TColor32 = $DDFFFFFF; colorDk: TColor32 = $80000000;
angleRads: double = angle225); overload;
procedure Draw3D(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; height, blurRadius: double;
colorLt: TColor32 = $DDFFFFFF; colorDk: TColor32 = $80000000;
angleRads: double = angle225); overload;
function RainbowColor(fraction: double): TColor32;
function GradientColor(color1, color2: TColor32; frac: single): TColor32;
function MakeDarker(color: TColor32; percent: cardinal): TColor32;
function MakeLighter(color: TColor32; percent: cardinal): TColor32;
function DrawButton(img: TImage32; const pt: TPointD;
size: double; color: TColor32 = clNone32;
buttonShape: TButtonShape = bsRound;
buttonAttributes: TButtonAttributes = [baShadow, ba3D, baEraseBeneath]): TPathD;
//Vectorize: convert an image into polygon vectors
function Vectorize(img: TImage32; compareColor: TColor32;
compareFunc: TCompareFunction; colorTolerance: Integer;
roundingTolerance: integer = 2): TPathsD;
function VectorizeMask(const mask: TArrayOfByte; maskWidth: integer): TPathsD;
// RamerDouglasPeucker: simplifies paths, recursively removing vertices where
// they deviate no more than 'epsilon' from their adjacent vertices.
function RamerDouglasPeucker(const path: TPathD;
epsilon: double): TPathD; overload;
function RamerDouglasPeucker(const paths: TPathsD;
epsilon: double): TPathsD; overload;
// SmoothToCubicBezier - produces a series of cubic bezier control points.
// This function is very useful in the following combination:
// RamerDouglasPeucker(), SmoothToCubicBezier(), FlattenCBezier().
function SmoothToCubicBezier(const path: TPathD;
pathIsClosed: Boolean; maxOffset: integer = 0): TPathD;
//InterpolatePoints: smooths a simple line chart.
//Points should be left to right and equidistant along the X axis
function InterpolatePoints(const points: TPathD; tension: integer = 0): TPathD;
function GetFloodFillMask(imgIn, imgMaskOut: TImage32; x, y: Integer;
tolerance: Byte; compareFunc: TCompareFunctionEx): Boolean;
procedure SymmetricCropTransparent(img: TImage32);
//3 additional blend functions (see TImage32.CopyBlend)
function BlendAverage(bgColor, fgColor: TColor32): TColor32;
function BlendLinearBurn(bgColor, fgColor: TColor32): TColor32;
function BlendColorDodge(bgColor, fgColor: TColor32): TColor32;
//CurveFit: this function is based on -
//"An Algorithm for Automatically Fitting Digitized Curves"
//by Philip J. Schneider in "Graphics Gems", Academic Press, 1990
//Smooths out many very closely positioned points
//tolerance range: 1..10 where 10 == max tolerance.
function CurveFit(const path: TPathD; closed: Boolean;
tolerance: double; minSegLength: double = 2): TPathD; overload;
function CurveFit(const paths: TPathsD; closed: Boolean;
tolerance: double; minSegLength: double = 2): TPathsD; overload;
implementation
uses
{$IFNDEF MSWINDOWS}
{$IFNDEF FPC}
Img32.FMX,
{$ENDIF}
{$ENDIF}
Img32.Transform;
const
FloodFillDefaultRGBTolerance: byte = 64;
MaxBlur = 100;
type
PColor32Array = ^TColor32Array;
TColor32Array = array [0.. maxint div SizeOf(TColor32) -1] of TColor32;
PWeightedColorArray = ^TWeightedColorArray;
TWeightedColorArray = array [0.. $FFFFFF] of TWeightedColor;
//------------------------------------------------------------------------------
// Miscellaneous functions
//------------------------------------------------------------------------------
function GetSymmetricCropTransparentRect(img: TImage32): TRect;
var
w,h, x,y, x1,y1: Integer;
p1,p2: PARGB;
opaquePxlFound: Boolean;
begin
Result := img.Bounds;
w := img.Width;
y1 := 0;
opaquePxlFound := false;
for y := 0 to (img.Height div 2) -1 do
begin
p1 := PARGB(img.PixelRow[y]);
p2 := PARGB(img.PixelRow[img.Height - y -1]);
for x := 0 to w -1 do
begin
if (p1.A > 0) or (p2.A > 0) then
begin
y1 := y;
opaquePxlFound := true;
break;
end;
inc(p1); inc(p2);
end;
if opaquePxlFound then break;
end;
// probably safeset not to resize empty images
if not opaquePxlFound then Exit;
if y1 > 0 then
begin
inc(Result.Top, y1);
dec(Result.Bottom, y1);
end;
x1 := 0;
h := RectHeight(Result);
opaquePxlFound := false;
for x := 0 to (w div 2) -1 do
begin
p1 := PARGB(@img.Pixels[Result.Top * w + x]);
p2 := PARGB(@img.Pixels[Result.Top * w + (w -1) - x]);
for y := 0 to h -1 do
begin
if (p1.A > 0) or (p2.A > 0) then
begin
x1 := x;
opaquePxlFound := true;
break;
end;
inc(p1, w); inc(p2, w);
end;
if opaquePxlFound then break;
end;
if not opaquePxlFound then Exit;
inc(Result.Left, x1);
dec(Result.Right, x1);
end;
//------------------------------------------------------------------------------
//SymmetricCropTransparent: after cropping, the image's midpoint
//will be the same pixel as before cropping. (Important for rotating.)
procedure SymmetricCropTransparent(img: TImage32);
var
rec: TRect;
begin
rec := GetSymmetricCropTransparentRect(img);
if (rec.Top > 0) or (rec.Left > 0) then img.Crop(rec);
end;
//------------------------------------------------------------------------------
procedure DrawEdge(img: TImage32; const rec: TRect;
topLeftColor, bottomRightColor: TColor32; penWidth: double = 1.0);
begin
DrawEdge(img, RectD(rec), topLeftColor, bottomRightColor, penWidth);
end;
//------------------------------------------------------------------------------
procedure DrawEdge(img: TImage32; const rec: TRectD;
topLeftColor, bottomRightColor: TColor32; penWidth: double = 1.0);
var
p: TPathD;
c: TColor32;
begin
if penWidth = 0 then Exit
else if penWidth < 0 then
begin
c := topLeftColor;
topLeftColor := bottomRightColor;
bottomRightColor := c;
penWidth := -penWidth;
end;
if topLeftColor <> bottomRightColor then
begin
with rec do
begin
p := Img32.Vector.MakePath([left, bottom, left, top, right, top]);
DrawLine(img, p, penWidth, topLeftColor, esButt);
p := Img32.Vector.MakePath([right, top, right, bottom, left, bottom]);
DrawLine(img, p, penWidth, bottomRightColor, esButt);
end;
end else
DrawLine(img, Rectangle(rec), penWidth, topLeftColor, esPolygon);
end;
//------------------------------------------------------------------------------
procedure DrawEdge(img: TImage32; const path: TPathD;
topLeftColor, bottomRightColor: TColor32;
penWidth: double = 1.0; closePath: Boolean = true);
var
i, highI, deg: integer;
frac: double;
c: TColor32;
p: TPathD;
const
RadToDeg = 180/PI;
begin
if penWidth = 0 then Exit
else if penWidth < 0 then
begin
c := topLeftColor;
topLeftColor := bottomRightColor;
bottomRightColor := c;
penWidth := -penWidth;
end;
highI := high(path);
if highI < 2 then Exit;
p := path;
if closePath and not PointsNearEqual(p[0], p[highI], 0.01) then
begin
AppendPath(p, p[0]);
inc(highI);
end;
for i := 1 to highI do
begin
deg := Round(GetAngle(p[i-1], p[i]) * RadToDeg);
case deg of
-180..-136: frac := (-deg-135)/45;
-135..0 : frac := 0;
1..44 : frac := deg/45;
else frac := 1;
end;
c := GradientColor(topLeftColor, bottomRightColor, frac);
DrawLine(img, p[i-1], p[i], penWidth, c);
end;
end;
//------------------------------------------------------------------------------
procedure FillColorHorz(img: TImage32; x, endX, y: integer; color: TColor32);
var
i,dx: integer;
p: PColor32;
begin
if (x < 0) or (x >= img.Width) then Exit;
if (y < 0) or (y >= img.Height) then Exit;
p := img.PixelRow[y]; inc(p, x);
if endX >= img.Width then endX := img.Width -1
else if endX < 0 then endX := 0;
if endX < x then dx := -1 else dx := 1;
for i := 0 to Abs(x-endX) do
begin
p^ := color;
inc(p, dx);
end;
end;
//------------------------------------------------------------------------------
procedure FillColorVert(img: TImage32; x, y, endY: integer; color: TColor32);
var
i, dy: integer;
p: PColor32;
begin
if (x < 0) or (x >= img.Width) then Exit;
if (y < 0) or (y >= img.Height) then Exit;
p := img.PixelRow[y]; inc(p, x);
if endY >= img.Height then
endY := img.Height -1 else if endY < 0 then endY := 0;
dy := img.Width;
if endY < y then dy := -dy;
for i := 0 to Abs(y - endY) do
begin
p^ := color;
inc(p, dy);
end;
end;
//------------------------------------------------------------------------------
procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double;
angle: double = angle45; color: TColor32 = $80000000);
var
i,j, sX,sY: integer;
l,t,r,b: integer;
tmpImg: TImage32;
tmpRec: TRect;
xx,yy: double;
ss: TPointD;
c: TColor32;
begin
GetSinCos(angle, yy, xx);
ss.X := depth * xx;
ss.Y := depth * yy;
sX := Abs(Round(ss.X));
sY := Abs(Round(ss.Y));
if rec.Left + ss.X < 0 then ss.X := -rec.Left
else if rec.Right + ss.X > img.Width then ss.X := img.Width - rec.Right -1;
if rec.Top + ss.Y < 0 then ss.Y := -rec.Top
else if rec.Bottom + ss.Y > img.Height then ss.Y := img.Height -rec.Bottom -1;
tmpImg := TImage32.Create(sX*3 +1, sY*3 +1);
try
i := sX div 2; j := sY div 2;
DrawPolygon(tmpImg, Rectangle(i,j,i+sX*2,j+sY*2), frNonZero, color);
FastGaussianBlur(tmpImg, tmpImg.Bounds, Round(sX/4),Round(sY/4), 1);
// t-l corner
if (ss.X < 0) or (ss.Y < 0) then
begin
tmpRec := Rect(0, 0, sX, sY);
l := rec.Left; t := rec.Top;
if ss.X < 0 then dec(l, sX);
if ss.Y < 0 then dec(t, sY);
img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY));
end;
// t-r corner
if (ss.X > 0) or (ss.Y < 0) then
begin
tmpRec := Rect(sX*2+1, 0, sX*3+1, sY);
l := rec.Right; t := rec.Top;
if ss.X < 0 then dec(l, sX);
if ss.Y < 0 then dec(t, sY);
img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY));
end;
// b-l corner
if (ss.X < 0) or (ss.Y > 0) then
begin
tmpRec := Rect(0, sY*2+1, sX, sY*3+1);
l := rec.Left; t := rec.Bottom;
if ss.X < 0 then dec(l, sX);
if ss.Y < 0 then dec(t, sY);
img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY));
end;
// b-r corner
if (ss.X > 0) or (ss.Y > 0) then
begin
tmpRec := Rect(sX*2+1, sY*2+1, sX*3+1, sY*3+1);
l := rec.Right; t := rec.Bottom;
if ss.X < 0 then dec(l, sX);
if ss.Y < 0 then dec(t, sY);
img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY));
end;
// l-edge
if (ss.X < 0) then
begin
l := rec.Left; t := rec.Top+sY; b := rec.Bottom-1;
if ss.Y < 0 then begin dec(t, sY); dec(b,sY); end;
for i := 1 to sX do
begin
c := tmpImg.Pixel[sX-i, sY+1];
FillColorVert(img, l-i, t, b, c);
end;
end;
// t-edge
if (ss.Y < 0) then
begin
l := rec.Left+sX; r := rec.Right-1; t := rec.Top;
if ss.X < 0 then begin dec(l, sX); dec(r,sX); end;
for i := 1 to sY do
begin
c := tmpImg.Pixel[sX+1, sY-i];
FillColorHorz(img, l, r, t-i, c);
end;
end;
// r-edge
if (ss.X > 0) then
begin
r := rec.Right-1; t := rec.Top+sY; b := rec.Bottom-1;
if ss.Y < 0 then begin dec(t, sY); dec(b,sY); end;
for i := 1 to sX do
begin
c := tmpImg.Pixel[sX*2+i, sY+1];
FillColorVert(img, r+i, t, b, c);
end;
end;
// b-edge
if (ss.Y > 0) then
begin
l := rec.Left+sX; r := rec.Right-1; b := rec.Bottom-1;
if ss.X < 0 then begin dec(l, sX); dec(r,sX); end;
for i := 1 to sY do
begin
c := tmpImg.Pixel[sX+1, sY*2+i];
FillColorHorz(img, l, r, b+i, c);
end;
end;
finally
tmpImg.Free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawShadow(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; depth: double; angleRads: double;
color: TColor32; cutoutInsideShadow: Boolean);
var
polygons: TPathsD;
begin
setlength(polygons, 1);
polygons[0] := polygon;
DrawShadow(img, polygons, fillRule, depth,
angleRads, color, cutoutInsideShadow);
end;
//------------------------------------------------------------------------------
procedure DrawShadow(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; depth: double; angleRads: double;
color: TColor32; cutoutInsideShadow: Boolean);
var
x, y: double;
blurSize, w,h: integer;
rec: TRect;
polys, shadowPolys: TPathsD;
shadowImg: TImage32;
begin
rec := GetBounds(polygons);
if IsEmptyRect(rec) or (depth < 1) then Exit;
if not ClockwiseRotationIsAnglePositive then angleRads := -angleRads;
NormalizeAngle(angleRads);
GetSinCos(angleRads, y, x);
depth := depth * 0.5;
x := depth * x;
y := depth * y;
blurSize := Max(1,Round(depth / 2));
Img32.Vector.InflateRect(rec, Ceil(depth*2), Ceil(depth*2));
polys := OffsetPath(polygons, -rec.Left, -rec.Top);
shadowPolys := OffsetPath(polys, x, y);
RectWidthHeight(rec, w, h);
shadowImg := TImage32.Create(w, h);
try
DrawPolygon(shadowImg, shadowPolys, fillRule, color);
FastGaussianBlur(shadowImg, shadowImg.Bounds, blurSize, 1);
if cutoutInsideShadow then EraseInsidePaths(shadowImg, polys, fillRule);
img.CopyBlend(shadowImg, shadowImg.Bounds, rec, BlendToAlpha);
finally
shadowImg.Free;
end;
end;
//------------------------------------------------------------------------------
procedure DrawGlow(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; color: TColor32; blurRadius: integer);
var
polygons: TPathsD;
begin
setlength(polygons, 1);
polygons[0] := polygon;
DrawGlow(img, polygons, fillRule, color, blurRadius);
end;
//------------------------------------------------------------------------------
procedure DrawGlow(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32; blurRadius: integer);
var
w,h: integer;
rec: TRect;
glowPolys: TPathsD;
glowImg: TImage32;
begin
rec := GetBounds(polygons);
glowPolys := OffsetPath(polygons,
blurRadius -rec.Left +1, blurRadius -rec.Top +1);
Img32.Vector.InflateRect(rec, blurRadius +1, blurRadius +1);
RectWidthHeight(rec, w, h);
glowImg := TImage32.Create(w, h);
try
DrawPolygon(glowImg, glowPolys, fillRule, color);
FastGaussianBlur(glowImg, glowImg.Bounds, blurRadius, 2);
glowImg.ScaleAlpha(4);
img.CopyBlend(glowImg, glowImg.Bounds, rec, BlendToAlpha);
finally
glowImg.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TileImage(img: TImage32; const rec: TRect; tile: TImage32);
begin
TileImage(img, rec, tile, tile.Bounds);
end;
//------------------------------------------------------------------------------
procedure TileImage(img: TImage32;
const rec: TRect; tile: TImage32; const tileRec: TRect);
var
i, dstW, dstH, srcW, srcH, cnt: integer;
dstRec, srcRec: TRect;
begin
if tile.IsEmpty or IsEmptyRect(tileRec) then Exit;
RectWidthHeight(rec, dstW,dstH);
RectWidthHeight(tileRec, srcW, srcH);
cnt := Ceil(dstW / srcW);
dstRec := Img32.Vector.Rect(rec.Left, rec.Top,
rec.Left + srcW, rec.Top + srcH);
for i := 1 to cnt do
begin
img.Copy(tile, tileRec, dstRec);
Types.OffsetRect(dstRec, srcW, 0);
end;
cnt := Ceil(dstH / srcH) -1;
srcRec := Img32.Vector.Rect(rec.Left, rec.Top,
rec.Right, rec.Top + srcH);
dstRec := srcRec;
for i := 1 to cnt do
begin
Types.OffsetRect(dstRec, 0, srcH);
img.Copy(img, srcRec, dstRec);
end;
end;
//------------------------------------------------------------------------------
procedure Sharpen(img: TImage32; radius: Integer; amount: Integer);
var
i: Integer;
amt: double;
weightAmount: array [-255 .. 255] of Integer;
bmpBlur: TImage32;
pColor, pBlur: PARGB;
begin
if radius = 0 then Exit;
amt := ClampRange(amount/10, 0.1, 5);
radius := ClampRange(radius, 1, 10);
for i := -255 to 255 do
weightAmount[i] := Round(amt * i);
bmpBlur := TImage32.Create(img); // clone self
try
pColor := PARGB(img.pixelBase);
FastGaussianBlur(bmpBlur, bmpBlur.Bounds, radius, 2);
pBlur := PARGB(bmpBlur.pixelBase);
for i := 1 to img.Width * img.Height do
begin
if (pColor.A > 0) then
begin
pColor.R := ClampByte(pColor.R + weightAmount[pColor.R - pBlur.R]);
pColor.G := ClampByte(pColor.G + weightAmount[pColor.G - pBlur.G]);
pColor.B := ClampByte(pColor.B + weightAmount[pColor.B - pBlur.B]);
end;
Inc(pColor); Inc(pBlur);
end;
finally
bmpBlur.Free;
end;
end;
//------------------------------------------------------------------------------
procedure HatchBackground(img: TImage32; const rec: TRect;
color1: TColor32 = clWhite32; color2: TColor32= $FFE8E8E8;
hatchSize: Integer = 10); overload;
var
i,j: Integer;
pc: PColor32;
colors: array[boolean] of TColor32;
hatch: Boolean;
begin
colors[false] := color1;
colors[true] := color2;
img.BeginUpdate;
try
for i := rec.Top to rec.Bottom -1 do
begin
pc := img.PixelRow[i];
inc(pc, rec.Left);
hatch := Odd(i div hatchSize);
for j := rec.Left to rec.Right -1 do
begin
if (j + 1) mod hatchSize = 0 then hatch := not hatch;
pc^ := BlendToOpaque(pc^, colors[hatch]);
inc(pc);
end;
end;
finally
img.EndUpdate;
end;
end;
//------------------------------------------------------------------------------
procedure HatchBackground(img: TImage32;
color1: TColor32; color2: TColor32; hatchSize: Integer);
begin
HatchBackground(img, img.Bounds, color1, color2, hatchSize);
end;
//------------------------------------------------------------------------------
procedure GridBackground(img: TImage32; majorInterval, minorInterval: integer;
fillColor: TColor32; majColor: TColor32; minColor: TColor32);
var
i, x,y, w,h: integer;
path: TPathD;
begin
img.Clear(fillColor);
w := img.Width; h := img.Height;
SetLength(path, 2);
if minorInterval > 0 then
begin
x := minorInterval;
path[0] := PointD(x, 0); path[1] := PointD(x, h);;
for i := 1 to (w div minorInterval) do
begin
Img32.Draw.DrawLine(img, path, 1, minColor, esSquare);
path[0].X := path[0].X + minorInterval;
path[1].X := path[1].X + minorInterval;
end;
y := minorInterval;
path[0] := PointD(0, y); path[1] := PointD(w, y);
for i := 1 to (h div minorInterval) do
begin
Img32.Draw.DrawLine(img, path, 1, minColor, esSquare);
path[0].Y := path[0].Y + minorInterval;
path[1].Y := path[1].Y + minorInterval;
end;
end;
if majorInterval > minorInterval then
begin
x := majorInterval;
path[0] := PointD(x, 0); path[1] := PointD(x, h);;
for i := 1 to (w div majorInterval) do
begin
Img32.Draw.DrawLine(img, path, 1, majColor, esSquare);
path[0].X := path[0].X + majorInterval;
path[1].X := path[1].X + majorInterval;
end;
y := majorInterval;
path[0] := PointD(0, y); path[1] := PointD(w, y);
for i := 1 to (h div majorInterval) do
begin
Img32.Draw.DrawLine(img, path, 1, majColor, esSquare);
path[0].Y := path[0].Y + majorInterval;
path[1].Y := path[1].Y + majorInterval;
end;
end;
end;
//------------------------------------------------------------------------------
function ColorDifference(color1, color2: TColor32): cardinal;
{$IFDEF INLINE} inline; {$ENDIF}
var
c1: TARGB absolute color1;
c2: TARGB absolute color2;
begin
result := Abs(c1.R - c2.R) + Abs(c1.G - c2.G) + Abs(c1.B - c2.B);
result := (result * 341) shr 10; // divide by 3
end;
//------------------------------------------------------------------------------
procedure ReplaceColor(img: TImage32; oldColor, newColor: TColor32);
var
color: PColor32;
i: Integer;
begin
color := img.PixelBase;
for i := 0 to img.Width * img.Height -1 do
begin
if color^ = oldColor then color^ := newColor;
inc(color);
end;
end;
//------------------------------------------------------------------------------
procedure EraseColor(img: TImage32; color: TColor32);
var
fg: TARGB absolute color;
bg: PARGB;
i: Integer;
Q: byte;
begin
if fg.A = 0 then Exit;
bg := PARGB(img.PixelBase);
for i := 0 to img.Width * img.Height -1 do
begin
if bg.A > 0 then
begin
if (bg.R > fg.R) then Q := DivTable[bg.R - fg.R, not fg.R]
else if (bg.R < fg.R) then Q := DivTable[fg.R - bg.R, fg.R]
else Q := 0;
if (bg.G > fg.G) then Q := Max(Q, DivTable[bg.G - fg.G, not fg.G])
else if (bg.G < fg.G) then Q := Max(Q, DivTable[fg.G - bg.G, fg.G]);
if (bg.B > fg.B) then Q := Max(Q, DivTable[bg.B - fg.B, not fg.B])
else if (bg.B < fg.B) then Q := Max(Q, DivTable[fg.B - bg.B, fg.B]);
if (Q > 0) then
begin
bg.A := MulTable[bg.A, Q];
bg.R := DivTable[bg.R - MulTable[fg.R, not Q], Q];
bg.G := DivTable[bg.G - MulTable[fg.G, not Q], Q];
bg.B := DivTable[bg.B - MulTable[fg.B, not Q], Q];
end else
bg.Color := clNone32;
end;
inc(bg);
end;
end;
//------------------------------------------------------------------------------
procedure RedEyeRemove(img: TImage32; const rect: TRect);
var
k: integer;
cutout, mask: TImage32;
path: TPathD;
cutoutRec, rect3: TRect;
radGrad: TRadialGradientRenderer;
begin
k := RectWidth(rect) * RectHeight(rect);
if k < 120 then k := 2
else if k < 230 then k := 3
else k := 4;
cutoutRec := rect;
Img32.Vector.InflateRect(cutoutRec, k, k);
cutout := TImage32.Create(img, cutoutRec);
mask := TImage32.Create(cutout.Width, cutout.Height);
radGrad := TRadialGradientRenderer.Create;
try
// fill behind the cutout with black also
// blurring the fill to soften its edges
rect3 := cutout.Bounds;
Img32.Vector.InflateRect(rect3, -k, -k);
path := Ellipse(rect3);
DrawPolygon(mask, path, frNonZero, clBlack32);
// given the very small area and small radius of the blur, the
// speed improvement of BoxBlur over GaussianBlur is inconsequential.
GaussianBlur(mask, mask.Bounds, k);
img.CopyBlend(mask, mask.Bounds, cutoutRec, BlendToOpaque);
// gradient fill to clNone32 a mask to soften cutout's edges
path := Ellipse(cutoutRec);
radGrad.SetParameters(rect3, clBlack32, clNone32);
DrawPolygon(mask, path, frNonZero, radGrad);
cutout.CopyBlend(mask, mask.Bounds, cutout.Bounds, BlendMask);
// now remove red from the cutout
EraseColor(cutout, clRed32);
// finally replace the cutout ...
img.CopyBlend(cutout, cutout.Bounds, cutoutRec, BlendToOpaque);
finally
mask.Free;
cutout.Free;
radGrad.Free;
end;
end;
//------------------------------------------------------------------------------
procedure EraseInsidePath(img: TImage32; const path: TPathD; fillRule: TFillRule);
begin
if assigned(path) then
ErasePolygon(img, path, fillRule);
end;
//------------------------------------------------------------------------------
procedure EraseInsidePaths(img: TImage32; const paths: TPathsD; fillRule: TFillRule);
begin
if assigned(paths) then
ErasePolygon(img, paths, fillRule);
end;
//------------------------------------------------------------------------------
procedure EraseOutsidePath(img: TImage32; const path: TPathD;
fillRule: TFillRule; const outsideBounds: TRect);
var
mask: TImage32;
p: TPathD;
w,h: integer;
begin
if not assigned(path) then Exit;
RectWidthHeight(outsideBounds, w,h);
mask := TImage32.Create(w, h);
try
p := OffsetPath(path, -outsideBounds.Left, -outsideBounds.top);
DrawPolygon(mask, p, fillRule, clBlack32);
img.CopyBlend(mask, mask.Bounds, outsideBounds, BlendMask);
finally
mask.Free;
end;
end;
//------------------------------------------------------------------------------
procedure EraseOutsidePaths(img: TImage32; const paths: TPathsD;
fillRule: TFillRule; const outsideBounds: TRect);
var
mask: TImage32;
pp: TPathsD;
w,h: integer;
begin
if not assigned(paths) then Exit;
RectWidthHeight(outsideBounds, w,h);
mask := TImage32.Create(w, h);
try
pp := OffsetPath(paths, -outsideBounds.Left, -outsideBounds.top);
DrawPolygon(mask, pp, fillRule, clBlack32);
img.CopyBlend(mask, mask.Bounds, outsideBounds, BlendMask);
finally
mask.Free;
end;
end;
//------------------------------------------------------------------------------
procedure Draw3D(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; height, blurRadius: double;
colorLt: TColor32; colorDk: TColor32; angleRads: double);
var
polygons: TPathsD;
begin
setLength(polygons, 1);
polygons[0] := polygon;
Draw3D(img, polygons, fillRule, height, blurRadius, colorLt, colorDk, angleRads);
end;
//------------------------------------------------------------------------------
procedure Draw3D(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; height, blurRadius: double;
colorLt: TColor32; colorDk: TColor32; angleRads: double);
var
tmp: TImage32;
rec: TRect;
paths, paths2: TPathsD;
w,h: integer;
x,y: double;
begin
rec := GetBounds(polygons);
if IsEmptyRect(rec) then Exit;
if not ClockwiseRotationIsAnglePositive then angleRads := -angleRads;
GetSinCos(angleRads, y, x);
paths := OffsetPath(polygons, -rec.Left, -rec.Top);
RectWidthHeight(rec, w, h);
tmp := TImage32.Create(w, h);
try
if GetAlpha(colorLt) > 0 then
begin
tmp.Clear(colorLt);
paths2 := OffsetPath(paths, -height*x, -height*y);
EraseInsidePaths(tmp, paths2, fillRule);
FastGaussianBlur(tmp, tmp.Bounds, Round(blurRadius), 0);
EraseOutsidePaths(tmp, paths, fillRule, tmp.Bounds);
img.CopyBlend(tmp, tmp.Bounds, rec, BlendToAlpha);
end;
if GetAlpha(colorDk) > 0 then
begin
tmp.Clear(colorDk);
paths2 := OffsetPath(paths, height*x, height*y);
EraseInsidePaths(tmp, paths2, fillRule);
FastGaussianBlur(tmp, tmp.Bounds, Round(blurRadius), 0);
EraseOutsidePaths(tmp, paths, fillRule, tmp.Bounds);
img.CopyBlend(tmp, tmp.Bounds, rec, BlendToAlpha);
end;
finally
tmp.Free;
end;
end;
//------------------------------------------------------------------------------
function RainbowColor(fraction: double): TColor32;
var
hsl: THsl;
begin
if (fraction > 0) and (fraction < 1) then
begin
hsl.hue := Round(fraction * 255);
hsl.sat := 255;
hsl.lum := 255;
hsl.alpha := 255;
Result := HslToRgb(hsl);
end else
result := clRed32
end;
//------------------------------------------------------------------------------
function GradientColor(color1, color2: TColor32; frac: single): TColor32;
var
hsl1, hsl2: THsl;
begin
if (frac <= 0) then result := color1
else if (frac >= 1) then result := color2
else
begin
hsl1 := RgbToHsl(color1); hsl2 := RgbToHsl(color2);
hsl1.hue := ClampByte(hsl1.hue*(1-frac) + hsl2.hue*frac);
hsl1.sat := ClampByte(hsl1.sat*(1-frac) + hsl2.sat*frac);
hsl1.lum := ClampByte(hsl1.lum*(1-frac) + hsl2.lum*frac);
hsl1.alpha := ClampByte(hsl1.alpha*(1-frac) + hsl2.alpha*frac);
Result := HslToRgb(hsl1);
end;
end;
//------------------------------------------------------------------------------
function MakeDarker(color: TColor32; percent: cardinal): TColor32;
var
hsl: THsl;
begin
hsl := RgbToHsl(color);
hsl.lum := ClampByte(hsl.lum - (percent/100 * hsl.lum));
Result := HslToRgb(hsl);
end;
//------------------------------------------------------------------------------
function MakeLighter(color: TColor32; percent: cardinal): TColor32;
var
hsl: THsl;
begin
hsl := RgbToHsl(color);
hsl.lum := ClampByte(hsl.lum + percent/100 * (255 - hsl.lum));
Result := HslToRgb(hsl);
end;
//------------------------------------------------------------------------------
function DrawButton(img: TImage32; const pt: TPointD;
size: double; color: TColor32; buttonShape: TButtonShape;
buttonAttributes: TButtonAttributes): TPathD;
var
i: integer;
radius: double;
rec: TRectD;
lightSize, lightAngle: double;
begin
if (size < 5) then Exit;
radius := size * 0.5;
lightSize := radius * 0.25;
rec := RectD(pt.X -radius, pt.Y -radius, pt.X +radius, pt.Y +radius);
if baEraseBeneath in buttonAttributes then
img.Clear(Rect(rec));
case buttonShape of
bsDiamond:
begin
SetLength(Result, 4);
for i := 0 to 3 do Result[i] := pt;
Result[0].X := Result[0].X -radius;
Result[1].Y := Result[1].Y -radius;
Result[2].X := Result[2].X +radius;
Result[3].Y := Result[3].Y +radius;
end;
bsSquare:
begin
Img32.Vector.InflateRect(rec, -1,-1);
Result := Rectangle(rec);
end;
else
Result := Ellipse(rec);
end;
lightAngle := angle225;
img.BeginUpdate;
try
// nb: only need to cutout the inside shadow if
// the pending color fill is semi-transparent
if baShadow in buttonAttributes then
DrawShadow(img, Result, frNonZero, lightSize *2,
(lightAngle + angle180), $AA000000, GetAlpha(color) < $FE);
if GetAlpha(color) > 2 then
DrawPolygon(img, Result, frNonZero, color);
if ba3D in buttonAttributes then
Draw3D(img, Result, frNonZero, lightSize*2,
Ceil(lightSize), $CCFFFFFF, $AA000000, lightAngle);
DrawLine(img, Result, dpiAware1, clBlack32, esPolygon);
finally
img.EndUpdate;
end;
end;
//------------------------------------------------------------------------------
function AlphaAverage(color1, color2: TColor32): cardinal;
{$IFDEF INLINE} inline; {$ENDIF}
var
c1: TARGB absolute color1;
c2: TARGB absolute color2;
begin
result := (c1.A + c2.A) shr 1;
end;
//------------------------------------------------------------------------------
function BlendAverage(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
begin
res.A := (fg.A + bg.A) shr 1;
res.R := (fg.R + bg.R) shr 1;
res.G := (fg.G + bg.G) shr 1;
res.B := (fg.B + bg.B) shr 1;
end;
//------------------------------------------------------------------------------
function BlendLinearBurn(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
begin
res.A := 255;
res.R := Max(0, bg.R + fg.R - 255);
res.G := Max(0, bg.G + fg.G - 255);
res.B := Max(0, bg.B + fg.B - 255);
end;
//------------------------------------------------------------------------------
function BlendColorDodge(bgColor, fgColor: TColor32): TColor32;
var
res: TARGB absolute Result;
bg: TARGB absolute bgColor;
fg: TARGB absolute fgColor;
begin
res.A := 255;
res.R := DivTable[bg.R, not fg.R];
res.G := DivTable[bg.G, not fg.G];
res.B := DivTable[bg.B, not fg.B];
end;
//------------------------------------------------------------------------------
procedure PencilEffect(img: TImage32; intensity: integer);
var
img2: TImage32;
begin
if img.IsEmpty then Exit;
intensity := max(1, min(10, intensity));
img.Grayscale;
img2 := TImage32.Create(img);
try
img2.InvertColors;
FastGaussianBlur(img2, img2.Bounds, intensity, 2);
img.CopyBlend(img2, img2.Bounds, img.Bounds, BlendColorDodge);
finally
img2.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TraceContours(img: TImage32; intensity: integer);
var
i,j, w,h: integer;
tmp, tmp2: TArrayOfColor32;
s, s2: PColor32;
d: PARGB;
begin
w := img.Width; h := img.Height;
if w * h = 0 then Exit;
SetLength(tmp, w * h);
SetLength(tmp2, w * h);
s := img.PixelRow[0]; d := @tmp[0];
for j := 0 to h-1 do
begin
s2 := IncPColor32(s, 1);
for i := 0 to w-2 do
begin
d.A := ColorDifference(s^, s2^);
inc(s); inc(s2); inc(d);
end;
inc(s); inc(d);
end;
for j := 0 to w-1 do
begin
s := @tmp[j]; d := @tmp2[j];
s2 := IncPColor32(s, w);
for i := 0 to h-2 do
begin
d.A := AlphaAverage(s^, s2^);
inc(s, w); inc(s2, w); inc(d, w);
end;
end;
Move(tmp2[0], img.PixelBase^, w * h * sizeOf(TColor32));
if intensity < 1 then Exit;
if intensity > 10 then
intensity := 10; // range = 1-10
img.ScaleAlpha(intensity);
end;
//------------------------------------------------------------------------------
// FLOODFILL - AND SUPPORT FUNCTIONS
//------------------------------------------------------------------------------
type
PFloodFillRec = ^TFloodFillRec;
TFloodFillRec = record
xLeft : Integer;
xRight : Integer;
y : Integer;
dirY : Integer;
next : PFloodFillRec;
end;
TFloodFillStack = class
first : PFloodFillRec;
maxY : integer;
constructor Create(maxY: integer);
destructor Destroy; override;
procedure Push(xLeft, xRight,y, direction: Integer);
procedure Pop(out xLeft, xRight,y, direction: Integer);
function IsEmpty: Boolean;
end;
TFloodFillMask = class
private
img : TImage32;
mask : TImage32;
colorsRow : PColor32Array;
maskRow : PColor32Array;
initialColor : TColor32;
compareFunc : TCompareFunctionEx;
tolerance : Integer;
public
function Execute(imgIn, imgMaskOut: TImage32; x,y: integer;
aTolerance: Byte = 0; compFunc: TCompareFunctionEx = nil): Boolean;
procedure SetCurrentY(y: Integer);
function IsMatch(x: Integer): Boolean;
end;
//------------------------------------------------------------------------------
// TFloodFillStack methods
//------------------------------------------------------------------------------
constructor TFloodFillStack.Create(maxY: integer);
begin
self.maxY := maxY;
end;
//------------------------------------------------------------------------------
destructor TFloodFillStack.Destroy;
var
ffr: PFloodFillRec;
begin
while assigned(first) do
begin
ffr := first;
first := first.next;
dispose(ffr);
end;
end;
//------------------------------------------------------------------------------
procedure TFloodFillStack.Push(xLeft, xRight, y, direction: Integer);
var
ffr: PFloodFillRec;
begin
if ((y <= 0) and (direction = -1)) or
((y >= maxY) and (direction = 1)) then Exit;
new(ffr);
ffr.xLeft := xLeft;
ffr.xRight := xRight;
ffr.y := y;
ffr.dirY := direction;
ffr.next := first;
first := ffr;
end;
//------------------------------------------------------------------------------
procedure TFloodFillStack.Pop(out xLeft, xRight, y, direction: Integer);
var
ffr: PFloodFillRec;
begin
xLeft := first.xLeft;
xRight := first.xRight;
direction := first.dirY;
y := first.y + direction;
ffr := first;
first := first.next;
dispose(ffr);
end;
//------------------------------------------------------------------------------
function TFloodFillStack.IsEmpty: Boolean;
begin
result := not assigned(first);
end;
//------------------------------------------------------------------------------
// TFloodFillMask methods
//------------------------------------------------------------------------------
function TFloodFillMask.Execute(imgIn, imgMaskOut: TImage32; x,y: integer;
aTolerance: Byte; compFunc: TCompareFunctionEx): Boolean;
var
ffs : TFloodFillStack;
w,h : integer;
xl, xr, xr2 : Integer;
maxX : Integer;
dirY : Integer;
begin
Result := Assigned(imgIn) and Assigned(imgMaskOut) and
InRange(x,0,imgIn.Width -1) and InRange(y,0,imgIn.Height -1);
if not Result then Exit;
w := imgIn.Width; h := imgIn.Height;
// make sure the mask is the size of the image
imgMaskOut.SetSize(w,h);
img := imgIn;
mask := imgMaskOut;
compareFunc := compFunc;
tolerance := aTolerance;
maxX := w -1;
ffs := TFloodFillStack.create(h -1);
try
initialColor := imgIn.Pixel[x, y];
xl := x; xr := x;
SetCurrentY(y);
IsMatch(x);
while (xl > 0) and IsMatch(xl -1) do dec(xl);
while (xr < maxX) and IsMatch(xr +1) do inc(xr);
ffs.Push(xl, xr, y, -1); // down
ffs.Push(xl, xr, y, 1); // up
while not ffs.IsEmpty do
begin
ffs.Pop(xl, xr, y, dirY);
SetCurrentY(y);
xr2 := xl;
// check left ...
if IsMatch(xl) then
begin
while (xl > 0) and IsMatch(xl-1) do dec(xl);
if xl <= xr2 -2 then
ffs.Push(xl, xr2-2, y, -dirY);
while (xr2 < maxX) and IsMatch(xr2+1) do inc(xr2);
ffs.Push(xl, xr2, y, dirY);
if xr2 >= xr +2 then
ffs.Push(xr+2, xr2, y, -dirY);
xl := xr2 +2;
end;
// check right ...
while (xl <= xr) and not IsMatch(xl) do inc(xl);
while (xl <= xr) do
begin
xr2 := xl;
while (xr2 < maxX) and IsMatch(xr2+1) do inc(xr2);
ffs.Push(xl, xr2, y, dirY);
if xr2 >= xr +2 then
begin
ffs.Push(xr+2, xr2, y, -dirY);
break;
end;
inc(xl, 2);
while (xl <= xr) and not IsMatch(xl) do inc(xl);
end;
end;
finally
ffs.Free;
end;
end;
//------------------------------------------------------------------------------
procedure TFloodFillMask.SetCurrentY(y: Integer);
begin
colorsRow := PColor32Array(img.PixelRow[y]);
maskRow := PColor32Array(mask.PixelRow[y]);
end;
//------------------------------------------------------------------------------
function TFloodFillMask.IsMatch(x: Integer): Boolean;
var
b: Byte;
begin
if (maskRow[x] > 0) then
result := false
else
begin
b := compareFunc(initialColor, colorsRow[x]);
result := b < tolerance;
if Result then
maskRow[x] := tolerance - b else
maskRow[x] := 1;
end;
end;
//------------------------------------------------------------------------------
function GetFloodFillMask(imgIn, imgMaskOut: TImage32; x, y: Integer;
tolerance: Byte; compareFunc: TCompareFunctionEx): Boolean;
var
ffm: TFloodFillMask;
begin
if not Assigned(compareFunc) then compareFunc := CompareRGBEx;
ffm := TFloodFillMask.Create;
try
Result := ffm.Execute(imgIn, imgMaskOut, x, y, tolerance, compareFunc);
finally
ffm.Free;
end;
end;
//------------------------------------------------------------------------------
procedure FloodFill(img: TImage32; x, y: Integer; newColor: TColor32;
tolerance: Byte; compareFunc: TCompareFunctionEx);
var
i: Integer;
pc, pm: PColor32;
mask: TImage32;
begin
if not assigned(compareFunc) then
begin
compareFunc := CompareRGBEx;
if tolerance = 0 then
tolerance := FloodFillDefaultRGBTolerance;
end;
mask := TImage32.Create;
try
if not GetFloodFillMask(img, mask, x, y, tolerance, compareFunc) then
Exit;
pc := img.PixelBase;
pm := mask.PixelBase;
for i := 0 to img.Width * img.Height -1 do
begin
if (pm^ > 1) then pc^ := newColor;
inc(pm); inc(pc);
end;
finally
mask.free;
end;
end;
//------------------------------------------------------------------------------
// EMBOSS - AND SUPPORT FUNCTIONS
//------------------------------------------------------------------------------
function IncPWeightColor(pwc: PWeightedColor; cnt: Integer): PWeightedColor;
begin
result := PWeightedColor(PByte(pwc) + cnt * SizeOf(TWeightedColor));
end;
//------------------------------------------------------------------------------
function Intensity(color: TColor32): byte;
var
c: TARGB absolute color;
begin
Result := (c.R * 61 + c.G * 174 + c.B * 21) shr 8;
end;
//------------------------------------------------------------------------------
function Gray(color: TColor32): TColor32;
var
c: TARGB absolute color;
res: TARGB absolute Result;
begin
res.A := c.A;
res.R := Intensity(color);
res.G := res.R;
res.B := res.R;
end;
//------------------------------------------------------------------------------
procedure Emboss(img: TImage32; radius: Integer;
depth: Integer; luminance: Integer; preserveColor: Boolean);
var
yy,xx, x,y, w,h: Integer;
b: byte;
kernel: array [0 .. MaxBlur, 0 .. MaxBlur] of Integer;
wca: TArrayOfWeightedColor;
pc0, pcf, pcb: PColor32; // pointers to pixels (forward & backward in kernel)
pw0, pw: PWeightedColor; // pointers to weight
customGray: TColor32;
pc: PColor32;
const
maxDepth = 50;
begin
// grayscale luminance as percent where 0% is black and 100% is white
//(luminance is ignored when preserveColor = true)
luminance := ClampRange(luminance, 0, 100);
b := luminance *255 div 100;
customGray := $FF000000 + b shl 16 + b shl 8 + b;
ClampRange(radius, 1, 5);
inc(depth);
ClampRange(depth, 2, maxDepth);
kernel[0][0] := 1;
for y := 1 to radius do
for x := 1 to radius do
kernel[y][x] := depth;
w := img.Width; h := img.Height;
// nb: dynamic arrays are zero-initialized (unless they're a function result)
SetLength(wca, w * h);
pc0 := IncPColor32(img.PixelBase, radius * w);
pw0 := @wca[radius * w];
for y := radius to h -1 - radius do
begin
for x := radius to w -1 - radius do
begin
pw := IncPWeightColor(pw0, x);
pcb := IncPColor32(pc0, x - 1);
if preserveColor then
begin
pcf := IncPColor32(pc0, x);
pw^.Add(pcf^, kernel[0,0]);
inc(pcf);
end else
begin
pw^.Add(customGray, kernel[0,0]);
pcf := IncPColor32(pc0, x + 1);
end;
// parse the kernel ...
for yy := 1 to radius do
begin
for xx := 1 to radius do
begin
pw^.Subtract(Gray(pcf^), kernel[yy,xx]);
pw^.Add(Gray(pcb^), kernel[yy,xx]);
dec(pcb); inc(pcf);
end;
dec(pcb, img.Width - radius);
inc(pcf, img.Width - radius);
end;
end;
inc(pc0, img.Width);
inc(pw0, img.Width);
end;
pc := @img.Pixels[0]; pw := @wca[0];
for x := 0 to img.width * img.Height - 1 do
begin
pc^ := pw.Color or $FF000000;
inc(pc); inc(pw);
end;
end;
//------------------------------------------------------------------------------
// Structure and functions used by the Vectorize routine
//------------------------------------------------------------------------------
type
TPt2Container = class;
TPt2 = class
pt : TPointD;
owner : TPt2Container;
isStart : Boolean;
isHole : Boolean;
nextInPath : TPt2;
prevInPath : TPt2;
nextInRow : TPt2;
prevInRow : TPt2;
destructor Destroy; override;
procedure Update(x, y: double);
function GetCount: integer;
function GetPoints: TPathD;
property IsAscending: Boolean read isStart;
end;
TPt2Container = class
prevRight: integer;
leftMostPt, rightMost: TPt2;
solution: TPathsD;
procedure AddToSolution(const path: TPathD);
function StartNewPath(insertBefore: TPt2;
xLeft, xRight, y: integer; isHole: Boolean): TPt2;
procedure AddRange(var current: TPt2; xLeft, xRight, y: integer);
function JoinAscDesc(path1, path2: TPt2): TPt2;
function JoinDescAsc(path1, path2: TPt2): TPt2;
procedure CheckRowEnds(pt2Left, pt2Right: TPt2);
end;
//------------------------------------------------------------------------------
destructor TPt2.Destroy;
var
startPt, endPt, pt: TPt2;
begin
if not isStart then Exit;
startPt := self;
endPt := startPt.prevInPath;
// remove 'endPt' from double linked list
if endPt = owner.rightMost then
owner.rightMost := endPt.prevInRow
else if assigned(endPt.nextInRow) then
endPt.nextInRow.prevInRow := endPt.prevInRow;
if endPt = owner.leftMostPt then
owner.leftMostPt := endPt.nextInRow
else if assigned(endPt.prevInRow) then
endPt.prevInRow.nextInRow := endPt.nextInRow;
// remove 'startPt' from double linked list
if startPt = owner.leftMostPt then
owner.leftMostPt := startPt.nextInRow
else if assigned(startPt.prevInRow) then
startPt.prevInRow.nextInRow := startPt.nextInRow;
if assigned(startPt.nextInRow) then
startPt.nextInRow.prevInRow := startPt.prevInRow;
owner.AddToSolution(GetPoints);
// now Free the entire path (except self)
pt := startPt.nextInPath;
while pt <> startPt do
begin
endPt := pt;
pt := pt.nextInPath;
endPt.Free;
end;
end;
//------------------------------------------------------------------------------
function IsColinear(const pt1, pt2, pt3: TPoint): Boolean; overload;
begin
// cross product = 0
result := (pt1.X - pt2.X)*(pt2.Y - pt3.Y) = (pt2.X - pt3.X)*(pt1.Y - pt2.Y);
end;
//------------------------------------------------------------------------------
function IsColinear(const pt1, pt2, pt3, pt4: TPoint): Boolean; overload;
begin
result := (pt1.X - pt2.X)*(pt3.Y - pt4.Y) = (pt3.X - pt4.X)*(pt1.Y - pt2.Y);
end;
//------------------------------------------------------------------------------
function CreatePt2After(pt: TPt2; const p: TPointD): TPt2;
begin
Result := TPt2.Create;
Result.pt := p;
Result.nextInPath := pt.nextInPath;
Result.prevInPath := pt;
pt.nextInPath.prevInPath := Result;
pt.nextInPath := Result;
end;
//------------------------------------------------------------------------------
procedure TPt2.Update(x, y: double);
var
newPt2: TPt2;
begin
if isStart then
begin
// just update self.pt when colinear
if (x = pt.X) and (pt.X = nextInPath.pt.X) then
begin
pt := PointD(x,y);
Exit;
end;
// self -> 2 -> 1 -> nip
CreatePt2After(self, pt);
if (x <> pt.X) or (x <> nextInPath.pt.X) then
begin
// add a pixel either below or beside
if IsAscending then
CreatePt2After(self, PointD(pt.X, y)) else
CreatePt2After(self, PointD(x, pt.Y));
end;
pt := PointD(x,y);
end else
begin
// just update self.pt when colinear
if (x = pt.X) and (pt.X = prevInPath.pt.X) then
begin
pt := PointD(x,y);
Exit;
end;
// self <- 2 <- 1 <- pip
newPt2 := CreatePt2After(prevInPath, pt);
if (x <> pt.X) or (x <> prevInPath.pt.X) then
begin
// add a pixel either below or beside
if IsAscending then
CreatePt2After(newPt2, PointD(x, pt.Y)) else
CreatePt2After(newPt2, PointD(pt.X, y));
end;
pt := PointD(x,y);
end;
end;
//------------------------------------------------------------------------------
function TPt2.GetCount: integer;
var
pt2: TPt2;
begin
result := 1;
pt2 := nextInPath;
while pt2 <> self do
begin
inc(Result);
pt2 := pt2.nextInPath;
end;
end;
//------------------------------------------------------------------------------
function TPt2.GetPoints: TPathD;
var
i, count: integer;
pt2: TPt2;
begin
Update(pt.X, pt.Y+1);
with prevInPath do Update(pt.X, pt.Y+1); // path 'end'
count := GetCount;
SetLength(Result, count);
pt2 := self;
for i := 0 to count -1 do
begin
Result[i] := pt2.pt;
pt2 := pt2.nextInPath;
end;
end;
//------------------------------------------------------------------------------
procedure TPt2Container.AddToSolution(const path: TPathD);
var
len: integer;
begin
if Length(path) < 2 then Exit;
len := Length(solution);
SetLength(solution, len + 1);
solution[len] := path;
end;
//------------------------------------------------------------------------------
function TPt2Container.StartNewPath(insertBefore: TPt2;
xLeft, xRight, y: integer; isHole: Boolean): TPt2;
var
pt2Left, pt2Right: TPt2;
begin
inc(xRight);
pt2Left := TPt2.Create;
pt2Left.owner := self;
pt2Left.isStart := not isHole;
pt2Left.isHole := isHole;
pt2Left.pt := PointD(xLeft, y);
pt2Right := TPt2.Create;
pt2Right.owner := self;
pt2Right.isStart := isHole;
pt2Right.isHole := isHole;
pt2Right.pt := PointD(xRight, y);
pt2Left.nextInPath := pt2Right;
pt2Left.prevInPath := pt2Right;
pt2Right.nextInPath := pt2Left;
pt2Right.prevInPath := pt2Left;
pt2Left.nextInRow := pt2Right;
pt2Right.prevInRow := pt2Left;
if not Assigned(insertBefore) then
begin
// must be a new rightMost path
pt2Left.prevInRow := rightMost;
if Assigned(rightMost) then rightMost.nextInRow := pt2Left;
pt2Right.nextInRow := nil;
rightMost := pt2Right;
if not Assigned(leftMostPt) then leftMostPt := pt2Left;
end else
begin
pt2Right.nextInRow := insertBefore;
if leftMostPt = insertBefore then
begin
// must be a new leftMostPt path
leftMostPt := pt2Left;
pt2Left.prevInRow := nil;
end else
begin
pt2Left.prevInRow := insertBefore.prevInRow;
insertBefore.prevInRow.nextInRow := pt2Left;
end;
insertBefore.prevInRow := pt2Right;
end;
result := pt2Right.nextInRow;
end;
//------------------------------------------------------------------------------
procedure TPt2Container.CheckRowEnds(pt2Left, pt2Right: TPt2);
begin
if pt2Left = leftMostPt then leftMostPt := pt2Right.nextInRow;
if pt2Right = rightMost then rightMost := pt2Left.prevInRow;
end;
//------------------------------------------------------------------------------
function TPt2Container.JoinAscDesc(path1, path2: TPt2): TPt2;
begin
result := path2.nextInRow;
CheckRowEnds(path1, path2);
if path2 = path1.prevInPath then
begin
path1.Free;
Exit;
end;
with path1 do Update(pt.X, pt.Y+1);
with path2 do Update(pt.X, pt.Y+1);
path1.isStart := false;
// remove path1 from double linked list
if assigned(path1.nextInRow) then
path1.nextInRow.prevInRow := path1.prevInRow;
if assigned(path1.prevInRow) then
path1.prevInRow.nextInRow := path1.nextInRow;
// remove path2 from double linked list
if assigned(path2.nextInRow) then
path2.nextInRow.prevInRow := path2.prevInRow;
if assigned(path2.prevInRow) then
path2.prevInRow.nextInRow := path2.nextInRow;
path1.prevInPath.nextInPath := path2.nextInPath;
path2.nextInPath.prevInPath := path1.prevInPath;
path2.nextInPath := path1;
path1.prevInPath := path2;
end;
//------------------------------------------------------------------------------
function TPt2Container.JoinDescAsc(path1, path2: TPt2): TPt2;
begin
result := path2.nextInRow;
CheckRowEnds(path1, path2);
if path1 = path2.prevInPath then
begin
path2.Free;
Exit;
end;
with path1 do Update(pt.X, pt.Y+1);
with path2 do Update(pt.X, pt.Y+1);
path2.isStart := false;
// remove path1 'end' from double linked list
if assigned(path1.nextInRow) then
path1.nextInRow.prevInRow := path1.prevInRow;
if assigned(path1.prevInRow) then
path1.prevInRow.nextInRow := path1.nextInRow;
// remove path2 'start' from double linked list
if assigned(path2.nextInRow) then
path2.nextInRow.prevInRow := path2.prevInRow;
if assigned(path2.prevInRow) then
path2.prevInRow.nextInRow := path2.nextInRow;
path1.nextInPath.prevInPath := path2.prevInPath;
path2.prevInPath.nextInPath := path1.nextInPath;
path1.nextInPath := path2;
path2.prevInPath := path1;
end;
//------------------------------------------------------------------------------
function IsHeadingLeft(current: TPt2; r: integer): Boolean;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result := r <= current.pt.X;
end;
//------------------------------------------------------------------------------
procedure TPt2Container.AddRange(var current: TPt2;
xLeft, xRight, y: integer);
begin
if (prevRight > 0) then
begin
// nb: prevRight always ends a range (whether a hole or an outer)
// check if we're about to start a hole
if xLeft < current.pt.X then
begin
//'current' must be descending and hence prevRight->xLeft a hole
current := StartNewPath(current, prevRight, xLeft -1, y, true);
prevRight := xRight;
Exit; // nb: it's possible for multiple holes
end;
// check if we're passing under a pending join
while assigned(current) and assigned(current.nextInRow) and
(prevRight > current.nextInRow.pt.X) do
begin
// Assert(not current.IsAscending, 'oops!');
// Assert(current.nextInRow.IsAscending, 'oops!');
current := JoinDescAsc(current, current.nextInRow);
end;
// check again for a new hole
if (xLeft < current.pt.X) then
begin
current := StartNewPath(current, prevRight, xLeft -1, y, true);
prevRight := xRight;
Exit;
end;
current.Update(prevRight, y);
current := current.nextInRow;
prevRight := 0;
end;
// check if we're passing under a pending join
while assigned(current) and assigned(current.nextInRow) and
(xLeft > current.nextInRow.pt.X) do
current := JoinAscDesc(current, current.nextInRow);
if not assigned(current) or (xRight < current.pt.X) then
begin
StartNewPath(current, xLeft, xRight -1, y, false);
// nb: current remains unchanged
end else
begin
//'range' must somewhat overlap one or more paths above
if IsHeadingLeft(current, xRight) then
begin
if current.isHole then
begin
current.Update(xLeft, y);
current := current.nextInRow;
end;
current.Update(xRight, y);
current.Update(xLeft, y);
if current.IsAscending then
prevRight := xRight else
prevRight := 0;
current := current.nextInRow;
end else
begin
current.Update(xLeft, y);
current := current.nextInRow;
prevRight := xRight;
end;
end
end;
//------------------------------------------------------------------------------
function VectorizeMask(const mask: TArrayOfByte; maskWidth: integer): TPathsD;
var
i,j, len, height, blockStart: integer;
current: TPt2;
ba: PByteArray;
pt2Container: TPt2Container;
begin
Result := nil;
len := Length(mask);
if (len = 0) or (maskWidth = 0) or (len mod maskWidth <> 0) then Exit;
height := len div maskWidth;
pt2Container := TPt2Container.Create;
try
for i := 0 to height -1 do
begin
ba := @mask[maskWidth * i];
blockStart := -2;
current := pt2Container.leftMostPt;
for j := 0 to maskWidth -1 do
begin
if (ba[j] > 0) = (blockStart >= 0) then Continue;
if blockStart >= 0 then
begin
pt2Container.AddRange(current, blockStart, j, i);
blockStart := -1;
end else
blockStart := j;
end;
if blockStart >= 0 then
pt2Container.AddRange(current, blockStart, maskWidth, i);
if (pt2Container.prevRight > 0) then
begin
while Assigned(current.nextInRow) and
(pt2Container.prevRight >= current.nextInRow.pt.X) do
begin
if current.isStart then
current := pt2Container.JoinAscDesc(current, current.nextInRow)
else
current := pt2Container.JoinDescAsc(current, current.nextInRow);
end;
current.Update(pt2Container.prevRight, i);
current := current.nextInRow;
pt2Container.prevRight := 0;
end;
while assigned(current) do
begin
if current.isStart then
current := pt2Container.JoinAscDesc(current, current.nextInRow) else
current := pt2Container.JoinDescAsc(current, current.nextInRow);
end
end;
with pt2Container do
while Assigned(leftMostPt) do
if leftMostPt.isStart then
JoinAscDesc(leftMostPt, leftMostPt.nextInRow) else
JoinDescAsc(leftMostPt, leftMostPt.nextInRow);
Result := pt2Container.solution;
finally
pt2Container.Free;
end;
end;
//------------------------------------------------------------------------------
function Tidy(const poly: TPathD; tolerance: integer): TPathD;
var
i,j, highI: integer;
prev: TPointD;
tolSqrd: double;
begin
Result := nil;
highI := High(poly);
while (HighI >= 0) and PointsEqual(poly[highI], poly[0]) do dec(highI);
if highI < 1 then Exit;
tolSqrd := Sqr(Max(2.02, Min(16.1, tolerance + 0.01)));
SetLength(Result, highI +1);
prev := poly[highI];
Result[0] := prev;
Result[1] := poly[0];
j := 1;
for i := 1 to highI -1 do
begin
if ((DistanceSqrd(prev, Result[j]) > tolSqrd) and
(DistanceSqrd(Result[j], poly[i]) > tolSqrd)) or
(TurnsRight(prev, result[j], poly[i]) or
TurnsLeft(result[j], poly[i], poly[i+1])) then
begin
prev := result[j];
inc(j);
end;
result[j] := poly[i];
end;
if ((DistanceSqrd(prev, Result[j]) > tolSqrd) and
(DistanceSqrd(Result[j], Result[0]) > tolSqrd)) or
TurnsRight(prev, result[j], Result[0]) or
TurnsLeft(result[j], Result[0], Result[1]) then
SetLength(Result, j +1) else
SetLength(Result, j);
if Abs(Area(Result)) < Length(Result) * tolerance/2 then Result := nil;
end;
//------------------------------------------------------------------------------
function Vectorize(img: TImage32; compareColor: TColor32;
compareFunc: TCompareFunction; colorTolerance: Integer;
roundingTolerance: integer): TPathsD;
var
i,j: integer;
mask: TArrayOfByte;
begin
mask := GetBoolMask(img, compareColor, compareFunc, colorTolerance);
Result := VectorizeMask(mask, img.Width);
j := 0;
for i := 0 to high(Result) do
begin
Result[j] := Tidy(Result[i], roundingTolerance);
if Assigned(Result[j]) then inc(j);
end;
SetLength(Result, j);
end;
//------------------------------------------------------------------------------
// RamerDouglasPeucker - and support functions
//------------------------------------------------------------------------------
procedure RDP(const path: TPathD; startIdx, endIdx: integer;
epsilonSqrd: double; var flags: TArrayOfInteger);
var
i, idx: integer;
d, maxD: double;
begin
idx := 0;
maxD := 0;
for i := startIdx +1 to endIdx -1 do
begin
// PerpendicularDistSqrd - avoids expensive Sqrt()
d := PerpendicularDistSqrd(path[i], path[startIdx], path[endIdx]);
if d <= maxD then Continue;
maxD := d;
idx := i;
end;
if maxD < epsilonSqrd then Exit;
flags[idx] := 1;
if idx > startIdx + 1 then RDP(path, startIdx, idx, epsilonSqrd, flags);
if endIdx > idx + 1 then RDP(path, idx, endIdx, epsilonSqrd, flags);
end;
//------------------------------------------------------------------------------
function RamerDouglasPeucker(const path: TPathD;
epsilon: double): TPathD;
var
i,j, len: integer;
buffer: TArrayOfInteger;
begin
len := length(path);
if len < 5 then
begin
result := Copy(path, 0, len);
Exit;
end;
SetLength(buffer, len); // buffer is zero initialized
buffer[0] := 1;
buffer[len -1] := 1;
RDP(path, 0, len -1, Sqr(epsilon), buffer);
j := 0;
SetLength(Result, len);
for i := 0 to len -1 do
if buffer[i] = 1 then
begin
Result[j] := path[i];
inc(j);
end;
SetLength(Result, j);
end;
//------------------------------------------------------------------------------
function RamerDouglasPeucker(const paths: TPathsD;
epsilon: double): TPathsD;
var
i,j, len: integer;
begin
j := 0;
len := length(paths);
setLength(Result, len);
for i := 0 to len -1 do
begin
Result[j] := RamerDouglasPeucker(paths[i], epsilon);
if Result[j] <> nil then inc(j);
end;
setLength(Result, j);
end;
//------------------------------------------------------------------------------
function DotProdVecs(const vec1, vec2: TPointD): double;
{$IFDEF INLINE} inline; {$ENDIF}
begin
result := (vec1.X * vec2.X + vec1.Y * vec2.Y);
end;
//---------------------------------------------------------------------------
function SmoothToCubicBezier(const path: TPathD;
pathIsClosed: Boolean; maxOffset: integer): TPathD;
var
i, j, len, prev: integer;
vec: TPointD;
pl: TArrayOfDouble;
unitVecs: TPathD;
d, angle, d1,d2: double;
begin
// SmoothToCubicBezier - returns cubic bezier control points
Result := nil;
len := Length(path);
if len < 3 then Exit;
SetLength(Result, len *3 +1);
prev := len-1;
SetLength(pl, len);
SetLength(unitVecs, len);
pl[0] := Distance(path[prev], path[0]);
unitVecs[0] := GetUnitVector(path[prev], path[0]);
for i := 0 to len -1 do
begin
if i = prev then
begin
j := 0;
end else
begin
j := i +1;
pl[j] := Distance(path[i], path[j]);
unitVecs[j] := GetUnitVector(path[i], path[j]);
end;
vec := GetAvgUnitVector(unitVecs[i], unitVecs[j]);
angle := arccos(Max(-1,Min(1,(DotProdVecs(unitVecs[i], unitVecs[j])))));
d := abs(Pi-angle)/TwoPi;
d1 := pl[i] * d;
d2 := pl[j] * d;
if maxOffset > 0 then
begin
d1 := Min(maxOffset, d1);
d2 := Min(maxOffset, d2);
end;
if i = 0 then
Result[len*3-1] := OffsetPoint(path[0], -vec.X * d1, -vec.Y * d1)
else
Result[i*3-1] := OffsetPoint(path[i], -vec.X * d1, -vec.Y * d1);
Result[i*3] := path[i];
Result[i*3+1] := OffsetPoint(path[i], vec.X * d2, vec.Y * d2);
end;
Result[len*3] := path[0];
if pathIsClosed then Exit;
Result[1] := Result[0];
dec(len);
Result[len*3-1] := Result[len*3];
SetLength(Result, Len*3 +1);
end;
//------------------------------------------------------------------------------
function HermiteInterpolation(y1, y2, y3, y4: double;
mu, tension: double): double;
var
m0,m1,mu2,mu3: double;
a0,a1,a2,a3: double;
begin
// http://paulbourke.net/miscellaneous/interpolation/
// nb: optional bias toward left or right has been disabled.
mu2 := mu * mu;
mu3 := mu2 * mu;
m0 := (y2-y1)*(1-tension)/2;
m0 := m0 + (y3-y2)*(1-tension)/2;
m1 := (y3-y2)*(1-tension)/2;
m1 := m1 + (y4-y3)*(1-tension)/2;
a0 := 2*mu3 - 3*mu2 + 1;
a1 := mu3 - 2*mu2 + mu;
a2 := mu3 - mu2;
a3 := -2*mu3 + 3*mu2;
Result := a0*y2+a1*m0+a2*m1+a3*y3;
end;
//------------------------------------------------------------------------------
function InterpolateY(const y1,y2,y3,y4: double;
dx: integer; tension: double): TArrayOfDouble;
var
i: integer;
begin
SetLength(Result, dx);
if dx = 0 then Exit;
Result[0] := y2;
for i := 1 to dx-1 do
Result[i] := HermiteInterpolation(y1,y2,y3,y4, i/dx, tension);
end;
//------------------------------------------------------------------------------
function InterpolatePoints(const points: TPathD; tension: integer): TPathD;
var
i, j, len, len2: integer;
p, p2: TPathD;
ys: TArrayOfDouble;
begin
if tension < -1 then tension := -1
else if tension > 1 then tension := 1;
Result := nil;
len := Length(points);
if len < 2 then Exit;
SetLength(p, len +2);
p[0] := points[0];
p[len+1] := points[len -1];
Move(points[0],p[1], len * SizeOf(TPointD));
for i := 1 to len-1 do
begin
ys := InterpolateY(p[i-1].Y,p[i].Y,p[i+1].Y,p[i+2].Y,
Trunc(p[i+1].X - p[i].X), tension);
len2 := Length(ys);
SetLength(p2, len2);
for j := 0 to len2 -1 do
p2[j] := PointD(p[i].X +j, ys[j]);
AppendPath(Result, p2);
end;
AppendPoint(Result, p[len]);
end;
//------------------------------------------------------------------------------
// GaussianBlur
//------------------------------------------------------------------------------
procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer);
var
i, w,h, x,y,yy,z: Integer;
gaussTable: array [-MaxBlur .. MaxBlur] of Cardinal;
wc: TWeightedColor;
wca: TArrayOfWeightedColor;
row: PColor32Array;
wcRow: PWeightedColorArray;
begin
Types.IntersectRect(rec, rec, img.Bounds);
if IsEmptyRect(rec) or (radius < 1) then Exit
else if radius > MaxBlur then radius := MaxBlur;
for i := 0 to radius do
begin
gaussTable[i] := Sqr(Radius - i +1);
gaussTable[-i] := gaussTable[i];
end;
RectWidthHeight(rec, w, h);
setLength(wca, w * h);
for y := 0 to h -1 do
begin
row := PColor32Array(@img.Pixels[(y + rec.Top) * img.Width + rec.Left]);
wcRow := PWeightedColorArray(@wca[y * w]);
for x := 0 to w -1 do
for z := max(0, x - radius) to min(img.Width -1, x + radius) do
wcRow[x].Add(row[z], gaussTable[x-z]);
end;
for x := 0 to w -1 do
begin
for y := 0 to h -1 do
begin
wc.Reset;
yy := max(0, y - radius) * w;
for z := max(0, y - radius) to min(h -1, y + radius) do
begin
wc.Add(wca[x + yy].Color, gaussTable[y-z]);
inc(yy, w);
end;
img.Pixels[x + rec.Left + (y + rec.Top) * img.Width] := wc.Color;
end;
end;
end;
//------------------------------------------------------------------------------
// FastGaussian blur - and support functions
//------------------------------------------------------------------------------
//http://blog.ivank.net/fastest-gaussian-blur.html
//https://www.peterkovesi.com/papers/FastGaussianSmoothing.pdf
function BoxesForGauss(stdDev, boxCnt: integer): TArrayOfInteger;
var
i, wl, wu, m: integer;
wIdeal, mIdeal: double;
begin
SetLength(Result, boxCnt);
wIdeal := Sqrt((12*stdDev*stdDev/boxCnt)+1); // Ideal averaging filter width
wl := Floor(wIdeal); if not Odd(wl) then dec(wl);
mIdeal :=
(-3*stdDev*stdDev +0.25*boxCnt*wl*wl +boxCnt*wl +0.75*boxCnt)/(wl+1);
m := Floor(mIdeal) div 2; // nb: variation on Ivan Kutskir's code.
wl := (wl -1) div 2; // It's better to do this here
wu := wl+1; // than later in both BoxBlurH & BoxBlurV
for i := 0 to boxCnt -1 do
if i < m then
Result[i] := wl else
Result[i] := wu;
end;
//------------------------------------------------------------------------------
procedure BoxBlurH(var src, dst: TArrayOfColor32; w,h, stdDev: integer);
var
i,j, ti, li, ri, re, ovr: integer;
fv, lv, val: TWeightedColor;
rc: TColor32;
begin
ovr := Max(0, stdDev - w);
for i := 0 to h -1 do
begin
ti := i * w;
li := ti;
ri := ti +stdDev;
re := ti +w -1; // idx of last pixel in row
rc := src[re]; // color of last pixel in row
fv.Reset;
lv.Reset;
val.Reset;
fv.Add(src[ti], 1);
lv.Add(rc, 1);
val.Add(src[ti], stdDev +1);
for j := 0 to stdDev -1 - ovr do
val.Add(src[ti + j]);
if ovr > 0 then val.Add(rc, ovr);
for j := 0 to stdDev do
begin
if ri > re then
val.Add(rc) else
val.Add(src[ri]);
inc(ri);
val.Subtract(fv);
if ti <= re then
dst[ti] := val.Color;
inc(ti);
end;
for j := stdDev +1 to w - stdDev -1 do
begin
if ri <= re then
begin
val.Add(src[ri]); inc(ri);
val.Subtract(src[li]); inc(li);
end;
dst[ti] := val.Color; inc(ti);
end;
while ti <= re do
begin
if ti > re then Break;
val.Add(lv);
val.Subtract(src[li]); inc(li);
dst[ti] := val.Color;
inc(ti);
end;
end;
end;
//------------------------------------------------------------------------------
procedure BoxBlurV(var src, dst: TArrayOfColor32; w, h, stdDev: integer);
var
i,j, ti, li, ri, re, ovr: integer;
fv, lv, val: TWeightedColor;
rc: TColor32;
begin
ovr := Max(0, stdDev - h);
for i := 0 to w -1 do
begin
ti := i;
li := ti;
ri := ti + stdDev * w;
fv.Reset;
lv.Reset;
val.Reset;
re := ti +w *(h-1); // idx of last pixel in column
rc := src[re]; // color of last pixel in column
fv.Add(src[ti]);
lv.Add(rc, 1);
val.Add(src[ti], stdDev +1);
for j := 0 to stdDev -1 -ovr do
val.Add(src[ti + j *w]);
if ovr > 0 then val.Add(rc, ovr);
for j := 0 to stdDev do
begin
if ri > re then
val.Add(rc) else
val.Add(src[ri]);
inc(ri, w);
val.Subtract(fv);
if ti <= re then
dst[ti] := val.Color;
inc(ti, w);
end;
for j := stdDev +1 to h - stdDev -1 do
begin
if ri <= re then
begin
val.Add(src[ri]); inc(ri, w);
val.Subtract(src[li]); inc(li, w);
end;
dst[ti] := val.Color; inc(ti, w);
end;
while ti <= re do
begin
val.Add(lv);
val.Subtract(src[li]); inc(li, w);
dst[ti] := val.Color;
inc(ti, w);
end;
end;
end;
//------------------------------------------------------------------------------
procedure FastGaussianBlur(img: TImage32;
const rec: TRect; stdDev: integer; repeats: integer);
begin
FastGaussianBlur(img, rec, stdDev, stdDev, repeats);
end;
//------------------------------------------------------------------------------
procedure FastGaussianBlur(img: TImage32;
const rec: TRect; stdDevX, stdDevY: integer; repeats: integer);
var
i,j,len, w,h: integer;
rec2: TRect;
boxesH: TArrayOfInteger;
boxesV: TArrayOfInteger;
src, dst: TArrayOfColor32;
blurFullImage: Boolean;
pSrc, pDst: PColor32;
begin
if not Assigned(img) then Exit;
Types.IntersectRect(rec2, rec, img.Bounds);
if IsEmptyRect(rec2) then Exit;
blurFullImage := RectsEqual(rec2, img.Bounds);
RectWidthHeight(rec2, w, h);
if (Min(w, h) < 2) or ((stdDevX < 1) and (stdDevY < 1)) then Exit;
len := w * h;
SetLength(src, len);
SetLength(dst, len);
if blurFullImage then
begin
// copy the entire image into 'dst'
Move(img.PixelBase^, dst[0], len * SizeOf(TColor32));
end else
begin
// copy a rectangular region into 'dst'
pSrc := img.PixelRow[rec2.Top];
inc(pSrc, rec2.Left);
pDst := @dst[0];
for i := 0 to h -1 do
begin
Move(pSrc^, pDst^, w * SizeOf(TColor32));
inc(pSrc, img.Width);
inc(pDst, w);
end;
end;
// do the blur
inc(repeats); // now represents total iterations
boxesH := BoxesForGauss(stdDevX, repeats);
if stdDevY = stdDevX then
boxesV := boxesH else
boxesV := BoxesForGauss(stdDevY, repeats);
for j := 0 to repeats -1 do
begin
BoxBlurH(dst, src, w, h, boxesH[j]);
BoxBlurV(src, dst, w, h, boxesV[j]);
end;
// copy dst array back to image rect
img.BeginUpdate;
try
if blurFullImage then
begin
Move(dst[0], img.PixelBase^, len * SizeOf(TColor32));
end else
begin
pDst := img.PixelRow[rec2.Top];
inc(pDst, rec2.Left);
pSrc := @dst[0];
for i := 0 to h -1 do
begin
Move(pSrc^, pDst^, w * SizeOf(TColor32));
inc(pSrc, w);
inc(pDst, img.Width);
end;
end;
finally
img.EndUpdate;
end;
end;
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
// CurveFit() support structures and functions
//------------------------------------------------------------------------------
//CurveFit: this function is based on -
//"An Algorithm for Automatically Fitting Digitized Curves"
//by Philip J. Schneider in "Graphics Gems", Academic Press, 1990
//Smooths out many very closely positioned points
//tolerance range: 1..10 where 10 == max tolerance.
//This function has been archived as I believe that
//RamerDouglasPeuker(), GetSmoothPath() and FlattenCBezier()
//will usually achieve a better result
function Scale(const vec: TPointD; newLen: double): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result.X := vec.X * newLen;
Result.Y := vec.Y * newLen;
end;
//------------------------------------------------------------------------------
function Mul(const vec: TPointD; val: double): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result.X := vec.X * val;
Result.Y := vec.Y * val;
end;
//------------------------------------------------------------------------------
function AddVecs(const vec1, vec2: TPointD): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result.X := vec1.X + vec2.X;
Result.Y := vec1.Y + vec2.Y;
end;
//------------------------------------------------------------------------------
function SubVecs(const vec1, vec2: TPointD): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result.X := vec1.X - vec2.X;
Result.Y := vec1.Y - vec2.Y;
end;
//------------------------------------------------------------------------------
function NormalizeVec(const vec: TPointD): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
var
len: double;
begin
len := Sqrt(vec.X * vec.X + vec.Y * vec.Y);
if len <> 0 then
begin
Result.X := vec.X / len;
Result.Y := vec.Y / len;
end else
result := vec;
end;
//------------------------------------------------------------------------------
function NormalizeTPt(const pt: PPt): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
with pt^ do
if len <> 0 then
begin
Result.X := vec.X / len;
Result.Y := vec.Y / len;
end else
result := vec;
end;
//------------------------------------------------------------------------------
function NegateVec(vec: TPointD): TPointD;
{$IFDEF INLINE} inline; {$ENDIF}
begin
Result.X := -vec.X;
Result.Y := -vec.Y;
end;
//------------------------------------------------------------------------------
function B0(u: double): double; {$IFDEF INLINE} inline; {$ENDIF}
var
tmp: double;
begin
tmp := 1.0 - u;
result := tmp * tmp * tmp;
end;
//------------------------------------------------------------------------------
function B1(u: double): double; {$IFDEF INLINE} inline; {$ENDIF}
var
tmp: double;
begin
tmp := 1.0 - u;
result := 3 * u * tmp * tmp;
end;
//------------------------------------------------------------------------------
function B2(u: double): double; {$IFDEF INLINE} inline; {$ENDIF}
begin
result := 3 * u * u * (1.0 - u);
end;
//------------------------------------------------------------------------------
function B3(u: double): double; {$IFDEF INLINE} inline; {$ENDIF}
begin
result := u * u * u;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.AddPt(const pt: TPointD): PPt;
begin
new(Result);
Result.pt := pt;
if not assigned(ppts) then
begin
Result.prev := Result;
Result.next := Result;
ppts := Result;
end else
begin
Result.prev := ppts.prev;
ppts.prev.next := Result;
ppts.prev := Result;
Result.next := ppts;
end;
end;
//------------------------------------------------------------------------------
procedure TFitCurveContainer.Clear;
var
p: PPt;
begin
solution := nil;
ppts.prev.next := nil; //break loop
while assigned(ppts) do
begin
p := ppts;
ppts := ppts.next;
Dispose(p);
end;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.Count(first, last: PPt): integer;
begin
if first = last then
result := 0 else
result := 1;
repeat
inc(Result);
first := first.next;
until (first = last);
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.ComputeLeftTangent(p: PPt): TPointD;
begin
Result := NormalizeTPt(p);
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.ComputeRightTangent(p: PPt): TPointD;
begin
Result := NegateVec(NormalizeTPt(p.prev));
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.ComputeCenterTangent(p: PPt): TPointD;
var
v1, v2: TPointD;
begin
v1 := SubVecs(p.pt, p.prev.pt);
v2 := SubVecs(p.next.pt, p.pt);
Result := AddVecs(v1, v2);
Result := NormalizeVec(Result);
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.ChordLengthParameterize(
first: PPt; cnt: integer): TArrayOfDouble;
var
d: double;
i: integer;
begin
SetLength(Result, cnt);
Result[0] := 0;
d := 0;
for i := 1 to cnt -1 do
begin
d := d + first.len;
Result[i] := d;
first := first.next;
end;
for i := 1 to cnt -1 do
Result[i] := Result[i] / d;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.GenerateBezier(first, last: PPt; cnt: integer;
const u: TArrayOfDouble; const firstTan, lastTan: TPointD): TPathD;
var
i: integer;
p: PPt;
dist, epsilon: double;
v1,v2, tmp: TPointD;
a0, a1: TPathD;
c: array [0..1, 0..1] of double;
x: array [0..1] of double;
det_c0_c1, det_c0_x, det_x_c1, alphaL, alphaR: double;
begin
SetLength(a0, cnt);
SetLength(a1, cnt);
dist := Distance(first.pt, last.pt);
for i := 0 to cnt -1 do
begin
v1 := Scale(firstTan, B1(u[i]));
v2 := Scale(lastTan, B2(u[i]));
a0[i] := v1;
a1[i] := v2;
end;
FillChar(c[0][0], 4 * SizeOf(double), 0);
FillChar(x[0], 2 * SizeOf(double), 0);
p := first;
for i := 0 to cnt -1 do
begin
c[0][0] := c[0][0] + DotProdVecs(a0[i], (a0[i]));
c[0][1] := c[0][1] + DotProdVecs(a0[i], (a1[i]));
c[1][0] := c[0][1];
c[1][1] := c[1][1] + DotProdVecs(a1[i], (a1[i]));
tmp := SubVecs(p.pt,
AddVecs(Mul(first.pt, B0(u[i])),
AddVecs(Mul(first.pt, B1(u[i])),
AddVecs(Mul(last.pt, B2(u[i])),
Mul(last.pt, B3(u[i]))))));
x[0] := x[0] + DotProdVecs(a0[i], tmp);
x[1] := x[1] + DotProdVecs(a1[i], tmp);
p := p.next;
end;
det_c0_c1 := c[0][0] * c[1][1] - c[1][0] * c[0][1];
det_c0_x := c[0][0] * x[1] - c[1][0] * x[0];
det_x_c1 := x[0] * c[1][1] - x[1] * c[0][1];
if det_c0_c1 = 0 then
alphaL := 0 else
alphaL := det_x_c1 / det_c0_c1;
if det_c0_c1 = 0 then
alphaR := 0 else
alphaR := det_c0_x / det_c0_c1;
//check for unlikely fit
if (alphaL > dist * 2) then alphaL := 0
else if (alphaR > dist * 2) then alphaR := 0;
epsilon := 1.0e-6 * dist;
SetLength(Result, 4);
Result[0] := first.pt;
Result[3] := last.pt;
if (alphaL < epsilon) or (alphaR < epsilon) then
begin
dist := dist / 3;
Result[1] := AddVecs(Result[0], Scale(firstTan, dist));
Result[2] := AddVecs(Result[3], Scale(lastTan, dist));
end else
begin
Result[1] := AddVecs(Result[0], Scale(firstTan, alphaL));
Result[2] := AddVecs(Result[3], Scale(lastTan, alphaR));
end;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.Reparameterize(first: PPt; cnt: integer;
const u: TArrayOfDouble; const bezier: TPathD): TArrayOfDouble;
var
i: integer;
begin
SetLength(Result, cnt);
for i := 0 to cnt -1 do
begin
Result[i] := NewtonRaphsonRootFind(bezier, first.pt, u[i]);
first := first.next;
end;
end;
//------------------------------------------------------------------------------
function BezierII(degree: integer; const v: array of TPointD; t: double): TPointD;
var
i,j: integer;
tmp: array[0..3] of TPointD;
begin
Move(v[0], tmp[0], degree * sizeOf(TPointD));
for i := 1 to degree do
for j := 0 to degree - i do
begin
tmp[j].x := (1.0 - t) * tmp[j].x + t * tmp[j+1].x;
tmp[j].y := (1.0 - t) * tmp[j].y + t * tmp[j+1].y;
end;
Result := tmp[0];
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.ComputeMaxErrorSqrd(first, last: PPt;
const bezier: TPathD; const u: TArrayOfDouble;
out SplitPoint: PPt): double;
var
i: integer;
distSqrd: double;
pt: TPointD;
p: PPt;
begin
Result := 0;
i := 1;
SplitPoint := first.next;
p := first.next;
while p <> last do
begin
pt := BezierII(3, bezier, u[i]);
distSqrd := DistanceSqrd(pt, p.pt);
if (distSqrd >= Result) then
begin
Result := distSqrd;
SplitPoint := p;
end;
inc(i);
p := p.next;
end;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.NewtonRaphsonRootFind(const q: TPathD;
const pt: TPointD; u: double): double;
var
numerator, denominator: double;
qu, q1u, q2u: TPointD;
q1: array[0..2] of TPointD;
q2: array[0..1] of TPointD;
begin
q1[0].x := (q[1].x - q[0].x) * 3.0;
q1[0].y := (q[1].y - q[0].y) * 3.0;
q1[1].x := (q[2].x - q[1].x) * 3.0;
q1[1].y := (q[2].y - q[1].y) * 3.0;
q1[2].x := (q[3].x - q[2].x) * 3.0;
q1[2].y := (q[3].y - q[2].y) * 3.0;
q2[0].x := (q1[1].x - q1[0].x) * 2.0;
q2[0].y := (q1[1].y - q1[0].y) * 2.0;
q2[1].x := (q1[2].x - q1[1].x) * 2.0;
q2[1].y := (q1[2].y - q1[1].y) * 2.0;
qu := BezierII(3, q, u);
q1u := BezierII(2, q1, u);
q2u := BezierII(1, q2, u);
numerator := (qu.x - pt.x) * (q1u.x) + (qu.y - pt.y) * (q1u.y);
denominator := (q1u.x) * (q1u.x) + (q1u.y) * (q1u.y) +
(qu.x - pt.x) * (q2u.x) + (qu.y - pt.y) * (q2u.y);
if (denominator = 0) then
Result := u else
Result := u - (numerator / denominator);
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.FitCubic(first, last: PPt;
firstTan, lastTan: TPointD): Boolean;
var
i, cnt: integer;
splitPoint: PPt;
centerTan: TPointD;
bezier: TPathD;
clps, uPrime: TArrayOfDouble;
maxErrorSqrd: double;
const
maxRetries = 4;
begin
Result := true;
cnt := Count(first, last);
if cnt = 2 then
begin
SetLength(bezier, 4);
bezier[0] := first.pt;
bezier[3] := last.pt;
bezier[1] := bezier[0];
bezier[2] := bezier[3];
AppendSolution(bezier);
Exit;
end
else if cnt = 3 then
begin
if TurnsLeft(first.prev.pt, first.pt, first.next.pt) =
TurnsLeft(first.pt, first.next.pt, last.pt) then
firstTan := ComputeCenterTangent(first);
if TurnsLeft(last.prev.pt, last.pt, last.next.pt) =
TurnsLeft(first.pt, first.next.pt, last.pt) then
lastTan := NegateVec(ComputeCenterTangent(last));
end;
clps := ChordLengthParameterize(first, cnt);
bezier := GenerateBezier(first, last, cnt, clps, firstTan, lastTan);
maxErrorSqrd := ComputeMaxErrorSqrd(first, last, bezier, clps, splitPoint);
if (maxErrorSqrd < tolSqrd) then
begin
AppendSolution(bezier);
Exit;
end;
if (maxErrorSqrd < tolSqrd * 4) then //close enough to try again
begin
for i := 1 to maxRetries do
begin
uPrime := Reparameterize(first, cnt, clps, bezier);
bezier := GenerateBezier(first, last, cnt, uPrime, firstTan, lastTan);
maxErrorSqrd :=
ComputeMaxErrorSqrd(first, last, bezier, uPrime, splitPoint);
if (maxErrorSqrd < tolSqrd) then
begin
AppendSolution(bezier);
Exit;
end;
clps := uPrime;
end;
end;
//We need to break the curve because it's too complex for a single Bezier.
//If we're changing direction then make this a 'hard' break (see below).
if TurnsLeft(splitPoint.prev.prev.pt, splitPoint.prev.pt, splitPoint.pt) <>
TurnsLeft(splitPoint.prev.pt, splitPoint.pt, splitPoint.next.pt) then
begin
centerTan := ComputeRightTangent(splitPoint);
FitCubic(first, splitPoint, firstTan, centerTan);
centerTan := ComputeLeftTangent(splitPoint);
FitCubic(splitPoint, last, centerTan, lastTan);
end else
begin
centerTan := ComputeCenterTangent(splitPoint);
FitCubic(first, splitPoint, firstTan, NegateVec(centerTan));
FitCubic(splitPoint, last, centerTan, lastTan);
end;
end;
//------------------------------------------------------------------------------
function HardBreakCheck(ppt: PPt; compareLen: double): Boolean;
var
q: double;
const
longLen = 15;
begin
//A 'break' means starting a new Bezier. A 'hard' break avoids smoothing
//whereas a 'soft' break will still be smoothed. There is as much art as
//science in determining where to smooth and where not to. For example,
//long edges should generally remain straight but how long does an edge
//have to be to be considered a 'long' edge?
if (ppt.prev.len * 4 < ppt.len) or (ppt.len * 4 < ppt.prev.len) then
begin
//We'll hard break whenever there's significant asymmetry between
//segment lengths because GenerateBezier() will perform poorly.
result := true;
end
else if ((ppt.prev.len > longLen) and (ppt.len > longLen)) then
begin
//hard break long segments only when turning by more than ~45 degrees
q := (Sqr(ppt.prev.len) + Sqr(ppt.len) - DistanceSqrd(ppt.prev.pt, ppt.next.pt)) /
(2 * ppt.prev.len * ppt.len); //Cosine Rule.
result := (1 - abs(q)) > 0.3;
end
else if ((TurnsLeft(ppt.prev.prev.pt, ppt.prev.pt, ppt.pt) =
TurnsRight(ppt.prev.pt, ppt.pt, ppt.next.pt)) and
(ppt.prev.len > compareLen) and (ppt.len > compareLen)) then
begin
//we'll also hard break whenever there's a significant inflection point
result := true;
end else
begin
//Finally, we'll also force a 'hard' break when there's a significant bend.
//Again uses the Cosine Rule.
q :=(Sqr(ppt.prev.len) + Sqr(ppt.len) -
DistanceSqrd(ppt.prev.pt, ppt.next.pt)) / (2 * ppt.prev.len * ppt.len);
Result := (q > -0.2); //ie more than 90%
end;
end;
//------------------------------------------------------------------------------
function TFitCurveContainer.FitCurve(const path: TPathD;
closed: Boolean; tolerance: double; minSegLength: double): TPathD;
var
i, highI: integer;
d: double;
p, p2, pEnd: PPt;
begin
//tolerance: specifies the maximum allowed variance between the existing
//vertices and the new Bezier curves. More tolerance will produce
//fewer Beziers and simpler paths, but at the cost of less precison.
tolSqrd := Sqr(Max(1, Min(10, tolerance))); //range 1..10
//minSegLength: Typically when vectorizing raster images, the produced
//vector paths will have many series of axis aligned segments that trace
//pixel boundaries. These paths will also contain many 1 unit segments at
//right angles to adjacent segments. Importantly, these very short segments
//will cause artifacts in the solution unless they are trimmed.
highI := High(path);
if closed then
while (highI > 0) and (Distance(path[highI], path[0]) < minSegLength) do
dec(highI);
p := AddPt(path[0]);
for i := 1 to highI do
begin
d := Distance(p.pt, path[i]);
//skip line segments with lengths less than 'minSegLength'
if d < minSegLength then Continue;
p := AddPt(path[i]);
p.prev.len := d;
p.prev.vec := SubVecs(p.pt, p.prev.pt);
end;
p.len := Distance(ppts.pt, p.pt);
p.vec := SubVecs(p.next.pt, p.pt);
p := ppts;
if (p.next = p) or (closed and (p.next = p.prev)) then
begin
Clear;
result := nil;
Exit;
end;
//for closed paths, find a good starting point
if closed then
begin
repeat
if HardBreakCheck(p, tolerance) then break;
p := p.next;
until p = ppts;
pEnd := p;
end else
pEnd := ppts.prev;
p2 := p.next;
repeat
if HardBreakCheck(p2, tolerance) then
begin
FitCubic(p, p2, ComputeLeftTangent(p), ComputeRightTangent(p2));
p := p2;
end;
p2 := p2.next;
until (p2 = pEnd);
FitCubic(p, p2, ComputeLeftTangent(p), ComputeRightTangent(p2));
Result := solution;
Clear;
end;
//------------------------------------------------------------------------------
procedure TFitCurveContainer.AppendSolution(const bezier: TPathD);
var
i, len: integer;
begin
len := Length(solution);
if len > 0 then
begin
SetLength(solution, len + 3);
for i := 0 to 2 do
solution[len +i] := bezier[i +1];
end else
solution := bezier;
end;
//------------------------------------------------------------------------------
function CurveFit(const path: TPathD; closed: Boolean;
tolerance: double; minSegLength: double): TPathD;
var
paths, solution: TPathsD;
begin
SetLength(paths, 1);
paths[0] := path;
solution := CurveFit(paths, closed, tolerance, minSegLength);
if solution <> nil then
Result := solution[0];
end;
//------------------------------------------------------------------------------
function CurveFit(const paths: TPathsD; closed: Boolean;
tolerance: double; minSegLength: double): TPathsD;
var
i,j, len: integer;
begin
j := 0;
len := Length(paths);
SetLength(Result, len);
with TFitCurveContainer.Create do
try
for i := 0 to len -1 do
if (paths[i] <> nil) and (Abs(Area(paths[i])) > Sqr(tolerance)) then
begin
Result[j] := FitCurve(paths[i], closed, tolerance, minSegLength);
inc(j);
end;
finally
Free;
end;
SetLength(Result, j);
end;
//------------------------------------------------------------------------------
end.